From 877e90fa64a6c8bbb6fa653c81a885e95c6265b2 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:50:23 +0200 Subject: [PATCH 01/19] Profiler: plug profiler in env --- .../environment_V10.ml | 22 ++- .../environment_V11.ml | 18 ++- .../environment_V12.ml | 18 ++- .../environment_V13.ml | 18 ++- .../environment_V9.ml | 21 ++- .../environment_profiler.ml | 10 ++ src/lib_protocol_environment/sigs/v10.in.ml | 2 + src/lib_protocol_environment/sigs/v10.ml | 137 +++++++++++------- .../sigs/v10/profiler.mli | 23 +++ src/lib_protocol_environment/sigs/v11.in.ml | 2 + src/lib_protocol_environment/sigs/v11.ml | 137 +++++++++++------- .../sigs/v11/profiler.mli | 23 +++ src/lib_protocol_environment/sigs/v12.in.ml | 2 + src/lib_protocol_environment/sigs/v12.ml | 137 +++++++++++------- .../sigs/v12/profiler.mli | 23 +++ src/lib_protocol_environment/sigs/v13.in.ml | 2 + src/lib_protocol_environment/sigs/v13.ml | 137 +++++++++++------- .../sigs/v13/profiler.mli | 23 +++ src/lib_protocol_environment/sigs/v9.in.ml | 2 + src/lib_protocol_environment/sigs/v9.ml | 131 ++++++++++------- .../sigs/v9/profiler.mli | 23 +++ .../tezos_protocol_environment.ml | 1 + 22 files changed, 640 insertions(+), 272 deletions(-) create mode 100644 src/lib_protocol_environment/environment_profiler.ml create mode 100644 src/lib_protocol_environment/sigs/v10/profiler.mli create mode 100644 src/lib_protocol_environment/sigs/v11/profiler.mli create mode 100644 src/lib_protocol_environment/sigs/v12/profiler.mli create mode 100644 src/lib_protocol_environment/sigs/v13/profiler.mli create mode 100644 src/lib_protocol_environment/sigs/v9/profiler.mli diff --git a/src/lib_protocol_environment/environment_V10.ml b/src/lib_protocol_environment/environment_V10.ml index 15378729c7e9..970959a1ff3d 100644 --- a/src/lib_protocol_environment/environment_V10.ml +++ b/src/lib_protocol_environment/environment_V10.ml @@ -189,6 +189,7 @@ struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib module Pervasives = Stdlib + module Profiler = Environment_profiler module Logging = struct type level = Internal_event.level = @@ -319,7 +320,22 @@ struct module Secp256k1 = Tezos_crypto.Signature.Secp256k1 module P256 = Tezos_crypto.Signature.P256 module Bls = Tezos_crypto.Signature.Bls - module Signature = Tezos_crypto.Signature.V1 + + module Signature = struct + include Tezos_crypto.Signature.V1 + + let check ?watermark pk s bytes = + Profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ] + (fun () -> check ?watermark pk s bytes) + end + module Timelock = Tezos_crypto.Timelock module Vdf = Class_group_vdf.Vdf_self_contained @@ -1234,6 +1250,9 @@ struct in let*? f = wrap_tzresult r in return (fun x -> + Environment_profiler.record_s + (Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)) + @@ fun () -> let*! r = f x in Lwt.return (wrap_tzresult r)) @@ -1241,6 +1260,7 @@ struct before running any operations. *) let load_predecessor_cache predecessor_context chain_id mode (predecessor_header : Block_header.shell_header) cache = + Environment_profiler.record_s "load_predecessor_cache" @@ fun () -> let open Lwt_result_syntax in let predecessor_hash, timestamp = match mode with diff --git a/src/lib_protocol_environment/environment_V11.ml b/src/lib_protocol_environment/environment_V11.ml index 7ec8dcaa2f42..ddc4336cfb15 100644 --- a/src/lib_protocol_environment/environment_V11.ml +++ b/src/lib_protocol_environment/environment_V11.ml @@ -189,6 +189,7 @@ struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib module Pervasives = Stdlib + module Profiler = Environment_profiler module Logging = struct type level = Internal_event.level = @@ -330,7 +331,22 @@ struct module Secp256k1 = Tezos_crypto.Signature.Secp256k1 module P256 = Tezos_crypto.Signature.P256 module Bls = Tezos_crypto.Signature.Bls - module Signature = Tezos_crypto.Signature.V1 + + module Signature = struct + include Tezos_crypto.Signature.V1 + + let check ?watermark pk s bytes = + Profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ] + (fun () -> check ?watermark pk s bytes) + end + module Timelock = Tezos_crypto.Timelock module Vdf = Class_group_vdf.Vdf_self_contained diff --git a/src/lib_protocol_environment/environment_V12.ml b/src/lib_protocol_environment/environment_V12.ml index 17c5cec90358..db8a2c605315 100644 --- a/src/lib_protocol_environment/environment_V12.ml +++ b/src/lib_protocol_environment/environment_V12.ml @@ -189,6 +189,7 @@ struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib module Pervasives = Stdlib + module Profiler = Environment_profiler module Logging = struct type level = Internal_event.level = @@ -330,7 +331,22 @@ struct module Secp256k1 = Tezos_crypto.Signature.Secp256k1 module P256 = Tezos_crypto.Signature.P256 module Bls = Tezos_crypto.Signature.Bls - module Signature = Tezos_crypto.Signature.V1 + + module Signature = struct + include Tezos_crypto.Signature.V1 + + let check ?watermark pk s bytes = + Profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ] + (fun () -> check ?watermark pk s bytes) + end + module Timelock = Tezos_crypto.Timelock module Vdf = Class_group_vdf.Vdf_self_contained diff --git a/src/lib_protocol_environment/environment_V13.ml b/src/lib_protocol_environment/environment_V13.ml index e16c5f632521..ef7598fa9025 100644 --- a/src/lib_protocol_environment/environment_V13.ml +++ b/src/lib_protocol_environment/environment_V13.ml @@ -189,6 +189,7 @@ struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib module Pervasives = Stdlib + module Profiler = Environment_profiler module Logging = struct type level = Internal_event.level = @@ -330,7 +331,22 @@ struct module Secp256k1 = Tezos_crypto.Signature.Secp256k1 module P256 = Tezos_crypto.Signature.P256 module Bls = Tezos_crypto.Signature.Bls - module Signature = Tezos_crypto.Signature.V1 + + module Signature = struct + include Tezos_crypto.Signature.V1 + + let check ?watermark pk s bytes = + Profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ] + (fun () -> check ?watermark pk s bytes) + end + module Timelock = Tezos_crypto.Timelock module Vdf = Class_group_vdf.Vdf_self_contained diff --git a/src/lib_protocol_environment/environment_V9.ml b/src/lib_protocol_environment/environment_V9.ml index 819d38543812..5681b7be1021 100644 --- a/src/lib_protocol_environment/environment_V9.ml +++ b/src/lib_protocol_environment/environment_V9.ml @@ -177,6 +177,7 @@ struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib module Pervasives = Stdlib + module Profiler = Environment_profiler module Logging = struct type level = Internal_event.level = @@ -307,7 +308,22 @@ struct module Secp256k1 = Tezos_crypto.Signature.Secp256k1 module P256 = Tezos_crypto.Signature.P256 module Bls = Tezos_crypto.Signature.Bls - module Signature = Tezos_crypto.Signature.V1 + + module Signature = struct + include Tezos_crypto.Signature.V1 + + let check ?watermark pk s bytes = + Profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ] + (fun () -> check ?watermark pk s bytes) + end + module Timelock = Tezos_crypto.Timelock_legacy module Vdf = Class_group_vdf.Vdf_self_contained @@ -1206,6 +1222,9 @@ struct in let*? f = wrap_tzresult r in return (fun x -> + Environment_profiler.record_s + (Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)) + @@ fun () -> let*! r = f x in Lwt.return (wrap_tzresult r)) diff --git a/src/lib_protocol_environment/environment_profiler.ml b/src/lib_protocol_environment/environment_profiler.ml new file mode 100644 index 000000000000..24535d4d3f10 --- /dev/null +++ b/src/lib_protocol_environment/environment_profiler.ml @@ -0,0 +1,10 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +let profiler = Profiler.unplugged () + +include (val Profiler.wrap profiler) diff --git a/src/lib_protocol_environment/sigs/v10.in.ml b/src/lib_protocol_environment/sigs/v10.in.ml index a93820c15a60..f4a63a332eed 100644 --- a/src/lib_protocol_environment/sigs/v10.in.ml +++ b/src/lib_protocol_environment/sigs/v10.in.ml @@ -31,6 +31,8 @@ module type T = sig module Lwt : [%sig "v10/lwt.mli"] + module Profiler : [%sig "v10/profiler.mli"] + module Data_encoding : [%sig "v10/data_encoding.mli"] module Raw_hashes : [%sig "v10/raw_hashes.mli"] diff --git a/src/lib_protocol_environment/sigs/v10.ml b/src/lib_protocol_environment/sigs/v10.ml index 70da4339c8fb..369dbff3632e 100644 --- a/src/lib_protocol_environment/sigs/v10.ml +++ b/src/lib_protocol_environment/sigs/v10.ml @@ -3461,6 +3461,35 @@ end # 32 "v10.in.ml" + module Profiler : sig +# 1 "v10/profiler.mli" +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end +# 34 "v10.in.ml" + + module Data_encoding : sig # 1 "v10/data_encoding.mli" (*****************************************************************************) @@ -5211,7 +5240,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 34 "v10.in.ml" +# 36 "v10.in.ml" module Raw_hashes : sig @@ -5253,7 +5282,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 36 "v10.in.ml" +# 38 "v10.in.ml" module Compare : sig @@ -5534,7 +5563,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 38 "v10.in.ml" +# 40 "v10.in.ml" module Time : sig @@ -5588,7 +5617,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 40 "v10.in.ml" +# 42 "v10.in.ml" module TzEndian : sig @@ -5654,7 +5683,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 42 "v10.in.ml" +# 44 "v10.in.ml" module Bits : sig @@ -5691,7 +5720,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 44 "v10.in.ml" +# 46 "v10.in.ml" module Equality_witness : sig @@ -5759,7 +5788,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 46 "v10.in.ml" +# 48 "v10.in.ml" module FallbackArray : sig @@ -5849,7 +5878,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 48 "v10.in.ml" +# 50 "v10.in.ml" module Error_monad : sig @@ -6283,7 +6312,7 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v10.in.ml" +# 52 "v10.in.ml" open Error_monad @@ -6410,7 +6439,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v10.in.ml" +# 56 "v10.in.ml" module List : sig @@ -7697,7 +7726,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v10.in.ml" +# 58 "v10.in.ml" module Array : sig @@ -7807,7 +7836,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v10.in.ml" +# 60 "v10.in.ml" module Set : sig @@ -7956,7 +7985,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v10.in.ml" +# 62 "v10.in.ml" module Map : sig @@ -8125,7 +8154,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v10.in.ml" +# 64 "v10.in.ml" module Option : sig @@ -8273,7 +8302,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 64 "v10.in.ml" +# 66 "v10.in.ml" module Result : sig @@ -8439,7 +8468,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v10.in.ml" +# 68 "v10.in.ml" module RPC_arg : sig @@ -8509,7 +8538,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v10.in.ml" +# 70 "v10.in.ml" module RPC_path : sig @@ -8565,7 +8594,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v10.in.ml" +# 72 "v10.in.ml" module RPC_query : sig @@ -8637,7 +8666,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v10.in.ml" +# 74 "v10.in.ml" module RPC_service : sig @@ -8714,7 +8743,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v10.in.ml" +# 76 "v10.in.ml" module RPC_answer : sig @@ -8775,7 +8804,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v10.in.ml" +# 78 "v10.in.ml" module RPC_directory : sig @@ -9045,7 +9074,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v10.in.ml" +# 80 "v10.in.ml" module Base58 : sig @@ -9110,7 +9139,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v10.in.ml" +# 82 "v10.in.ml" module S : sig @@ -9487,7 +9516,7 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v10.in.ml" +# 84 "v10.in.ml" module Blake2B : sig @@ -9552,7 +9581,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v10.in.ml" +# 86 "v10.in.ml" module Bls : sig @@ -9598,7 +9627,7 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v10.in.ml" +# 88 "v10.in.ml" module Ed25519 : sig @@ -9632,7 +9661,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v10.in.ml" +# 90 "v10.in.ml" module Secp256k1 : sig @@ -9666,7 +9695,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v10.in.ml" +# 92 "v10.in.ml" module P256 : sig @@ -9700,7 +9729,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v10.in.ml" +# 94 "v10.in.ml" module Chain_id : sig @@ -9732,7 +9761,7 @@ end include S.HASH end -# 94 "v10.in.ml" +# 96 "v10.in.ml" module Signature : sig @@ -9800,7 +9829,7 @@ include val size : t -> int end -# 96 "v10.in.ml" +# 98 "v10.in.ml" module Block_hash : sig @@ -9833,7 +9862,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v10.in.ml" +# 100 "v10.in.ml" module Operation_hash : sig @@ -9866,7 +9895,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v10.in.ml" +# 102 "v10.in.ml" module Operation_list_hash : sig @@ -9899,7 +9928,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v10.in.ml" +# 104 "v10.in.ml" module Operation_list_list_hash : sig @@ -9932,7 +9961,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v10.in.ml" +# 106 "v10.in.ml" module Protocol_hash : sig @@ -9965,7 +9994,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v10.in.ml" +# 108 "v10.in.ml" module Context_hash : sig @@ -10018,7 +10047,7 @@ end type version = Version.t end -# 108 "v10.in.ml" +# 110 "v10.in.ml" module Sapling : sig @@ -10166,7 +10195,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v10.in.ml" +# 112 "v10.in.ml" module Timelock : sig @@ -10223,7 +10252,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v10.in.ml" +# 114 "v10.in.ml" module Vdf : sig @@ -10311,7 +10340,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v10.in.ml" +# 116 "v10.in.ml" module Micheline : sig @@ -10371,7 +10400,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v10.in.ml" +# 118 "v10.in.ml" module Block_header : sig @@ -10428,7 +10457,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v10.in.ml" +# 120 "v10.in.ml" module Bounded : sig @@ -10577,7 +10606,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v10.in.ml" +# 122 "v10.in.ml" module Fitness : sig @@ -10611,7 +10640,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v10.in.ml" +# 124 "v10.in.ml" module Operation : sig @@ -10655,7 +10684,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v10.in.ml" +# 126 "v10.in.ml" module Context : sig @@ -11292,7 +11321,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v10.in.ml" +# 128 "v10.in.ml" module Updater : sig @@ -11837,7 +11866,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v10.in.ml" +# 130 "v10.in.ml" module RPC_context : sig @@ -11991,7 +12020,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v10.in.ml" +# 132 "v10.in.ml" module Context_binary : sig @@ -12034,7 +12063,7 @@ module Tree : val make_empty_context : ?root:string -> unit -> t end -# 132 "v10.in.ml" +# 134 "v10.in.ml" module Wasm_2_0_0 : sig @@ -12110,7 +12139,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 134 "v10.in.ml" +# 136 "v10.in.ml" module Plonk : sig @@ -12229,7 +12258,7 @@ val scalar_array_encoding : scalar array Data_encoding.t on the given [inputs] according to the [public_parameters]. *) val verify : public_parameters -> verifier_inputs -> proof -> bool end -# 136 "v10.in.ml" +# 138 "v10.in.ml" module Dal : sig @@ -12352,7 +12381,7 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 138 "v10.in.ml" +# 140 "v10.in.ml" module Skip_list : sig @@ -12584,7 +12613,7 @@ module Make (_ : sig val basis : int end) : S end -# 140 "v10.in.ml" +# 142 "v10.in.ml" module Smart_rollup : sig @@ -12641,6 +12670,6 @@ module Inbox_hash : S.HASH (** Smart rollup merkelized payload hashes' hash *) module Merkelized_payload_hashes_hash : S.HASH end -# 142 "v10.in.ml" +# 144 "v10.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v10/profiler.mli b/src/lib_protocol_environment/sigs/v10/profiler.mli new file mode 100644 index 000000000000..95e641049739 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v10/profiler.mli @@ -0,0 +1,23 @@ +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v11.in.ml b/src/lib_protocol_environment/sigs/v11.in.ml index 8d6d7f6c0dd7..ccda1b6c5ef1 100644 --- a/src/lib_protocol_environment/sigs/v11.in.ml +++ b/src/lib_protocol_environment/sigs/v11.in.ml @@ -31,6 +31,8 @@ module type T = sig module Lwt : [%sig "v11/lwt.mli"] + module Profiler : [%sig "v10/profiler.mli"] + module Data_encoding : [%sig "v11/data_encoding.mli"] module Raw_hashes : [%sig "v11/raw_hashes.mli"] diff --git a/src/lib_protocol_environment/sigs/v11.ml b/src/lib_protocol_environment/sigs/v11.ml index 5ff2e686d67c..bb93656c8d0a 100644 --- a/src/lib_protocol_environment/sigs/v11.ml +++ b/src/lib_protocol_environment/sigs/v11.ml @@ -3497,6 +3497,35 @@ end # 32 "v11.in.ml" + module Profiler : sig +# 1 "v10/profiler.mli" +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end +# 34 "v11.in.ml" + + module Data_encoding : sig # 1 "v11/data_encoding.mli" (*****************************************************************************) @@ -5263,7 +5292,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 34 "v11.in.ml" +# 36 "v11.in.ml" module Raw_hashes : sig @@ -5305,7 +5334,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 36 "v11.in.ml" +# 38 "v11.in.ml" module Compare : sig @@ -5586,7 +5615,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 38 "v11.in.ml" +# 40 "v11.in.ml" module Time : sig @@ -5640,7 +5669,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 40 "v11.in.ml" +# 42 "v11.in.ml" module TzEndian : sig @@ -5706,7 +5735,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 42 "v11.in.ml" +# 44 "v11.in.ml" module Bits : sig @@ -5743,7 +5772,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 44 "v11.in.ml" +# 46 "v11.in.ml" module Equality_witness : sig @@ -5811,7 +5840,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 46 "v11.in.ml" +# 48 "v11.in.ml" module FallbackArray : sig @@ -5901,7 +5930,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 48 "v11.in.ml" +# 50 "v11.in.ml" module Error_monad : sig @@ -6310,7 +6339,7 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v11.in.ml" +# 52 "v11.in.ml" open Error_monad @@ -6437,7 +6466,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v11.in.ml" +# 56 "v11.in.ml" module List : sig @@ -7724,7 +7753,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v11.in.ml" +# 58 "v11.in.ml" module Array : sig @@ -7834,7 +7863,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v11.in.ml" +# 60 "v11.in.ml" module Set : sig @@ -7983,7 +8012,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v11.in.ml" +# 62 "v11.in.ml" module Map : sig @@ -8152,7 +8181,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v11.in.ml" +# 64 "v11.in.ml" module Option : sig @@ -8300,7 +8329,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 64 "v11.in.ml" +# 66 "v11.in.ml" module Result : sig @@ -8466,7 +8495,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v11.in.ml" +# 68 "v11.in.ml" module RPC_arg : sig @@ -8536,7 +8565,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v11.in.ml" +# 70 "v11.in.ml" module RPC_path : sig @@ -8592,7 +8621,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v11.in.ml" +# 72 "v11.in.ml" module RPC_query : sig @@ -8664,7 +8693,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v11.in.ml" +# 74 "v11.in.ml" module RPC_service : sig @@ -8741,7 +8770,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v11.in.ml" +# 76 "v11.in.ml" module RPC_answer : sig @@ -8802,7 +8831,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v11.in.ml" +# 78 "v11.in.ml" module RPC_directory : sig @@ -9072,7 +9101,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v11.in.ml" +# 80 "v11.in.ml" module Base58 : sig @@ -9137,7 +9166,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v11.in.ml" +# 82 "v11.in.ml" module S : sig @@ -9514,7 +9543,7 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v11.in.ml" +# 84 "v11.in.ml" module Blake2B : sig @@ -9579,7 +9608,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v11.in.ml" +# 86 "v11.in.ml" module Bls : sig @@ -9625,7 +9654,7 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v11.in.ml" +# 88 "v11.in.ml" module Ed25519 : sig @@ -9659,7 +9688,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v11.in.ml" +# 90 "v11.in.ml" module Secp256k1 : sig @@ -9693,7 +9722,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v11.in.ml" +# 92 "v11.in.ml" module P256 : sig @@ -9727,7 +9756,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v11.in.ml" +# 94 "v11.in.ml" module Chain_id : sig @@ -9759,7 +9788,7 @@ end include S.HASH end -# 94 "v11.in.ml" +# 96 "v11.in.ml" module Signature : sig @@ -9827,7 +9856,7 @@ include val size : t -> int end -# 96 "v11.in.ml" +# 98 "v11.in.ml" module Block_hash : sig @@ -9860,7 +9889,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v11.in.ml" +# 100 "v11.in.ml" module Operation_hash : sig @@ -9893,7 +9922,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v11.in.ml" +# 102 "v11.in.ml" module Operation_list_hash : sig @@ -9926,7 +9955,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v11.in.ml" +# 104 "v11.in.ml" module Operation_list_list_hash : sig @@ -9959,7 +9988,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v11.in.ml" +# 106 "v11.in.ml" module Protocol_hash : sig @@ -9992,7 +10021,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v11.in.ml" +# 108 "v11.in.ml" module Context_hash : sig @@ -10045,7 +10074,7 @@ end type version = Version.t end -# 108 "v11.in.ml" +# 110 "v11.in.ml" module Sapling : sig @@ -10193,7 +10222,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v11.in.ml" +# 112 "v11.in.ml" module Timelock : sig @@ -10250,7 +10279,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v11.in.ml" +# 114 "v11.in.ml" module Vdf : sig @@ -10338,7 +10367,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v11.in.ml" +# 116 "v11.in.ml" module Micheline : sig @@ -10398,7 +10427,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v11.in.ml" +# 118 "v11.in.ml" module Block_header : sig @@ -10455,7 +10484,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v11.in.ml" +# 120 "v11.in.ml" module Bounded : sig @@ -10604,7 +10633,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v11.in.ml" +# 122 "v11.in.ml" module Fitness : sig @@ -10638,7 +10667,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v11.in.ml" +# 124 "v11.in.ml" module Operation : sig @@ -10682,7 +10711,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v11.in.ml" +# 126 "v11.in.ml" module Context : sig @@ -11319,7 +11348,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v11.in.ml" +# 128 "v11.in.ml" module Updater : sig @@ -11864,7 +11893,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v11.in.ml" +# 130 "v11.in.ml" module RPC_context : sig @@ -12018,7 +12047,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v11.in.ml" +# 132 "v11.in.ml" module Context_binary : sig @@ -12061,7 +12090,7 @@ module Tree : val make_empty_context : ?root:string -> unit -> t end -# 132 "v11.in.ml" +# 134 "v11.in.ml" module Wasm_2_0_0 : sig @@ -12135,7 +12164,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 134 "v11.in.ml" +# 136 "v11.in.ml" module Plonk : sig @@ -12254,7 +12283,7 @@ val scalar_array_encoding : scalar array Data_encoding.t on the given [inputs] according to the [public_parameters]. *) val verify : public_parameters -> verifier_inputs -> proof -> bool end -# 136 "v11.in.ml" +# 138 "v11.in.ml" module Dal : sig @@ -12377,7 +12406,7 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 138 "v11.in.ml" +# 140 "v11.in.ml" module Skip_list : sig @@ -12609,7 +12638,7 @@ module Make (_ : sig val basis : int end) : S end -# 140 "v11.in.ml" +# 142 "v11.in.ml" module Smart_rollup : sig @@ -12666,6 +12695,6 @@ module Inbox_hash : S.HASH (** Smart rollup merkelized payload hashes' hash *) module Merkelized_payload_hashes_hash : S.HASH end -# 142 "v11.in.ml" +# 144 "v11.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v11/profiler.mli b/src/lib_protocol_environment/sigs/v11/profiler.mli new file mode 100644 index 000000000000..95e641049739 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v11/profiler.mli @@ -0,0 +1,23 @@ +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v12.in.ml b/src/lib_protocol_environment/sigs/v12.in.ml index c85bdccaa6ee..48889f316e90 100644 --- a/src/lib_protocol_environment/sigs/v12.in.ml +++ b/src/lib_protocol_environment/sigs/v12.in.ml @@ -31,6 +31,8 @@ module type T = sig module Lwt : [%sig "v12/lwt.mli"] + module Profiler : [%sig "v12/profiler.mli"] + module Data_encoding : [%sig "v12/data_encoding.mli"] module Raw_hashes : [%sig "v12/raw_hashes.mli"] diff --git a/src/lib_protocol_environment/sigs/v12.ml b/src/lib_protocol_environment/sigs/v12.ml index 1245c7488f46..152a6e7f1e79 100644 --- a/src/lib_protocol_environment/sigs/v12.ml +++ b/src/lib_protocol_environment/sigs/v12.ml @@ -3497,6 +3497,35 @@ end # 32 "v12.in.ml" + module Profiler : sig +# 1 "v12/profiler.mli" +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end +# 34 "v12.in.ml" + + module Data_encoding : sig # 1 "v12/data_encoding.mli" (*****************************************************************************) @@ -5263,7 +5292,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 34 "v12.in.ml" +# 36 "v12.in.ml" module Raw_hashes : sig @@ -5305,7 +5334,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 36 "v12.in.ml" +# 38 "v12.in.ml" module Compare : sig @@ -5586,7 +5615,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 38 "v12.in.ml" +# 40 "v12.in.ml" module Time : sig @@ -5640,7 +5669,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 40 "v12.in.ml" +# 42 "v12.in.ml" module TzEndian : sig @@ -5706,7 +5735,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 42 "v12.in.ml" +# 44 "v12.in.ml" module Bits : sig @@ -5743,7 +5772,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 44 "v12.in.ml" +# 46 "v12.in.ml" module Equality_witness : sig @@ -5811,7 +5840,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 46 "v12.in.ml" +# 48 "v12.in.ml" module FallbackArray : sig @@ -5901,7 +5930,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 48 "v12.in.ml" +# 50 "v12.in.ml" module Error_monad : sig @@ -6310,7 +6339,7 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v12.in.ml" +# 52 "v12.in.ml" open Error_monad @@ -6437,7 +6466,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v12.in.ml" +# 56 "v12.in.ml" module List : sig @@ -7724,7 +7753,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v12.in.ml" +# 58 "v12.in.ml" module Array : sig @@ -7834,7 +7863,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v12.in.ml" +# 60 "v12.in.ml" module Set : sig @@ -7983,7 +8012,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v12.in.ml" +# 62 "v12.in.ml" module Map : sig @@ -8152,7 +8181,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v12.in.ml" +# 64 "v12.in.ml" module Option : sig @@ -8300,7 +8329,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 64 "v12.in.ml" +# 66 "v12.in.ml" module Result : sig @@ -8466,7 +8495,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v12.in.ml" +# 68 "v12.in.ml" module RPC_arg : sig @@ -8536,7 +8565,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v12.in.ml" +# 70 "v12.in.ml" module RPC_path : sig @@ -8592,7 +8621,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v12.in.ml" +# 72 "v12.in.ml" module RPC_query : sig @@ -8664,7 +8693,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v12.in.ml" +# 74 "v12.in.ml" module RPC_service : sig @@ -8741,7 +8770,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v12.in.ml" +# 76 "v12.in.ml" module RPC_answer : sig @@ -8802,7 +8831,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v12.in.ml" +# 78 "v12.in.ml" module RPC_directory : sig @@ -9072,7 +9101,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v12.in.ml" +# 80 "v12.in.ml" module Base58 : sig @@ -9137,7 +9166,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v12.in.ml" +# 82 "v12.in.ml" module S : sig @@ -9514,7 +9543,7 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v12.in.ml" +# 84 "v12.in.ml" module Blake2B : sig @@ -9579,7 +9608,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v12.in.ml" +# 86 "v12.in.ml" module Bls : sig @@ -9625,7 +9654,7 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v12.in.ml" +# 88 "v12.in.ml" module Ed25519 : sig @@ -9659,7 +9688,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v12.in.ml" +# 90 "v12.in.ml" module Secp256k1 : sig @@ -9693,7 +9722,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v12.in.ml" +# 92 "v12.in.ml" module P256 : sig @@ -9727,7 +9756,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v12.in.ml" +# 94 "v12.in.ml" module Chain_id : sig @@ -9759,7 +9788,7 @@ end include S.HASH end -# 94 "v12.in.ml" +# 96 "v12.in.ml" module Signature : sig @@ -9827,7 +9856,7 @@ include val size : t -> int end -# 96 "v12.in.ml" +# 98 "v12.in.ml" module Block_hash : sig @@ -9860,7 +9889,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v12.in.ml" +# 100 "v12.in.ml" module Operation_hash : sig @@ -9893,7 +9922,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v12.in.ml" +# 102 "v12.in.ml" module Operation_list_hash : sig @@ -9926,7 +9955,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v12.in.ml" +# 104 "v12.in.ml" module Operation_list_list_hash : sig @@ -9959,7 +9988,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v12.in.ml" +# 106 "v12.in.ml" module Protocol_hash : sig @@ -9992,7 +10021,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v12.in.ml" +# 108 "v12.in.ml" module Context_hash : sig @@ -10045,7 +10074,7 @@ end type version = Version.t end -# 108 "v12.in.ml" +# 110 "v12.in.ml" module Sapling : sig @@ -10193,7 +10222,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v12.in.ml" +# 112 "v12.in.ml" module Timelock : sig @@ -10250,7 +10279,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v12.in.ml" +# 114 "v12.in.ml" module Vdf : sig @@ -10338,7 +10367,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v12.in.ml" +# 116 "v12.in.ml" module Micheline : sig @@ -10398,7 +10427,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v12.in.ml" +# 118 "v12.in.ml" module Block_header : sig @@ -10455,7 +10484,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v12.in.ml" +# 120 "v12.in.ml" module Bounded : sig @@ -10604,7 +10633,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v12.in.ml" +# 122 "v12.in.ml" module Fitness : sig @@ -10638,7 +10667,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v12.in.ml" +# 124 "v12.in.ml" module Operation : sig @@ -10682,7 +10711,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v12.in.ml" +# 126 "v12.in.ml" module Context : sig @@ -11319,7 +11348,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v12.in.ml" +# 128 "v12.in.ml" module Updater : sig @@ -11868,7 +11897,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v12.in.ml" +# 130 "v12.in.ml" module RPC_context : sig @@ -12022,7 +12051,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v12.in.ml" +# 132 "v12.in.ml" module Context_binary : sig @@ -12065,7 +12094,7 @@ module Tree : val make_empty_context : ?root:string -> unit -> t end -# 132 "v12.in.ml" +# 134 "v12.in.ml" module Wasm_2_0_0 : sig @@ -12139,7 +12168,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 134 "v12.in.ml" +# 136 "v12.in.ml" module Plonk : sig @@ -12258,7 +12287,7 @@ val scalar_array_encoding : scalar array Data_encoding.t on the given [inputs] according to the [public_parameters]. *) val verify : public_parameters -> verifier_inputs -> proof -> bool end -# 136 "v12.in.ml" +# 138 "v12.in.ml" module Dal : sig @@ -12381,7 +12410,7 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 138 "v12.in.ml" +# 140 "v12.in.ml" module Skip_list : sig @@ -12613,7 +12642,7 @@ module Make (_ : sig val basis : int end) : S end -# 140 "v12.in.ml" +# 142 "v12.in.ml" module Smart_rollup : sig @@ -12670,6 +12699,6 @@ module Inbox_hash : S.HASH (** Smart rollup merkelized payload hashes' hash *) module Merkelized_payload_hashes_hash : S.HASH end -# 142 "v12.in.ml" +# 144 "v12.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v12/profiler.mli b/src/lib_protocol_environment/sigs/v12/profiler.mli new file mode 100644 index 000000000000..95e641049739 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v12/profiler.mli @@ -0,0 +1,23 @@ +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v13.in.ml b/src/lib_protocol_environment/sigs/v13.in.ml index af6bf60f3d18..beaa071de36d 100644 --- a/src/lib_protocol_environment/sigs/v13.in.ml +++ b/src/lib_protocol_environment/sigs/v13.in.ml @@ -31,6 +31,8 @@ module type T = sig module Lwt : [%sig "v13/lwt.mli"] + module Profiler : [%sig "v12/profiler.mli"] + module Data_encoding : [%sig "v13/data_encoding.mli"] module Raw_hashes : [%sig "v13/raw_hashes.mli"] diff --git a/src/lib_protocol_environment/sigs/v13.ml b/src/lib_protocol_environment/sigs/v13.ml index 88e577578004..2b4b528da567 100644 --- a/src/lib_protocol_environment/sigs/v13.ml +++ b/src/lib_protocol_environment/sigs/v13.ml @@ -3497,6 +3497,35 @@ end # 32 "v13.in.ml" + module Profiler : sig +# 1 "v12/profiler.mli" +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end +# 34 "v13.in.ml" + + module Data_encoding : sig # 1 "v13/data_encoding.mli" (*****************************************************************************) @@ -5263,7 +5292,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 34 "v13.in.ml" +# 36 "v13.in.ml" module Raw_hashes : sig @@ -5305,7 +5334,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 36 "v13.in.ml" +# 38 "v13.in.ml" module Compare : sig @@ -5586,7 +5615,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 38 "v13.in.ml" +# 40 "v13.in.ml" module Time : sig @@ -5640,7 +5669,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 40 "v13.in.ml" +# 42 "v13.in.ml" module TzEndian : sig @@ -5706,7 +5735,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 42 "v13.in.ml" +# 44 "v13.in.ml" module Bits : sig @@ -5743,7 +5772,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 44 "v13.in.ml" +# 46 "v13.in.ml" module Equality_witness : sig @@ -5811,7 +5840,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 46 "v13.in.ml" +# 48 "v13.in.ml" module FallbackArray : sig @@ -5901,7 +5930,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 48 "v13.in.ml" +# 50 "v13.in.ml" module Error_monad : sig @@ -6310,7 +6339,7 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v13.in.ml" +# 52 "v13.in.ml" open Error_monad @@ -6437,7 +6466,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v13.in.ml" +# 56 "v13.in.ml" module List : sig @@ -7724,7 +7753,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v13.in.ml" +# 58 "v13.in.ml" module Array : sig @@ -7834,7 +7863,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v13.in.ml" +# 60 "v13.in.ml" module Set : sig @@ -7983,7 +8012,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v13.in.ml" +# 62 "v13.in.ml" module Map : sig @@ -8152,7 +8181,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v13.in.ml" +# 64 "v13.in.ml" module Option : sig @@ -8300,7 +8329,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 64 "v13.in.ml" +# 66 "v13.in.ml" module Result : sig @@ -8466,7 +8495,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v13.in.ml" +# 68 "v13.in.ml" module RPC_arg : sig @@ -8536,7 +8565,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v13.in.ml" +# 70 "v13.in.ml" module RPC_path : sig @@ -8592,7 +8621,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v13.in.ml" +# 72 "v13.in.ml" module RPC_query : sig @@ -8664,7 +8693,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v13.in.ml" +# 74 "v13.in.ml" module RPC_service : sig @@ -8741,7 +8770,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v13.in.ml" +# 76 "v13.in.ml" module RPC_answer : sig @@ -8802,7 +8831,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v13.in.ml" +# 78 "v13.in.ml" module RPC_directory : sig @@ -9072,7 +9101,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v13.in.ml" +# 80 "v13.in.ml" module Base58 : sig @@ -9137,7 +9166,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v13.in.ml" +# 82 "v13.in.ml" module S : sig @@ -9514,7 +9543,7 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v13.in.ml" +# 84 "v13.in.ml" module Blake2B : sig @@ -9579,7 +9608,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v13.in.ml" +# 86 "v13.in.ml" module Bls : sig @@ -9625,7 +9654,7 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v13.in.ml" +# 88 "v13.in.ml" module Ed25519 : sig @@ -9659,7 +9688,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v13.in.ml" +# 90 "v13.in.ml" module Secp256k1 : sig @@ -9693,7 +9722,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v13.in.ml" +# 92 "v13.in.ml" module P256 : sig @@ -9727,7 +9756,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v13.in.ml" +# 94 "v13.in.ml" module Chain_id : sig @@ -9759,7 +9788,7 @@ end include S.HASH end -# 94 "v13.in.ml" +# 96 "v13.in.ml" module Signature : sig @@ -9827,7 +9856,7 @@ include val size : t -> int end -# 96 "v13.in.ml" +# 98 "v13.in.ml" module Block_hash : sig @@ -9860,7 +9889,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v13.in.ml" +# 100 "v13.in.ml" module Operation_hash : sig @@ -9893,7 +9922,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v13.in.ml" +# 102 "v13.in.ml" module Operation_list_hash : sig @@ -9926,7 +9955,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v13.in.ml" +# 104 "v13.in.ml" module Operation_list_list_hash : sig @@ -9959,7 +9988,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v13.in.ml" +# 106 "v13.in.ml" module Protocol_hash : sig @@ -9992,7 +10021,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v13.in.ml" +# 108 "v13.in.ml" module Context_hash : sig @@ -10045,7 +10074,7 @@ end type version = Version.t end -# 108 "v13.in.ml" +# 110 "v13.in.ml" module Sapling : sig @@ -10193,7 +10222,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v13.in.ml" +# 112 "v13.in.ml" module Timelock : sig @@ -10250,7 +10279,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v13.in.ml" +# 114 "v13.in.ml" module Vdf : sig @@ -10338,7 +10367,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v13.in.ml" +# 116 "v13.in.ml" module Micheline : sig @@ -10398,7 +10427,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v13.in.ml" +# 118 "v13.in.ml" module Block_header : sig @@ -10455,7 +10484,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v13.in.ml" +# 120 "v13.in.ml" module Bounded : sig @@ -10604,7 +10633,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v13.in.ml" +# 122 "v13.in.ml" module Fitness : sig @@ -10638,7 +10667,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v13.in.ml" +# 124 "v13.in.ml" module Operation : sig @@ -10682,7 +10711,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v13.in.ml" +# 126 "v13.in.ml" module Context : sig @@ -11319,7 +11348,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v13.in.ml" +# 128 "v13.in.ml" module Updater : sig @@ -11848,7 +11877,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v13.in.ml" +# 130 "v13.in.ml" module RPC_context : sig @@ -12002,7 +12031,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v13.in.ml" +# 132 "v13.in.ml" module Context_binary : sig @@ -12045,7 +12074,7 @@ module Tree : val make_empty_context : ?root:string -> unit -> t end -# 132 "v13.in.ml" +# 134 "v13.in.ml" module Wasm_2_0_0 : sig @@ -12119,7 +12148,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 134 "v13.in.ml" +# 136 "v13.in.ml" module Plonk : sig @@ -12238,7 +12267,7 @@ val scalar_array_encoding : scalar array Data_encoding.t on the given [inputs] according to the [public_parameters]. *) val verify : public_parameters -> verifier_inputs -> proof -> bool end -# 136 "v13.in.ml" +# 138 "v13.in.ml" module Dal : sig @@ -12361,7 +12390,7 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 138 "v13.in.ml" +# 140 "v13.in.ml" module Skip_list : sig @@ -12593,7 +12622,7 @@ module Make (_ : sig val basis : int end) : S end -# 140 "v13.in.ml" +# 142 "v13.in.ml" module Smart_rollup : sig @@ -12650,6 +12679,6 @@ module Inbox_hash : S.HASH (** Smart rollup merkelized payload hashes' hash *) module Merkelized_payload_hashes_hash : S.HASH end -# 142 "v13.in.ml" +# 144 "v13.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v13/profiler.mli b/src/lib_protocol_environment/sigs/v13/profiler.mli new file mode 100644 index 000000000000..95e641049739 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v13/profiler.mli @@ -0,0 +1,23 @@ +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v9.in.ml b/src/lib_protocol_environment/sigs/v9.in.ml index c479da485b90..68dd5eb2594e 100644 --- a/src/lib_protocol_environment/sigs/v9.in.ml +++ b/src/lib_protocol_environment/sigs/v9.in.ml @@ -31,6 +31,8 @@ module type T = sig module Lwt : [%sig "v9/lwt.mli"] + module Profiler : [%sig "v9/profiler.mli"] + module Data_encoding : [%sig "v9/data_encoding.mli"] module Raw_hashes : [%sig "v9/raw_hashes.mli"] diff --git a/src/lib_protocol_environment/sigs/v9.ml b/src/lib_protocol_environment/sigs/v9.ml index badab5a6546a..fb1cda002785 100644 --- a/src/lib_protocol_environment/sigs/v9.ml +++ b/src/lib_protocol_environment/sigs/v9.ml @@ -3461,6 +3461,35 @@ end # 32 "v9.in.ml" + module Profiler : sig +# 1 "v9/profiler.mli" +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end +# 34 "v9.in.ml" + + module Data_encoding : sig # 1 "v9/data_encoding.mli" (*****************************************************************************) @@ -5211,7 +5240,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 34 "v9.in.ml" +# 36 "v9.in.ml" module Raw_hashes : sig @@ -5253,7 +5282,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 36 "v9.in.ml" +# 38 "v9.in.ml" module Compare : sig @@ -5534,7 +5563,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 38 "v9.in.ml" +# 40 "v9.in.ml" module Time : sig @@ -5588,7 +5617,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 40 "v9.in.ml" +# 42 "v9.in.ml" module TzEndian : sig @@ -5654,7 +5683,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 42 "v9.in.ml" +# 44 "v9.in.ml" module Bits : sig @@ -5691,7 +5720,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 44 "v9.in.ml" +# 46 "v9.in.ml" module Equality_witness : sig @@ -5759,7 +5788,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 46 "v9.in.ml" +# 48 "v9.in.ml" module FallbackArray : sig @@ -5849,7 +5878,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 48 "v9.in.ml" +# 50 "v9.in.ml" module Error_monad : sig @@ -6283,7 +6312,7 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v9.in.ml" +# 52 "v9.in.ml" open Error_monad @@ -6410,7 +6439,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v9.in.ml" +# 56 "v9.in.ml" module List : sig @@ -7683,7 +7712,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v9.in.ml" +# 58 "v9.in.ml" module Array : sig @@ -7793,7 +7822,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v9.in.ml" +# 60 "v9.in.ml" module Set : sig @@ -7942,7 +7971,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v9.in.ml" +# 62 "v9.in.ml" module Map : sig @@ -8111,7 +8140,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v9.in.ml" +# 64 "v9.in.ml" module Option : sig @@ -8259,7 +8288,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 64 "v9.in.ml" +# 66 "v9.in.ml" module Result : sig @@ -8425,7 +8454,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v9.in.ml" +# 68 "v9.in.ml" module RPC_arg : sig @@ -8495,7 +8524,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v9.in.ml" +# 70 "v9.in.ml" module RPC_path : sig @@ -8551,7 +8580,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v9.in.ml" +# 72 "v9.in.ml" module RPC_query : sig @@ -8623,7 +8652,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v9.in.ml" +# 74 "v9.in.ml" module RPC_service : sig @@ -8700,7 +8729,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v9.in.ml" +# 76 "v9.in.ml" module RPC_answer : sig @@ -8761,7 +8790,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v9.in.ml" +# 78 "v9.in.ml" module RPC_directory : sig @@ -9031,7 +9060,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v9.in.ml" +# 80 "v9.in.ml" module Base58 : sig @@ -9096,7 +9125,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v9.in.ml" +# 82 "v9.in.ml" module S : sig @@ -9473,7 +9502,7 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v9.in.ml" +# 84 "v9.in.ml" module Blake2B : sig @@ -9538,7 +9567,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v9.in.ml" +# 86 "v9.in.ml" module Bls : sig @@ -9584,7 +9613,7 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v9.in.ml" +# 88 "v9.in.ml" module Ed25519 : sig @@ -9618,7 +9647,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v9.in.ml" +# 90 "v9.in.ml" module Secp256k1 : sig @@ -9652,7 +9681,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v9.in.ml" +# 92 "v9.in.ml" module P256 : sig @@ -9686,7 +9715,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v9.in.ml" +# 94 "v9.in.ml" module Chain_id : sig @@ -9718,7 +9747,7 @@ end include S.HASH end -# 94 "v9.in.ml" +# 96 "v9.in.ml" module Signature : sig @@ -9786,7 +9815,7 @@ include val size : t -> int end -# 96 "v9.in.ml" +# 98 "v9.in.ml" module Block_hash : sig @@ -9819,7 +9848,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v9.in.ml" +# 100 "v9.in.ml" module Operation_hash : sig @@ -9852,7 +9881,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v9.in.ml" +# 102 "v9.in.ml" module Operation_list_hash : sig @@ -9885,7 +9914,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v9.in.ml" +# 104 "v9.in.ml" module Operation_list_list_hash : sig @@ -9918,7 +9947,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v9.in.ml" +# 106 "v9.in.ml" module Protocol_hash : sig @@ -9951,7 +9980,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v9.in.ml" +# 108 "v9.in.ml" module Context_hash : sig @@ -10004,7 +10033,7 @@ end type version = Version.t end -# 108 "v9.in.ml" +# 110 "v9.in.ml" module Sapling : sig @@ -10152,7 +10181,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v9.in.ml" +# 112 "v9.in.ml" module Timelock : sig @@ -10211,7 +10240,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v9.in.ml" +# 114 "v9.in.ml" module Vdf : sig @@ -10299,7 +10328,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v9.in.ml" +# 116 "v9.in.ml" module Micheline : sig @@ -10359,7 +10388,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v9.in.ml" +# 118 "v9.in.ml" module Block_header : sig @@ -10416,7 +10445,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v9.in.ml" +# 120 "v9.in.ml" module Bounded : sig @@ -10565,7 +10594,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v9.in.ml" +# 122 "v9.in.ml" module Fitness : sig @@ -10599,7 +10628,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v9.in.ml" +# 124 "v9.in.ml" module Operation : sig @@ -10643,7 +10672,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v9.in.ml" +# 126 "v9.in.ml" module Context : sig @@ -11280,7 +11309,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v9.in.ml" +# 128 "v9.in.ml" module Updater : sig @@ -11805,7 +11834,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v9.in.ml" +# 130 "v9.in.ml" module RPC_context : sig @@ -11959,7 +11988,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v9.in.ml" +# 132 "v9.in.ml" module Wasm_2_0_0 : sig @@ -12035,7 +12064,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 132 "v9.in.ml" +# 134 "v9.in.ml" module Plonk : sig @@ -12154,7 +12183,7 @@ val scalar_array_encoding : scalar array Data_encoding.t on the given [inputs] according to the [public_parameters]. *) val verify : public_parameters -> verifier_inputs -> proof -> bool end -# 134 "v9.in.ml" +# 136 "v9.in.ml" module Dal : sig @@ -12277,6 +12306,6 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 136 "v9.in.ml" +# 138 "v9.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v9/profiler.mli b/src/lib_protocol_environment/sigs/v9/profiler.mli new file mode 100644 index 000000000000..95e641049739 --- /dev/null +++ b/src/lib_protocol_environment/sigs/v9/profiler.mli @@ -0,0 +1,23 @@ +type lod = Terse | Detailed | Verbose + +val record : ?lod:lod -> string -> unit + +val aggregate : ?lod:lod -> string -> unit + +val stop : unit -> unit + +val stamp : ?lod:lod -> string -> unit + +val record_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val record_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val aggregate_f : ?lod:lod -> string -> (unit -> 'a) -> 'a + +val aggregate_s : ?lod:lod -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t + +val mark : ?lod:lod -> string list -> unit + +val span_f : ?lod:lod -> string list -> (unit -> 'a) -> 'a + +val span_s : ?lod:lod -> string list -> (unit -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 1610e8087909..10fbccafd8b5 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -67,6 +67,7 @@ module Memory_context = Memory_context module Brassaia_memory_context = Brassaia_memory_context module Proxy_context = Proxy_context module Proxy_delegate = Proxy_delegate +module Environment_profiler = Environment_profiler module Internal_for_tests = struct module Environment_protocol_T_test = Environment_protocol_T_test -- GitLab From 23c42524f3255d0713f718bdaba3e61af2e41e1f Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:42:11 +0200 Subject: [PATCH 02/19] Profiler: introduce shell profilers --- src/bin_node/node_replay_command.ml | 16 +++++ src/bin_node/node_run_command.ml | 16 +++++ src/lib_shell/chain_validator.ml | 19 ++++++ src/lib_shell/profiler_directory.ml | 34 ++++++++++ src/lib_shell_services/profiler_services.ml | 73 +++++++++++++++++++++ src/lib_shell_services/shell_profiling.ml | 64 ++++++++++++++++++ 6 files changed, 222 insertions(+) create mode 100644 src/lib_shell/profiler_directory.ml create mode 100644 src/lib_shell_services/profiler_services.ml create mode 100644 src/lib_shell_services/shell_profiling.ml diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index 1c8b9e66c0d9..459413942c7c 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -492,6 +492,22 @@ let run ?verbosity ~singleprocess ~strict ~operation_metadata_size_limit let*! () = Tezos_base_unix.Internal_event_unix.init ~config:internal_events () in + (match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with + | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let instance = + Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.(config.data_dir // "/node_profiling.txt", max_lod) + in + Tezos_base.Profiler.(plug main) instance ; + Tezos_protocol_environment.Environment_profiler.plug instance + | _ -> ()) ; Updater.init (Data_version.protocol_dir config.data_dir) ; Lwt_exit.( wrap_and_exit diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 059a131a55b6..3656fe8471ec 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -723,6 +723,22 @@ let run ?verbosity ?sandbox ?target ?(cli_warnings = []) let*! () = Tezos_base_unix.Internal_event_unix.init ~config:internal_events () in + let () = + match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with + | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) + -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let profiler_maker = + Tezos_shell.Profiler_directory.profiler_maker config.data_dir max_lod + in + Shell_profiling.activate_all ~profiler_maker + | _ -> () + in let*! () = Lwt_list.iter_s (fun evt -> Internal_event.Simple.emit evt ()) cli_warnings in diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 2493cecbccbc..688cf80bfd9a 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -464,6 +464,24 @@ let may_synchronise_context synchronisation_state chain_store = Context_ops.sync context_index else Lwt.return_unit +let reset_profilers block = + let profilers = + Shell_profiling. + [ + p2p_reader_profiler; + requester_profiler; + chain_validator_profiler; + rpc_server_profiler; + ] + in + List.iter + (fun profiler -> + (try Tezos_base.Profiler.stop profiler with _ -> ()) ; + Tezos_base.Profiler.record + profiler + (Block_hash.to_b58check (Store.Block.hash block))) + profilers + let on_validation_request w peer start_testchain active_chains spawn_child block = let open Lwt_result_syntax in @@ -484,6 +502,7 @@ let on_validation_request w peer start_testchain active_chains spawn_child block if not accepted_head then return Ignored_head else let* previous = Store.Chain.set_head chain_store block in + reset_profilers block ; let () = if is_bootstrapped nv then Distributed_db.Advertise.current_head nv.chain_db block diff --git a/src/lib_shell/profiler_directory.ml b/src/lib_shell/profiler_directory.ml new file mode 100644 index 000000000000..78f10d969f6d --- /dev/null +++ b/src/lib_shell/profiler_directory.ml @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +let profiler_maker data_dir ~name max_lod = + Tezos_base.Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.((data_dir // name) ^ "_profiling.txt", max_lod) + +let build_rpc_directory data_dir = + let open Lwt_result_syntax in + let register endpoint f directory = + Tezos_rpc.Directory.register directory endpoint f + in + let open Profiler_services.S in + Tezos_rpc.Directory.empty + |> register activate_all (fun () lod () -> + Shell_profiling.activate_all + ~profiler_maker:(profiler_maker data_dir lod) ; + return_unit) + |> register deactivate_all (fun () () () -> + Shell_profiling.deactivate_all () ; + return_unit) + |> register activate (fun ((), name) lod () -> + Shell_profiling.activate + ~profiler_maker:(profiler_maker data_dir lod) + name ; + return_unit) + |> register deactivate (fun ((), name) () () -> + Shell_profiling.deactivate name ; + return_unit) diff --git a/src/lib_shell_services/profiler_services.ml b/src/lib_shell_services/profiler_services.ml new file mode 100644 index 000000000000..da81f3885291 --- /dev/null +++ b/src/lib_shell_services/profiler_services.ml @@ -0,0 +1,73 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +module S = struct + let profiler_names = Shell_profiling.all_profilers + + let lod_arg = + Resto.Arg.make + ~name:"profiler level of detail" + ~destruct:(function + | "terse" -> Ok Profiler.Terse + | "verbose" -> Ok Profiler.Verbose + | "detailed" -> Ok Profiler.Detailed + | _ -> Error "invalid lod parameter") + ~construct:(function + | Profiler.Terse -> "terse" + | Profiler.Verbose -> "verbose" + | Profiler.Detailed -> "detailed") + () + + let activate_all = + Tezos_rpc.Service.get_service + ~description:"Activate all profilers." + ~query: + Tezos_rpc.Query.( + query Fun.id |+ field "lod" lod_arg Terse Fun.id |> seal) + ~output:Data_encoding.unit + Tezos_rpc.Path.(root / "profiler" / "activate_all") + + let deactivate_all = + Tezos_rpc.Service.get_service + ~description:"Deactivate all profilers." + ~query:Tezos_rpc.Query.empty + ~output:Data_encoding.unit + Tezos_rpc.Path.(root / "profiler" / "deactivate_all") + + let profiler_name_arg = + Resto.Arg.make + ~name:"profiler name" + ~destruct:(fun s -> + if List.mem_assoc ~equal:String.equal s Shell_profiling.all_profilers + then Ok s + else Error (Printf.sprintf "no profiler named '%s' found" s)) + ~construct:Fun.id + () + + let activate = + Tezos_rpc.Service.get_service + ~description:"Activate a profiler." + ~query: + Tezos_rpc.Query.( + query Fun.id |+ field "lod" lod_arg Terse Fun.id |> seal) + ~output:Data_encoding.unit + Tezos_rpc.Path.(root / "profiler" / "activate" /: profiler_name_arg) + + let deactivate = + Tezos_rpc.Service.get_service + ~description:"Deactivate a profiler." + ~query:Tezos_rpc.Query.empty + ~output:Data_encoding.unit + Tezos_rpc.Path.(root / "profiler" / "deactivate" /: profiler_name_arg) + + let list = + Tezos_rpc.Service.get_service + ~description:"List profilers." + ~query:Tezos_rpc.Query.empty + ~output:Data_encoding.(list string) + Tezos_rpc.Path.(root / "profiler" / "list") +end diff --git a/src/lib_shell_services/shell_profiling.ml b/src/lib_shell_services/shell_profiling.ml new file mode 100644 index 000000000000..143fe71ca95f --- /dev/null +++ b/src/lib_shell_services/shell_profiling.ml @@ -0,0 +1,64 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Tezos_base.Profiler + +let mempool_profiler = unplugged () + +let store_profiler = unplugged () + +let chain_validator_profiler = unplugged () + +let block_validator_profiler = unplugged () + +let rpc_server_profiler = unplugged () + +let create_reset_block_section profiler = + let last_block = ref None in + fun b -> + match !last_block with + | None -> + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + | Some b' when Block_hash.equal b' b -> () + | Some _ -> + stop profiler ; + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + +let merge_profiler = unplugged () + +let p2p_reader_profiler = unplugged () + +let requester_profiler = unplugged () + +let all_profilers = + [ + ("mempool", mempool_profiler); + ("store", store_profiler); + ("chain_validator", chain_validator_profiler); + ("block_validator", block_validator_profiler); + ("merge", merge_profiler); + ("p2p_reader", p2p_reader_profiler); + ("requester", requester_profiler); + ] + +let activate_all ~profiler_maker = + List.iter (fun (name, p) -> plug p (profiler_maker ~name)) all_profilers + +let deactivate_all () = + List.iter (fun (_name, p) -> close_and_unplug_all p) all_profilers + +let activate ~profiler_maker name = + List.assoc ~equal:( = ) name all_profilers |> function + | None -> Format.ksprintf invalid_arg "unknown '%s' profiler" name + | Some p -> plug p (profiler_maker ~name) + +let deactivate name = + List.assoc ~equal:( = ) name all_profilers |> function + | None -> Format.ksprintf invalid_arg "unknown '%s' profiler" name + | Some p -> close_and_unplug_all p -- GitLab From 36f6e66d96d1e97157b27d970e5d3affa069dc26 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:27:08 +0200 Subject: [PATCH 03/19] Profiler: plug mempool profiler --- src/lib_shell/chain_validator.ml | 2 + src/lib_shell/prevalidator.ml | 122 ++++++++++++++++++++++++------- 2 files changed, 99 insertions(+), 25 deletions(-) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 688cf80bfd9a..6f70134e361b 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -333,6 +333,8 @@ let instantiate_prevalidator parameters set_prevalidator block chain_db = ~block_hash:(Store.Block.hash block) new_protocol_hash in + let instances = Profiler.plugged Shell_profiling.mempool_profiler in + List.iter Tezos_protocol_environment.Environment_profiler.plug instances ; Prevalidator.create parameters.prevalidator_limits proto chain_db in match r with diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 8856efa9938c..c7e096eae55c 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -27,6 +27,8 @@ (** Minimal delay between two mempool advertisements *) let advertisement_delay = 0.1 +module Profiler = (val Profiler.wrap Shell_profiling.mempool_profiler) + (** Argument that will be provided to {!Worker.MakeGroup} to create the prevalidator worker. *) module Name = struct @@ -330,11 +332,21 @@ module Make_s (Unit.catch_s (fun () -> Events.(emit ban_operation_encountered) (origin, oph))) ; true) - else - Classification.is_in_mempool oph shell.classification <> None - || Operation_hash.Set.mem oph shell.live_operations - || Pending_ops.mem oph shell.pending - || Classification.is_known_unparsable oph shell.classification + else if Classification.is_in_mempool oph shell.classification <> None then ( + Profiler.mark ["is already handled"; "is_classified"] ; + true) + else if Operation_hash.Set.mem oph shell.live_operations then ( + Profiler.mark ["is already handled"; "is_live_operation"] ; + true) + else if Pending_ops.mem oph shell.pending then ( + Profiler.mark ["is already handled"; "is_pending"] ; + true) + else if Classification.is_known_unparsable oph shell.classification then ( + Profiler.mark ["is already handled"; "is_known_unparsable"] ; + true) + else ( + Profiler.mark ["not already handled"] ; + false) let advertise (shell : ('operation_data, _) types_state_shell) mempool = let open Lwt_syntax in @@ -456,14 +468,34 @@ module Make_s match (status_and_priority.status, status_and_priority.priority) with - | Fresh, _ | Reclassified, High -> true - | Reclassified, Medium | Reclassified, Low _ -> + | Fresh, _ -> + Profiler.mark ["Freshly validated operation"] ; + true + | Reclassified, High -> + Profiler.mark ["reclassified high priority operation"] ; + true + | Reclassified, Medium -> + Profiler.mark ["reclassified medium priority operation"] ; + false + | Reclassified, Low _ -> (* Reclassified operations with medium and low priority are not reclassified *) + Profiler.mark ["reclassified low priority operation"] ; false in Some (op.hash, is_advertisable) - | `Branch_refused _ | `Branch_delayed _ | `Refused _ | `Outdated _ -> None + | `Branch_refused _ -> + Profiler.mark ["branch_refused operation"] ; + None + | `Branch_delayed _ -> + Profiler.mark ["branch_delayed operation"] ; + None + | `Refused _ -> + Profiler.mark ["refused operation"] ; + None + | `Outdated _ -> + Profiler.mark ["outdated operation"] ; + None in return (v_state, validated_operation, to_handle) @@ -499,7 +531,14 @@ module Make_s (* Using Error as an early-return mechanism *) Lwt.return_error (acc_validation_state, advertisable_mempool, validated_mempool) - else ( + else + let section = + match status_and_priority.priority with + | High -> "classify consensus operation " + | Medium -> "classify voting/anonymous operation" + | Low _ -> "classify manager operation" + in + Profiler.aggregate_s section @@ fun () -> shell.pending <- Pending_ops.remove oph shell.pending ; let* new_validation_state, validated_operation, to_handle = classify_operation @@ -525,7 +564,7 @@ module Make_s ( new_validation_state, advertisable_mempool, validated_mempool, - limit - 1 ))) + limit - 1 )) shell.pending ( state, Mempool.empty, @@ -545,21 +584,30 @@ module Make_s let update_advertised_mempool_fields pv_shell advertisable_mempool validated_mempool = let open Lwt_syntax in - if not (Mempool.is_empty advertisable_mempool) then - (* We only advertise newly classified operations. *) - advertise pv_shell advertisable_mempool ; + (if not (Mempool.is_empty advertisable_mempool) then + (* We only advertise newly classified operations. *) + Profiler.aggregate_f "advertise mempool" @@ fun () -> + advertise pv_shell advertisable_mempool) ; if Mempool.is_empty validated_mempool then Lwt.return_unit else let our_mempool = let known_valid = + Profiler.aggregate_f "union validated hashes" @@ fun () -> Operation_hash.Set.union validated_mempool.known_valid pv_shell.mempool.known_valid in - {Mempool.known_valid; pending = Pending_ops.hashes pv_shell.pending} + let pending = + Profiler.aggregate_f "pending hashes" @@ fun () -> + Pending_ops.hashes pv_shell.pending + in + {Mempool.known_valid; pending} in - let* _res = set_mempool pv_shell our_mempool in - Lwt.pause () + let* _res = + Profiler.aggregate_s "set mempool" @@ fun () -> + set_mempool pv_shell our_mempool + in + Profiler.aggregate_s "pause" @@ fun () -> Lwt.pause () let handle_unprocessed pv = let open Lwt_syntax in @@ -568,6 +616,7 @@ module Make_s else let* () = Events.(emit processing_operations) () in let* validation_state, advertisable_mempool, validated_mempool = + Profiler.aggregate_s "classify pending operations" @@ fun () -> classify_pending_operations ~notifier pv.shell @@ -627,16 +676,18 @@ module Make_s match peer with Some peer -> Events.Peer peer | None -> Leftover in let spawn_fetch_operation ~notify_arrival = + Profiler.aggregate_f "fetching thread" @@ fun () -> ignore (Unit.catch_s (fun () -> fetch_operation ~notify_arrival shell ?peer oph)) in - if Operation_hash.Set.mem oph shell.fetching then + if Operation_hash.Set.mem oph shell.fetching then ( + Profiler.mark ["already fetching"] ; (* If the operation is already being fetched, we notify the DDB that another peer may also be requested for the resource. In any case, the initial fetching thread will still be resolved and push an arrived worker request. *) - spawn_fetch_operation ~notify_arrival:false + spawn_fetch_operation ~notify_arrival:false) else if not (already_handled ~origin shell oph) then ( shell.fetching <- Operation_hash.Set.add oph shell.fetching ; spawn_fetch_operation ~notify_arrival:true) @@ -807,7 +858,10 @@ module Make_s let on_notify (shell : ('operation_data, _) types_state_shell) peer mempool = - let may_fetch_operation = may_fetch_operation shell (Some peer) in + let may_fetch_operation = + Profiler.aggregate_f "may_fetch_operation" @@ fun () -> + may_fetch_operation shell (Some peer) + in let () = Operation_hash.Set.iter may_fetch_operation mempool.Mempool.known_valid in @@ -828,6 +882,7 @@ module Make_s pv.shell.timestamp <- timestamp_system ; let timestamp = Time.System.to_protocol timestamp_system in let* validation_state = + Profiler.aggregate_s "flush state" @@ fun () -> pv.shell.parameters.flush ~head:new_predecessor ~timestamp @@ -851,6 +906,7 @@ module Make_s let*! new_pending_operations, nb_pending = Operation_hash.Map.fold_s (fun oph op (pending, nb_pending) -> + Profiler.aggregate_s "flushed operations" @@ fun () -> let*! v = pre_filter pv ~notifier:(mk_notifier pv.operation_stream) op in @@ -1373,13 +1429,19 @@ module Make (r, request_error) result Lwt.t -> (r, request_error) result Lwt.t = fun r -> let open Lwt_syntax in - let* () = handle_unprocessed pv in + let* () = + Profiler.aggregate_s "handle_unprocessed" @@ fun () -> + handle_unprocessed pv + in r in post_processing @@ match request with - | Request.Flush (hash, event, live_blocks, live_operations) -> ( + | Request.Flush (hash, event, live_blocks, live_operations) -> + Profiler.stop () ; + let bh = Block_hash.to_b58check hash in + Format.kasprintf Profiler.record "%s" bh ; Requests.on_advertise pv.shell ; (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 Rebase the advertisement instead. *) @@ -1392,24 +1454,32 @@ module Make in Lwt_mutex.with_lock pv.lock @@ fun () : (r, error trace) result Lwt.t -> + Profiler.aggregate_s "on_flush" @@ fun () -> Requests.on_flush ~handle_branch_refused pv block live_blocks - live_operations) + live_operations | Request.Notify (peer, mempool) -> + Profiler.aggregate_f "on_notify" @@ fun () -> Requests.on_notify pv.shell peer mempool ; return_unit | Request.Leftover -> (* unprocessed ops are handled just below *) return_unit - | Request.Inject {op; force} -> Requests.on_inject pv ~force op - | Request.Arrived (oph, op) -> Requests.on_arrived pv oph op + | Request.Inject {op; force} -> + Profiler.aggregate_s "on_inject" @@ fun () -> + Requests.on_inject pv ~force op + | Request.Arrived (oph, op) -> + Profiler.aggregate_s "on_arrived" @@ fun () -> + Requests.on_arrived pv oph op | Request.Advertise -> + Profiler.aggregate_s "on_advertise" @@ fun () -> Requests.on_advertise pv.shell ; return_unit - | Request.Ban oph -> Requests.on_ban pv oph + | Request.Ban oph -> + Profiler.aggregate_s "on_ban" @@ fun () -> Requests.on_ban pv oph let on_close w = let pv = Worker.state w in @@ -1431,6 +1501,8 @@ module Make let chain_store = Distributed_db.chain_store chain_db in let flush = Prevalidation_t.flush (Distributed_db.chain_store chain_db) in let*! head = Store.Chain.current_head chain_store in + let bh = Block_hash.to_b58check (Store.Block.hash head) in + Format.kasprintf Profiler.record "%s" bh ; let*! mempool = Store.Chain.mempool chain_store in let*! live_blocks, live_operations = Store.Chain.live_blocks chain_store -- GitLab From a0c0cd4d0697a5bb36fdf2f9a1cceafd5657a4f7 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Fri, 9 Aug 2024 16:17:43 +0200 Subject: [PATCH 04/19] Lib_shell: prevalidator.ml - use ppx profiler --- manifest/product_octez.ml | 3 +- src/lib_shell/dune | 2 +- src/lib_shell/prevalidator.ml | 261 ++++++++++++++++------------------ 3 files changed, 126 insertions(+), 140 deletions(-) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 5773fc0d8bae..7be53fb7554a 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -1893,7 +1893,7 @@ let octez_base_test_helpers = ~bisect_ppx:No ~release_status:Released -let _ppx_profiler = +let ppx_profiler = octez_lib "ppx_profiler" ~path:"src/lib_ppx_profiler" @@ -3643,6 +3643,7 @@ let octez_shell = Dune. [[S "package"; S "octez-shell-libs"]; [S "mld_files"; S "octez_shell"]] ~inline_tests:ppx_expect + ~preprocess:(pps ppx_profiler) ~deps: [ lwt_watcher; diff --git a/src/lib_shell/dune b/src/lib_shell/dune index df3b0bfffc7d..7a33495ebaaa 100644 --- a/src/lib_shell/dune +++ b/src/lib_shell/dune @@ -28,7 +28,7 @@ octez-libs.crypto-dal.dal-config lwt-exit) (inline_tests (flags -verbose) (modes native)) - (preprocess (pps ppx_expect)) + (preprocess (pps octez-libs.ppx_profiler ppx_expect)) (flags (:standard) -open Tezos_base.TzPervasives diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index c7e096eae55c..eeac1ed8c9ce 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -332,21 +332,15 @@ module Make_s (Unit.catch_s (fun () -> Events.(emit ban_operation_encountered) (origin, oph))) ; true) - else if Classification.is_in_mempool oph shell.classification <> None then ( - Profiler.mark ["is already handled"; "is_classified"] ; - true) - else if Operation_hash.Set.mem oph shell.live_operations then ( - Profiler.mark ["is already handled"; "is_live_operation"] ; - true) - else if Pending_ops.mem oph shell.pending then ( - Profiler.mark ["is already handled"; "is_pending"] ; - true) - else if Classification.is_known_unparsable oph shell.classification then ( - Profiler.mark ["is already handled"; "is_known_unparsable"] ; - true) - else ( - Profiler.mark ["not already handled"] ; - false) + else if Classification.is_in_mempool oph shell.classification <> None then + true [@profiler.mark ["is already handled"; "is_classified"]] + else if Operation_hash.Set.mem oph shell.live_operations then true + [@profiler.mark ["is already handled"; "is_live_operation"]] + else if Pending_ops.mem oph shell.pending then true + [@profiler.mark ["is already handled"; "is_pending"]] + else if Classification.is_known_unparsable oph shell.classification then + true [@profiler.mark ["is already handled"; "is_known_unparsable"]] + else false [@profiler.mark ["not already handled"]] let advertise (shell : ('operation_data, _) types_state_shell) mempool = let open Lwt_syntax in @@ -468,34 +462,23 @@ module Make_s match (status_and_priority.status, status_and_priority.priority) with - | Fresh, _ -> - Profiler.mark ["Freshly validated operation"] ; - true + | Fresh, _ -> true [@profiler.mark ["Freshly validated operation"]] | Reclassified, High -> - Profiler.mark ["reclassified high priority operation"] ; - true + true [@profiler.mark ["reclassified high priority operation"]] | Reclassified, Medium -> - Profiler.mark ["reclassified medium priority operation"] ; false + [@profiler.mark ["reclassified medium priority operation"]] | Reclassified, Low _ -> (* Reclassified operations with medium and low priority are not reclassified *) - Profiler.mark ["reclassified low priority operation"] ; false + [@profiler.mark ["reclassified low priority operation"]] in Some (op.hash, is_advertisable) - | `Branch_refused _ -> - Profiler.mark ["branch_refused operation"] ; - None - | `Branch_delayed _ -> - Profiler.mark ["branch_delayed operation"] ; - None - | `Refused _ -> - Profiler.mark ["refused operation"] ; - None - | `Outdated _ -> - Profiler.mark ["outdated operation"] ; - None + | `Branch_refused _ -> None [@profiler.mark ["branch_refused operation"]] + | `Branch_delayed _ -> None [@profiler.mark ["branch_delayed operation"]] + | `Refused _ -> None [@profiler.mark ["refused operation"]] + | `Outdated _ -> None [@profiler.mark ["outdated operation"]] in return (v_state, validated_operation, to_handle) @@ -532,39 +515,40 @@ module Make_s Lwt.return_error (acc_validation_state, advertisable_mempool, validated_mempool) else - let section = + (* Defined as a function to avoid an useless allocation *) + let[@warning "-26"] section () = match status_and_priority.priority with | High -> "classify consensus operation " | Medium -> "classify voting/anonymous operation" | Low _ -> "classify manager operation" in - Profiler.aggregate_s section @@ fun () -> - shell.pending <- Pending_ops.remove oph shell.pending ; - let* new_validation_state, validated_operation, to_handle = - classify_operation - shell - ~config - ~validation_state:acc_validation_state - status_and_priority - op - in - let+ () = Events.(emit operation_reclassified) oph in - List.iter (handle_classification ~notifier shell) to_handle ; - let advertisable_mempool, validated_mempool = - match validated_operation with - | None -> (advertisable_mempool, validated_mempool) - | Some (oph, true) -> - ( Mempool.cons_valid oph advertisable_mempool, - Mempool.cons_valid oph validated_mempool ) - | Some (oph, false) -> - ( advertisable_mempool, - Mempool.cons_valid oph validated_mempool ) - in - Ok - ( new_validation_state, - advertisable_mempool, - validated_mempool, - limit - 1 )) + ((shell.pending <- Pending_ops.remove oph shell.pending ; + let* new_validation_state, validated_operation, to_handle = + classify_operation + shell + ~config + ~validation_state:acc_validation_state + status_and_priority + op + in + let+ () = Events.(emit operation_reclassified) oph in + List.iter (handle_classification ~notifier shell) to_handle ; + let advertisable_mempool, validated_mempool = + match validated_operation with + | None -> (advertisable_mempool, validated_mempool) + | Some (oph, true) -> + ( Mempool.cons_valid oph advertisable_mempool, + Mempool.cons_valid oph validated_mempool ) + | Some (oph, false) -> + ( advertisable_mempool, + Mempool.cons_valid oph validated_mempool ) + in + Ok + ( new_validation_state, + advertisable_mempool, + validated_mempool, + limit - 1 )) + [@profiler.aggregate_s section ()])) shell.pending ( state, Mempool.empty, @@ -584,30 +568,30 @@ module Make_s let update_advertised_mempool_fields pv_shell advertisable_mempool validated_mempool = let open Lwt_syntax in - (if not (Mempool.is_empty advertisable_mempool) then - (* We only advertise newly classified operations. *) - Profiler.aggregate_f "advertise mempool" @@ fun () -> - advertise pv_shell advertisable_mempool) ; + if not (Mempool.is_empty advertisable_mempool) then + (* We only advertise newly classified operations. *) + advertise + pv_shell + advertisable_mempool [@profiler.aggregate_f "advertise mempool"] ; if Mempool.is_empty validated_mempool then Lwt.return_unit else let our_mempool = let known_valid = - Profiler.aggregate_f "union validated hashes" @@ fun () -> - Operation_hash.Set.union - validated_mempool.known_valid - pv_shell.mempool.known_valid + (Operation_hash.Set.union + validated_mempool.known_valid + pv_shell.mempool.known_valid + [@profiler.aggregate_f "union validated hashes"]) in let pending = - Profiler.aggregate_f "pending hashes" @@ fun () -> - Pending_ops.hashes pv_shell.pending + (Pending_ops.hashes + pv_shell.pending [@profiler.aggregate_f "pending hashes"]) in {Mempool.known_valid; pending} in let* _res = - Profiler.aggregate_s "set mempool" @@ fun () -> - set_mempool pv_shell our_mempool + (set_mempool pv_shell our_mempool [@profiler.aggregate_s "set mempool"]) in - Profiler.aggregate_s "pause" @@ fun () -> Lwt.pause () + (Lwt.pause () [@profiler.aggregate_s "pause"]) let handle_unprocessed pv = let open Lwt_syntax in @@ -616,12 +600,12 @@ module Make_s else let* () = Events.(emit processing_operations) () in let* validation_state, advertisable_mempool, validated_mempool = - Profiler.aggregate_s "classify pending operations" @@ fun () -> - classify_pending_operations - ~notifier - pv.shell - pv.config - pv.validation_state + (classify_pending_operations + ~notifier + pv.shell + pv.config + pv.validation_state + [@profiler.aggregate_s "classify pending operations"]) in pv.validation_state <- validation_state ; update_advertised_mempool_fields @@ -676,18 +660,18 @@ module Make_s match peer with Some peer -> Events.Peer peer | None -> Leftover in let spawn_fetch_operation ~notify_arrival = - Profiler.aggregate_f "fetching thread" @@ fun () -> - ignore - (Unit.catch_s (fun () -> - fetch_operation ~notify_arrival shell ?peer oph)) + (ignore + (Unit.catch_s (fun () -> + fetch_operation ~notify_arrival shell ?peer oph)) + [@profiler.aggregate_f "fetching thread"]) in - if Operation_hash.Set.mem oph shell.fetching then ( - Profiler.mark ["already fetching"] ; + if Operation_hash.Set.mem oph shell.fetching then (* If the operation is already being fetched, we notify the DDB that another peer may also be requested for the resource. In any case, the initial fetching thread will still be resolved and push an arrived worker request. *) - spawn_fetch_operation ~notify_arrival:false) + spawn_fetch_operation + ~notify_arrival:false [@profiler.mark ["already fetching"]] else if not (already_handled ~origin shell oph) then ( shell.fetching <- Operation_hash.Set.add oph shell.fetching ; spawn_fetch_operation ~notify_arrival:true) @@ -859,8 +843,9 @@ module Make_s let on_notify (shell : ('operation_data, _) types_state_shell) peer mempool = let may_fetch_operation = - Profiler.aggregate_f "may_fetch_operation" @@ fun () -> - may_fetch_operation shell (Some peer) + (may_fetch_operation + shell + (Some peer) [@profiler.aggregate_f "may_fetch_operation"]) in let () = Operation_hash.Set.iter may_fetch_operation mempool.Mempool.known_valid @@ -882,11 +867,10 @@ module Make_s pv.shell.timestamp <- timestamp_system ; let timestamp = Time.System.to_protocol timestamp_system in let* validation_state = - Profiler.aggregate_s "flush state" @@ fun () -> - pv.shell.parameters.flush - ~head:new_predecessor - ~timestamp - pv.validation_state + (pv.shell.parameters.flush + ~head:new_predecessor + ~timestamp + pv.validation_state [@profiler.aggregate_s "flush state"]) in pv.validation_state <- validation_state ; let*! new_pending_operations = @@ -906,23 +890,25 @@ module Make_s let*! new_pending_operations, nb_pending = Operation_hash.Map.fold_s (fun oph op (pending, nb_pending) -> - Profiler.aggregate_s "flushed operations" @@ fun () -> - let*! v = - pre_filter pv ~notifier:(mk_notifier pv.operation_stream) op - in - match v with - | Drop -> Lwt.return (pending, nb_pending) - | Priority ((High | Medium | Low _) as priority) -> - (* Here, an operation injected in this node with High priority will - now get its approriate priority. *) - let status = - (* If the operation has not yet been classified we set its - status to Fresh *) - if Pending_ops.mem oph pv.shell.pending then Pending_ops.Fresh - else Reclassified - in - Lwt.return - (Pending_ops.add op {status; priority} pending, nb_pending + 1)) + (let*! v = + pre_filter pv ~notifier:(mk_notifier pv.operation_stream) op + in + match v with + | Drop -> Lwt.return (pending, nb_pending) + | Priority ((High | Medium | Low _) as priority) -> + (* Here, an operation injected in this node with High priority will + now get its approriate priority. *) + let status = + (* If the operation has not yet been classified we set its + status to Fresh *) + if Pending_ops.mem oph pv.shell.pending then + Pending_ops.Fresh + else Reclassified + in + Lwt.return + ( Pending_ops.add op {status; priority} pending, + nb_pending + 1 )) + [@profiler.aggregate_s "flushed operations"]) new_pending_operations (Pending_ops.empty, 0) in @@ -1430,18 +1416,17 @@ module Make fun r -> let open Lwt_syntax in let* () = - Profiler.aggregate_s "handle_unprocessed" @@ fun () -> - handle_unprocessed pv + (handle_unprocessed pv [@profiler.aggregate_s "handle_unprocessed"]) in r in post_processing @@ match request with - | Request.Flush (hash, event, live_blocks, live_operations) -> - Profiler.stop () ; - let bh = Block_hash.to_b58check hash in - Format.kasprintf Profiler.record "%s" bh ; + | Request.Flush (hash, event, live_blocks, live_operations) -> ( + () + [@profiler.record Format.sprintf "%s" (Block_hash.to_b58check hash)] + [@profiler.stop] ; Requests.on_advertise pv.shell ; (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 Rebase the advertisement instead. *) @@ -1454,32 +1439,29 @@ module Make in Lwt_mutex.with_lock pv.lock @@ fun () : (r, error trace) result Lwt.t -> - Profiler.aggregate_s "on_flush" @@ fun () -> - Requests.on_flush - ~handle_branch_refused - pv - block - live_blocks - live_operations + (Requests.on_flush + ~handle_branch_refused + pv + block + live_blocks + live_operations [@profiler.aggregate_s "on_flush"])) | Request.Notify (peer, mempool) -> - Profiler.aggregate_f "on_notify" @@ fun () -> - Requests.on_notify pv.shell peer mempool ; - return_unit + (Requests.on_notify pv.shell peer mempool ; + return_unit) + [@profiler.aggregate_f "on_notify"] | Request.Leftover -> (* unprocessed ops are handled just below *) return_unit | Request.Inject {op; force} -> - Profiler.aggregate_s "on_inject" @@ fun () -> - Requests.on_inject pv ~force op + Requests.on_inject pv ~force op [@profiler.aggregate_s "on_inject"] | Request.Arrived (oph, op) -> - Profiler.aggregate_s "on_arrived" @@ fun () -> - Requests.on_arrived pv oph op + Requests.on_arrived pv oph op [@profiler.aggregate_s "on_arrived"] | Request.Advertise -> - Profiler.aggregate_s "on_advertise" @@ fun () -> - Requests.on_advertise pv.shell ; - return_unit + (Requests.on_advertise pv.shell ; + return_unit) + [@profiler.aggregate_s "on_advertise"] | Request.Ban oph -> - Profiler.aggregate_s "on_ban" @@ fun () -> Requests.on_ban pv oph + Requests.on_ban pv oph [@profiler.aggregate_s "on_ban"] let on_close w = let pv = Worker.state w in @@ -1501,8 +1483,11 @@ module Make let chain_store = Distributed_db.chain_store chain_db in let flush = Prevalidation_t.flush (Distributed_db.chain_store chain_db) in let*! head = Store.Chain.current_head chain_store in - let bh = Block_hash.to_b58check (Store.Block.hash head) in - Format.kasprintf Profiler.record "%s" bh ; + let () = + (() + [@profiler.record + Format.sprintf "%s" (Block_hash.to_b58check (Store.Block.hash head))]) + in let*! mempool = Store.Chain.mempool chain_store in let*! live_blocks, live_operations = Store.Chain.live_blocks chain_store -- GitLab From f609d7d7b25824078287dc9e28562ac8549c9461 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:27:58 +0200 Subject: [PATCH 05/19] Profiler: plug store profiler --- src/lib_shell/dune | 2 +- src/lib_store/unix/block_store.ml | 60 ++++++++++++++++++++-- src/lib_store/unix/cemented_block_store.ml | 30 ++++++++--- src/lib_store/unix/store.ml | 30 ++++++++++- 4 files changed, 108 insertions(+), 14 deletions(-) diff --git a/src/lib_shell/dune b/src/lib_shell/dune index 7a33495ebaaa..d407db3b0580 100644 --- a/src/lib_shell/dune +++ b/src/lib_shell/dune @@ -28,7 +28,7 @@ octez-libs.crypto-dal.dal-config lwt-exit) (inline_tests (flags -verbose) (modes native)) - (preprocess (pps octez-libs.ppx_profiler ppx_expect)) + (preprocess (pps ppx_expect octez-libs.ppx_profiler)) (flags (:standard) -open Tezos_base.TzPervasives diff --git a/src/lib_store/unix/block_store.ml b/src/lib_store/unix/block_store.ml index 0b78d985a06d..b11b56581b06 100644 --- a/src/lib_store/unix/block_store.ml +++ b/src/lib_store/unix/block_store.ml @@ -27,6 +27,13 @@ open Store_types open Block_repr open Store_errors +module Merge_profiler = struct + include (val Profiler.wrap Shell_profiling.merge_profiler) + + let reset_block_section = + Shell_profiling.create_reset_block_section Shell_profiling.merge_profiler +end + let default_block_cache_limit = 1_000 type merge_status = Not_running | Running | Merge_failed of tztrace @@ -412,6 +419,7 @@ let cement_blocks ?(check_consistency = true) ~write_metadata block_store in let {cemented_store; _} = block_store in let* () = + Merge_profiler.record_s "cement blocks" @@ fun () -> Cemented_block_store.cement_blocks ~check_consistency cemented_store @@ -915,6 +923,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let open Lwt_result_syntax in let*! () = Store_events.(emit start_updating_floating_stores) () in let* lpbl_block = + Merge_profiler.record_s "read lpbl block" @@ fun () -> read_predecessor_block_by_level block_store ~head:new_head new_head_lpbl in let final_hash, final_level = Block_repr.descriptor lpbl_block in @@ -934,6 +943,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store [ro_store; rw_store] in let*! lpbl_predecessors = + Merge_profiler.record_s "retrieve N lpbl's predecessors" @@ fun () -> try_retrieve_n_predecessors floating_stores final_hash @@ -942,6 +952,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store (* [min_level_to_preserve] is the lowest block that we want to keep in the floating stores. *) let*! min_level_to_preserve = + Merge_profiler.record_s "read min level block to preserve" @@ fun () -> match lpbl_predecessors with | [] -> Lwt.return new_head_lpbl | oldest_predecessor :: _ -> ( @@ -959,6 +970,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store the resulting [new_store] will be correct and will contain older blocks before more recent ones. *) let* () = + Merge_profiler.record_s "copy all lafl predecessors" @@ fun () -> Floating_block_store.raw_copy_all ~src_floating_stores:floating_stores ~block_hashes:lpbl_predecessors @@ -977,8 +989,18 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let blocks_lpbl = ref BlocksLPBL.empty in let*! () = Store_events.(emit start_retreiving_cycles) () in let* () = + Merge_profiler.record_s "iterate and prune floating stores" @@ fun () -> List.iter_es (fun store -> + let kind = + match Floating_block_store.kind store with + | RO -> "RO" + | RW -> "RW" + | _ -> assert false + in + Merge_profiler.record_s + (Printf.sprintf "iterate over floating store '%s'" kind) + @@ fun () -> Floating_block_store.raw_iterate (fun (block_bytes, total_block_length) -> let block_level = Block_repr_unix.raw_get_block_level block_bytes in @@ -1010,10 +1032,12 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store visited := Block_hash.Set.add block_hash !visited ; let*! {predecessors; resulting_context_hash} = let*! pred_opt = - Floating_block_store.find_info store block_hash + Merge_profiler.aggregate_s "find block index info" + @@ fun () -> Floating_block_store.find_info store block_hash in Lwt.return (WithExceptions.Option.get ~loc:__LOC__ pred_opt) in + Merge_profiler.aggregate_s "raw append block" @@ fun () -> Floating_block_store.raw_append new_store ( block_hash, @@ -1050,12 +1074,15 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let sorted_lpbl = List.sort Compare.Int32.compare (BlocksLPBL.elements !blocks_lpbl) in - let* cycles_to_cement = - let* cycles = loop [] initial_pred sorted_lpbl in + let* cycles = + Merge_profiler.record_s "retrieve cycle to cement" @@ fun () -> + loop [] initial_pred sorted_lpbl + in return (may_shrink_cycles cycles ~cycle_size_limit) in let* new_savepoint = + Merge_profiler.record_s "compute new savepoint" @@ fun () -> compute_new_savepoint block_store history_mode @@ -1065,6 +1092,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store ~cycles_to_cement in let* new_caboose = + Merge_profiler.record_s "compute new caboose" @@ fun () -> compute_new_caboose block_store history_mode @@ -1129,16 +1157,19 @@ let move_all_floating_stores block_store ~new_ro_store = (fun () -> (* (atomically?) Promote [new_ro] to [ro] *) let* () = + Merge_profiler.record_s "promote new ro floating as ro" @@ fun () -> move_floating_store block_store ~src:new_ro_store ~dst_kind:RO in (* ...and [new_rw] to [rw] *) let* () = + Merge_profiler.record_s "promote new rw floating as rw" @@ fun () -> move_floating_store block_store ~src:block_store.rw_floating_block_store ~dst_kind:RW in (* Load the swapped stores *) + Merge_profiler.record_s "open new floating stores" @@ fun () -> let*! ro = Floating_block_store.init chain_dir ~readonly:false RO in block_store.ro_floating_block_stores <- [ro] ; let*! rw = Floating_block_store.init chain_dir ~readonly:false RW in @@ -1217,6 +1248,7 @@ let instantiate_temporary_floating_store block_store = block_store.rw_floating_block_store :: block_store.ro_floating_block_stores ; let*! new_rw_store = + Merge_profiler.record_s "initializing RW TMP" @@ fun () -> Floating_block_store.init block_store.chain_dir ~readonly:false @@ -1246,12 +1278,14 @@ let create_merging_thread block_store ~history_mode ~old_ro_store ~old_rw_store let open Lwt_result_syntax in let*! () = Store_events.(emit start_merging_thread) () in let*! new_ro_store = + Merge_profiler.record_s "initializing RO TMP floating store" @@ fun () -> Floating_block_store.init block_store.chain_dir ~readonly:false RO_TMP in let* new_savepoint, new_caboose = Lwt.catch (fun () -> let* cycles_interval_to_cement, new_savepoint, new_caboose = + Merge_profiler.record_s "update floating stores" @@ fun () -> update_floating_stores block_store ~history_mode @@ -1403,6 +1437,8 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let* () = fail_when block_store.readonly Cannot_write_in_readonly in (* Do not allow multiple merges: force waiting for a potential previous merge. *) + Merge_profiler.reset_block_section (Block_repr.hash new_head) ; + Merge_profiler.record "merge store" ; let*! () = Lwt_mutex.lock block_store.merge_mutex in protect ~on_error:(fun err -> @@ -1420,6 +1456,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let* () = Lwt.finalize (fun () -> + Merge_profiler.span_s ["write status"] @@ fun () -> let*! () = lock block_store.stored_data_lockfile in Block_store_status.set_merge_status block_store.status_data) (fun () -> unlock block_store.stored_data_lockfile) @@ -1438,7 +1475,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store in let merge_start = Time.System.now () in let* () = + Merge_profiler.record "waiting for lock (start)" ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> + Merge_profiler.stop () ; (* Move the rw in the ro stores and create a new tmp *) let* old_ro_store, old_rw_store, _new_rw_store = Lwt.finalize @@ -1446,7 +1485,8 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store (* Lock the block store to avoid RO instances to open the state while the file descriptors are being updated. *) let*! () = lock block_store.lockfile in - instantiate_temporary_floating_store block_store) + Merge_profiler.record_s "instanciate tmp floating stores" + @@ fun () -> instantiate_temporary_floating_store block_store) (fun () -> unlock block_store.lockfile) in (* Important: do not clean-up the temporary stores on @@ -1469,6 +1509,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store on_error (Merge_error :: err)) (fun () -> let* new_ro_store, new_savepoint, new_caboose = + Merge_profiler.record_s "merging thread" @@ fun () -> create_merging_thread block_store ~cycle_size_limit @@ -1481,6 +1522,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store ~cementing_highwatermark in let* () = + Merge_profiler.record "waiting for lock (end)" ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> @@ -1493,6 +1535,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.lockfile in (* Critical section: update on-disk values *) let* () = + Merge_profiler.record_s + "move all floating stores" + @@ fun () -> move_all_floating_stores block_store ~new_ro_store @@ -1500,6 +1545,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.stored_data_lockfile in + Merge_profiler.span_s + ["write new checkpoints"] + @@ fun () -> let* () = write_caboose block_store new_caboose in @@ -1517,6 +1565,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store GC is performed, this call will block until its end. *) let* () = + Merge_profiler.span_s ["performing GC"] @@ fun () -> may_trigger_gc ~disable_context_pruning block_store @@ -1537,6 +1586,8 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.stored_data_lockfile in + Merge_profiler.record_s "set idle status" + @@ fun () -> Block_store_status.set_idle_status block_store.status_data) (fun () -> unlock block_store.stored_data_lockfile) @@ -1552,6 +1603,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store Prometheus.Gauge.set Store_metrics.metrics.last_store_merge_time (Ptime.Span.to_float_s merging_time) ; + Merge_profiler.stop () ; return_unit in block_store.merging_thread <- Some (new_head_lpbl, merging_thread) ; diff --git a/src/lib_store/unix/cemented_block_store.ml b/src/lib_store/unix/cemented_block_store.ml index 2f207655371f..2ad60f14cc2a 100644 --- a/src/lib_store/unix/cemented_block_store.ml +++ b/src/lib_store/unix/cemented_block_store.ml @@ -25,6 +25,8 @@ open Store_errors +module Profiler = (val Profiler.wrap Shell_profiling.merge_profiler) + (* Cemented files overlay: | x | x | @@ -713,6 +715,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) in let metadata_writer (block_bytes, total_block_length, block_level, metadata_offset) = + Profiler.aggregate_s "write metadata" @@ fun () -> Lwt_preemptive.detach (fun () -> let add, finish = @@ -729,6 +732,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) () in let metadata_finalizer () = + Profiler.record_s "finalize metadata" @@ fun () -> let*! () = Lwt_preemptive.detach Zip.close_out out_file in let metadata_file_path = Naming.cemented_blocks_metadata_file cemented_metadata_dir file @@ -755,12 +759,14 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) let first_offset = preamble_length in (* Cursor is now at the beginning of the element section *) let*! _ = + Profiler.record_s "write cemented cycle" @@ fun () -> Seq.ES.fold_left (fun (i, current_offset) block_read -> let* block_hash, total_block_length, block_bytes = block_read in let pruned_block_length = (* This call rewrites [block_bytes] to a pruned block (with its size modified) *) + Profiler.aggregate_f "prune raw block" @@ fun () -> Block_repr_unix.prune_raw_block_bytes block_bytes in (* We start by blitting the corresponding offset in the preamble part *) @@ -770,6 +776,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) (Int64.of_int current_offset) ; (* We write the block in the file *) let*! () = + Profiler.aggregate_s "write pruned block" @@ fun () -> Lwt_utils_unix.write_bytes ~pos:0 ~len:pruned_block_length @@ -793,6 +800,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) else return_unit) in (* We also populate the indexes *) + Profiler.record_s "update index" @@ fun () -> Cemented_block_level_index.replace cemented_store.cemented_block_level_index block_hash @@ -807,19 +815,24 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) in (* We now write the real offsets in the preamble *) let*! _ofs = Lwt_unix.lseek fd 0 Unix.SEEK_SET in + Profiler.record_s "blit cemented cycle offsets" @@ fun () -> Lwt_utils_unix.write_bytes ~pos:0 ~len:preamble_length fd offsets_buffer) (fun () -> let*! _ = Lwt_utils_unix.safe_close fd in Lwt.return_unit) in - let*! () = Lwt_unix.rename tmp_file_path final_path in + let*! () = + Profiler.record_s "mv temp file to final file" @@ fun () -> + Lwt_unix.rename tmp_file_path final_path + in (* Flush the indexes to make sure that the data is stored on disk *) - Cemented_block_level_index.flush - ~with_fsync:true - cemented_store.cemented_block_level_index ; - Cemented_block_hash_index.flush - ~with_fsync:true - cemented_store.cemented_block_hash_index ; + Profiler.record_f "flush indexes" (fun () -> + Cemented_block_level_index.flush + ~with_fsync:true + cemented_store.cemented_block_level_index ; + Cemented_block_hash_index.flush + ~with_fsync:true + cemented_store.cemented_block_hash_index) ; (* Update table *) let cemented_block_interval = {start_level = first_block_level; end_level = last_block_level; file} @@ -841,6 +854,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) let trigger_full_gc cemented_store cemented_blocks_files offset = let open Lwt_syntax in let nb_files = Array.length cemented_blocks_files in + Profiler.mark ["trigger full gc"] ; if nb_files <= offset then Lwt.return_unit else let cemented_files = Array.to_list cemented_blocks_files in @@ -868,6 +882,7 @@ let trigger_full_gc cemented_store cemented_blocks_files offset = let trigger_rolling_gc cemented_store cemented_blocks_files offset = let open Lwt_syntax in let nb_files = Array.length cemented_blocks_files in + Profiler.mark ["trigger rolling gc"] ; if nb_files <= offset then Lwt.return_unit else let {end_level = last_level_to_purge; _} = @@ -909,6 +924,7 @@ let trigger_rolling_gc cemented_store cemented_blocks_files offset = let trigger_gc cemented_store history_mode = let open Lwt_syntax in let* () = Store_events.(emit start_store_garbage_collection) () in + Profiler.record_s "trigger gc" @@ fun () -> match cemented_store.cemented_blocks_files with | None -> return_unit | Some cemented_blocks_files -> ( diff --git a/src/lib_store/unix/store.ml b/src/lib_store/unix/store.ml index 105b66d5042d..e8c1b3907375 100644 --- a/src/lib_store/unix/store.ml +++ b/src/lib_store/unix/store.ml @@ -26,6 +26,13 @@ open Store_types open Store_errors +module Profiler = struct + include (val Profiler.wrap Shell_profiling.store_profiler) + + let reset_block_section = + Shell_profiling.create_reset_block_section Shell_profiling.store_profiler +end + module Shared = struct type 'a t = {mutable data : 'a; lock : Lwt_idle_waiter.t} @@ -498,6 +505,10 @@ module Block = struct let store_block chain_store ~block_header ~operations validation_result = let open Lwt_result_syntax in + let bytes = Block_header.to_bytes block_header in + let hash = Block_header.hash_raw bytes in + Profiler.reset_block_section hash ; + Profiler.record_s "store_block" @@ fun () -> let { Block_validation.validation_store = { @@ -514,8 +525,6 @@ module Block = struct } = validation_result in - let bytes = Block_header.to_bytes block_header in - let hash = Block_header.hash_raw bytes in let operations_length = List.length operations in let operation_metadata_length = match ops_metadata with @@ -1272,6 +1281,8 @@ module Chain = struct state. Checking the expected capacity allows to force recomputing the livedata as soon as a max_op_ttl changes between blocks. *) + Profiler.record_s "Compute live blocks with new head" + @@ fun () -> let most_recent_block = Block.hash block in let most_recent_ops = Block.all_operation_hashes block @@ -1311,6 +1322,8 @@ module Chain = struct predecessor. It is an alternate head. We update the current cache by substituting the current head live data with the block's candidate one. *) + Profiler.record_s "compute live blocks with alternative head" + @@ fun () -> replace_head_from_live_data chain_state ~update_cache @@ -1323,6 +1336,8 @@ module Chain = struct (* The block candidate is not on top of the current head. It is likely to be an alternate branch. We recompute the whole live data. We may keep this new state in the cache. *) + Profiler.record_s "compute live blocks with alternative branch" + @@ fun () -> let new_cache = Ringo.Ring.create expected_capacity in let*! () = Chain_traversal.live_blocks_with_ring @@ -1344,6 +1359,7 @@ module Chain = struct (* The block candidate is not on top of the current head. It is likely to be an alternate head. We recompute the whole live data. *) + Profiler.record_s "compute whole live blocks" @@ fun () -> let*! new_live_blocks = Chain_traversal.live_blocks chain_store block expected_capacity in @@ -1374,8 +1390,10 @@ module Chain = struct let pred_cache = WithExceptions.Option.get ~loc:__LOC__ live_data_cache.pred in + Profiler.record_s "rollback livedata" @@ fun () -> rollback_livedata ~current_head live_blocks live_operations ~pred_cache else + Profiler.record_s "locked compute live blocks with cache" @@ fun () -> locked_compute_live_blocks_with_cache ~update_cache chain_store @@ -1387,6 +1405,7 @@ module Chain = struct let compute_live_blocks chain_store ~block = let open Lwt_result_syntax in + Profiler.record_s "compute live blocks" @@ fun () -> Shared.use chain_store.chain_state (fun chain_state -> let* metadata = Block.get_block_metadata chain_store block in let* r = @@ -1795,6 +1814,7 @@ module Chain = struct let set_head chain_store new_head = let open Lwt_result_syntax in + Profiler.record_s "set_head" @@ fun () -> Shared.update_with chain_store.chain_state (fun chain_state -> (* The merge cannot finish until we release the lock on the chain state so its status cannot change while this @@ -1830,6 +1850,7 @@ module Chain = struct (* Check that its predecessor exists and has metadata *) let predecessor = Block.predecessor new_head in let* new_head_metadata = + Profiler.record_s "get_pred_block" @@ fun () -> trace Bad_head_invariant (let* pred_block = Block.read_block chain_store predecessor in @@ -1845,6 +1866,7 @@ module Chain = struct Block.last_preserved_block_level new_head_metadata in let* () = + Profiler.record_s "may_split_context" @@ fun () -> may_split_context ~disable_context_pruning:chain_store.disable_context_pruning chain_store @@ -1971,6 +1993,7 @@ module Chain = struct - The heavy-work of this function is asynchronously done so this call is expected to return quickly. *) let* () = + Profiler.span_s ["start merge store"] @@ fun () -> Block_store.merge_stores chain_store.block_store ~on_error @@ -2033,13 +2056,16 @@ module Chain = struct (* Update values on disk but not the cementing highwatermark which will be updated by the merge finalizer. *) let* () = + Profiler.record_s "write_new_head" @@ fun () -> Stored_data.write chain_state.current_head_data new_head_descr in + Profiler.record_s "write_new_target" @@ fun () -> Stored_data.write chain_state.target_data new_target) (fun () -> unlock chain_store.stored_data_lockfile) in (* Update live_data *) let* live_blocks, live_operations = + Profiler.record_s "updating live blocks" @@ fun () -> locked_compute_live_blocks ~update_cache:true chain_store -- GitLab From 60bbeb4284759d2b3f3d5622eaec4294a389fce5 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Mon, 26 Aug 2024 14:01:41 +0200 Subject: [PATCH 06/19] Lib_store: store and merge_store - add ppx profiler --- manifest/product_octez.ml | 1 + src/lib_store/unix/block_store.ml | 360 +++---- src/lib_store/unix/cemented_block_store.ml | 188 ++-- src/lib_store/unix/dune | 1 + src/lib_store/unix/store.ml | 1072 ++++++++++---------- 5 files changed, 815 insertions(+), 807 deletions(-) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 7be53fb7554a..8b02d2065ba3 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -3485,6 +3485,7 @@ let octez_store_unix = "store.unix" ~internal_name:"tezos_store_unix" ~path:"src/lib_store/unix" + ~preprocess:(pps ppx_profiler) ~deps: [ octez_shell_services |> open_; diff --git a/src/lib_store/unix/block_store.ml b/src/lib_store/unix/block_store.ml index b11b56581b06..6a880cec2752 100644 --- a/src/lib_store/unix/block_store.ml +++ b/src/lib_store/unix/block_store.ml @@ -27,10 +27,10 @@ open Store_types open Block_repr open Store_errors -module Merge_profiler = struct +module Profiler = struct include (val Profiler.wrap Shell_profiling.merge_profiler) - let reset_block_section = + let[@warning "-32"] reset_block_section = Shell_profiling.create_reset_block_section Shell_profiling.merge_profiler end @@ -419,12 +419,11 @@ let cement_blocks ?(check_consistency = true) ~write_metadata block_store in let {cemented_store; _} = block_store in let* () = - Merge_profiler.record_s "cement blocks" @@ fun () -> - Cemented_block_store.cement_blocks - ~check_consistency - cemented_store - ~write_metadata - chunk_iterator + (Cemented_block_store.cement_blocks + ~check_consistency + cemented_store + ~write_metadata + chunk_iterator [@profiler.record_s "cement blocks"]) in let*! () = Store_events.(emit end_cementing_blocks) () in return_unit @@ -923,8 +922,10 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let open Lwt_result_syntax in let*! () = Store_events.(emit start_updating_floating_stores) () in let* lpbl_block = - Merge_profiler.record_s "read lpbl block" @@ fun () -> - read_predecessor_block_by_level block_store ~head:new_head new_head_lpbl + (read_predecessor_block_by_level + block_store + ~head:new_head + new_head_lpbl [@profiler.record_s "read lpbl block"]) in let final_hash, final_level = Block_repr.descriptor lpbl_block in (* 1. Append to the new RO [new_store] blocks between @@ -943,17 +944,18 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store [ro_store; rw_store] in let*! lpbl_predecessors = - Merge_profiler.record_s "retrieve N lpbl's predecessors" @@ fun () -> - try_retrieve_n_predecessors - floating_stores - final_hash - max_nb_blocks_to_retrieve + (try_retrieve_n_predecessors + floating_stores + final_hash + max_nb_blocks_to_retrieve + [@profiler.record_s "retrieve N lpbl's predecessors"]) in (* [min_level_to_preserve] is the lowest block that we want to keep in the floating stores. *) let*! min_level_to_preserve = - Merge_profiler.record_s "read min level block to preserve" @@ fun () -> - match lpbl_predecessors with + match[@profiler.record_s "read min level block to preserve"] + lpbl_predecessors + with | [] -> Lwt.return new_head_lpbl | oldest_predecessor :: _ -> ( let*! o = @@ -970,11 +972,11 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store the resulting [new_store] will be correct and will contain older blocks before more recent ones. *) let* () = - Merge_profiler.record_s "copy all lafl predecessors" @@ fun () -> - Floating_block_store.raw_copy_all - ~src_floating_stores:floating_stores - ~block_hashes:lpbl_predecessors - ~dst_floating_store:new_store + (Floating_block_store.raw_copy_all + ~src_floating_stores:floating_stores + ~block_hashes:lpbl_predecessors + ~dst_floating_store:new_store + [@profiler.record_s "copy all lpbl predecessors"]) in (* 2. Retrieve ALL cycles (potentially more than one) *) (* 2.1. We write back to the new store all the blocks from @@ -989,65 +991,70 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let blocks_lpbl = ref BlocksLPBL.empty in let*! () = Store_events.(emit start_retreiving_cycles) () in let* () = - Merge_profiler.record_s "iterate and prune floating stores" @@ fun () -> - List.iter_es - (fun store -> - let kind = - match Floating_block_store.kind store with - | RO -> "RO" - | RW -> "RW" - | _ -> assert false - in - Merge_profiler.record_s - (Printf.sprintf "iterate over floating store '%s'" kind) - @@ fun () -> - Floating_block_store.raw_iterate - (fun (block_bytes, total_block_length) -> - let block_level = Block_repr_unix.raw_get_block_level block_bytes in - (* Ignore blocks that are below the cementing highwatermark *) - if Compare.Int32.(block_level <= cementing_highwatermark) then - return_unit - else - let block_lpbl_opt = - Block_repr_unix.raw_get_last_preserved_block_level - block_bytes - total_block_length - in - (* Start by updating the set of cycles *) - Option.iter - (fun block_lpbl -> - if - Compare.Int32.( - cementing_highwatermark < block_lpbl - && block_lpbl <= new_head_lpbl) - then blocks_lpbl := BlocksLPBL.add block_lpbl !blocks_lpbl) - block_lpbl_opt ; - (* Append block if its predecessor was visited and update - the visited set. *) - let block_predecessor = - Block_repr_unix.raw_get_block_predecessor block_bytes + (List.iter_es + (fun store -> + let[@warning "-26"] kind = + match Floating_block_store.kind store with + | RO -> "RO" + | RW -> "RW" + | _ -> assert false + in + (Floating_block_store.raw_iterate + (fun (block_bytes, total_block_length) -> + let block_level = + Block_repr_unix.raw_get_block_level block_bytes in - let block_hash = Block_repr_unix.raw_get_block_hash block_bytes in - if Block_hash.Set.mem block_predecessor !visited then ( - visited := Block_hash.Set.add block_hash !visited ; - let*! {predecessors; resulting_context_hash} = - let*! pred_opt = - Merge_profiler.aggregate_s "find block index info" - @@ fun () -> Floating_block_store.find_info store block_hash - in - Lwt.return (WithExceptions.Option.get ~loc:__LOC__ pred_opt) + (* Ignore blocks that are below the cementing highwatermark *) + if Compare.Int32.(block_level <= cementing_highwatermark) then + return_unit + else + let block_lpbl_opt = + Block_repr_unix.raw_get_last_preserved_block_level + block_bytes + total_block_length in - Merge_profiler.aggregate_s "raw append block" @@ fun () -> - Floating_block_store.raw_append - new_store - ( block_hash, - block_bytes, - total_block_length, - predecessors, - resulting_context_hash )) - else return_unit) - store) - [ro_store; rw_store] + (* Start by updating the set of cycles *) + Option.iter + (fun block_lpbl -> + if + Compare.Int32.( + cementing_highwatermark < block_lpbl + && block_lpbl <= new_head_lpbl) + then blocks_lpbl := BlocksLPBL.add block_lpbl !blocks_lpbl) + block_lpbl_opt ; + (* Append block if its predecessor was visited and update + the visited set. *) + let block_predecessor = + Block_repr_unix.raw_get_block_predecessor block_bytes + in + let block_hash = + Block_repr_unix.raw_get_block_hash block_bytes + in + if Block_hash.Set.mem block_predecessor !visited then ( + visited := Block_hash.Set.add block_hash !visited ; + let*! {predecessors; resulting_context_hash} = + let*! pred_opt = + (Floating_block_store.find_info + store + block_hash + [@profiler.aggregate_s "find block index info"]) + in + Lwt.return (WithExceptions.Option.get ~loc:__LOC__ pred_opt) + in + (Floating_block_store.raw_append + new_store + ( block_hash, + block_bytes, + total_block_length, + predecessors, + resulting_context_hash ) + [@profiler.aggregate_s "raw append block"])) + else return_unit) + store + [@profiler.record_s + Printf.sprintf "iterate over floating store '%s'" kind])) + [ro_store; rw_store] + [@profiler.record_s "iterate and prune floating stores"]) in let is_cementing_highwatermark_genesis = Compare.Int32.( @@ -1076,29 +1083,29 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store in let* cycles_to_cement = let* cycles = - Merge_profiler.record_s "retrieve cycle to cement" @@ fun () -> - loop [] initial_pred sorted_lpbl + (loop + [] + initial_pred + sorted_lpbl [@profiler.record_s "retrieve cycle to cement"]) in return (may_shrink_cycles cycles ~cycle_size_limit) in let* new_savepoint = - Merge_profiler.record_s "compute new savepoint" @@ fun () -> - compute_new_savepoint - block_store - history_mode - ~new_store - ~min_level_to_preserve - ~new_head - ~cycles_to_cement + (compute_new_savepoint + block_store + history_mode + ~new_store + ~min_level_to_preserve + ~new_head + ~cycles_to_cement [@profiler.record_s "compute new savepoint"]) in let* new_caboose = - Merge_profiler.record_s "compute new caboose" @@ fun () -> - compute_new_caboose - block_store - history_mode - ~new_savepoint - ~min_level_to_preserve - ~new_head + (compute_new_caboose + block_store + history_mode + ~new_savepoint + ~min_level_to_preserve + ~new_head [@profiler.record_s "compute new caboose"]) in return (cycles_to_cement, new_savepoint, new_caboose) @@ -1157,24 +1164,25 @@ let move_all_floating_stores block_store ~new_ro_store = (fun () -> (* (atomically?) Promote [new_ro] to [ro] *) let* () = - Merge_profiler.record_s "promote new ro floating as ro" @@ fun () -> - move_floating_store block_store ~src:new_ro_store ~dst_kind:RO + (move_floating_store + block_store + ~src:new_ro_store + ~dst_kind:RO [@profiler.record_s "promote new ro floating as ro"]) in (* ...and [new_rw] to [rw] *) let* () = - Merge_profiler.record_s "promote new rw floating as rw" @@ fun () -> - move_floating_store - block_store - ~src:block_store.rw_floating_block_store - ~dst_kind:RW + (move_floating_store + block_store + ~src:block_store.rw_floating_block_store + ~dst_kind:RW [@profiler.record_s "promote new rw floating as rw"]) in (* Load the swapped stores *) - Merge_profiler.record_s "open new floating stores" @@ fun () -> - let*! ro = Floating_block_store.init chain_dir ~readonly:false RO in - block_store.ro_floating_block_stores <- [ro] ; - let*! rw = Floating_block_store.init chain_dir ~readonly:false RW in - block_store.rw_floating_block_store <- rw ; - return_unit) + (let*! ro = Floating_block_store.init chain_dir ~readonly:false RO in + block_store.ro_floating_block_stores <- [ro] ; + let*! rw = Floating_block_store.init chain_dir ~readonly:false RW in + block_store.rw_floating_block_store <- rw ; + return_unit) + [@profiler.record_s "open new floating stores"]) let check_store_consistency block_store ~cementing_highwatermark = let open Lwt_result_syntax in @@ -1248,11 +1256,10 @@ let instantiate_temporary_floating_store block_store = block_store.rw_floating_block_store :: block_store.ro_floating_block_stores ; let*! new_rw_store = - Merge_profiler.record_s "initializing RW TMP" @@ fun () -> - Floating_block_store.init - block_store.chain_dir - ~readonly:false - RW_TMP + (Floating_block_store.init + block_store.chain_dir + ~readonly:false + RW_TMP [@profiler.record_s "initializing RW TMP"]) in block_store.rw_floating_block_store <- new_rw_store ; return (ro_store, rw_store, new_rw_store))) @@ -1278,25 +1285,26 @@ let create_merging_thread block_store ~history_mode ~old_ro_store ~old_rw_store let open Lwt_result_syntax in let*! () = Store_events.(emit start_merging_thread) () in let*! new_ro_store = - Merge_profiler.record_s "initializing RO TMP floating store" @@ fun () -> - Floating_block_store.init block_store.chain_dir ~readonly:false RO_TMP + (Floating_block_store.init + block_store.chain_dir + ~readonly:false + RO_TMP [@profiler.record_s "initializing RO TMP floating store"]) in let* new_savepoint, new_caboose = Lwt.catch (fun () -> let* cycles_interval_to_cement, new_savepoint, new_caboose = - Merge_profiler.record_s "update floating stores" @@ fun () -> - update_floating_stores - block_store - ~history_mode - ~ro_store:old_ro_store - ~rw_store:old_rw_store - ~new_store:new_ro_store - ~new_head - ~new_head_lpbl - ~lowest_bound_to_preserve_in_floating - ~cementing_highwatermark - ~cycle_size_limit + (update_floating_stores + block_store + ~history_mode + ~ro_store:old_ro_store + ~rw_store:old_rw_store + ~new_store:new_ro_store + ~new_head + ~new_head_lpbl + ~lowest_bound_to_preserve_in_floating + ~cementing_highwatermark + ~cycle_size_limit [@profiler.record_s "update floating stores"]) in let*! () = Store_events.(emit cementing_block_ranges) cycles_interval_to_cement @@ -1437,8 +1445,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let* () = fail_when block_store.readonly Cannot_write_in_readonly in (* Do not allow multiple merges: force waiting for a potential previous merge. *) - Merge_profiler.reset_block_section (Block_repr.hash new_head) ; - Merge_profiler.record "merge store" ; + () + [@profiler.record "merge store"] + [@profiler.reset_block_section Block_repr.hash new_head] ; let*! () = Lwt_mutex.lock block_store.merge_mutex in protect ~on_error:(fun err -> @@ -1456,9 +1465,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let* () = Lwt.finalize (fun () -> - Merge_profiler.span_s ["write status"] @@ fun () -> - let*! () = lock block_store.stored_data_lockfile in - Block_store_status.set_merge_status block_store.status_data) + (let*! () = lock block_store.stored_data_lockfile in + Block_store_status.set_merge_status block_store.status_data) + [@profiler.span_s ["write status"]]) (fun () -> unlock block_store.stored_data_lockfile) in let new_head_lpbl = @@ -1475,9 +1484,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store in let merge_start = Time.System.now () in let* () = - Merge_profiler.record "waiting for lock (start)" ; + () [@profiler.record "waiting for lock (start)"] ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> - Merge_profiler.stop () ; + () [@profiler.stop] ; (* Move the rw in the ro stores and create a new tmp *) let* old_ro_store, old_rw_store, _new_rw_store = Lwt.finalize @@ -1485,8 +1494,10 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store (* Lock the block store to avoid RO instances to open the state while the file descriptors are being updated. *) let*! () = lock block_store.lockfile in - Merge_profiler.record_s "instanciate tmp floating stores" - @@ fun () -> instantiate_temporary_floating_store block_store) + + (instantiate_temporary_floating_store + block_store + [@profiler.record_s "instanciate tmp floating stores"])) (fun () -> unlock block_store.lockfile) in (* Important: do not clean-up the temporary stores on @@ -1509,20 +1520,20 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store on_error (Merge_error :: err)) (fun () -> let* new_ro_store, new_savepoint, new_caboose = - Merge_profiler.record_s "merging thread" @@ fun () -> - create_merging_thread - block_store - ~cycle_size_limit - ~history_mode - ~old_ro_store - ~old_rw_store - ~new_head - ~new_head_lpbl - ~lowest_bound_to_preserve_in_floating - ~cementing_highwatermark + (create_merging_thread + block_store + ~cycle_size_limit + ~history_mode + ~old_ro_store + ~old_rw_store + ~new_head + ~new_head_lpbl + ~lowest_bound_to_preserve_in_floating + ~cementing_highwatermark + [@profiler.record_s "merging thread"]) in let* () = - Merge_profiler.record "waiting for lock (end)" ; + () [@profiler.record "waiting for lock (end)"] ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> @@ -1535,26 +1546,23 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.lockfile in (* Critical section: update on-disk values *) let* () = - Merge_profiler.record_s - "move all floating stores" - @@ fun () -> - move_all_floating_stores - block_store - ~new_ro_store + (move_all_floating_stores + block_store + ~new_ro_store + [@profiler.record_s + "move all floating stores"]) in let*! () = lock block_store.stored_data_lockfile in - Merge_profiler.span_s - ["write new checkpoints"] - @@ fun () -> - let* () = - write_caboose block_store new_caboose - in - let* () = - write_savepoint block_store new_savepoint - in - return_unit) + (let* () = + write_caboose block_store new_caboose + in + let* () = + write_savepoint block_store new_savepoint + in + return_unit) + [@profiler.span_s ["write new checkpoints"]]) (fun () -> let*! () = unlock block_store.stored_data_lockfile @@ -1565,13 +1573,12 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store GC is performed, this call will block until its end. *) let* () = - Merge_profiler.span_s ["performing GC"] @@ fun () -> - may_trigger_gc - ~disable_context_pruning - block_store - history_mode - ~previous_savepoint - ~new_savepoint + (may_trigger_gc + ~disable_context_pruning + block_store + history_mode + ~previous_savepoint + ~new_savepoint [@profiler.span_s ["performing GC"]]) in (* Don't call the finalizer in the critical section, in case it needs to access the block @@ -1586,10 +1593,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.stored_data_lockfile in - Merge_profiler.record_s "set idle status" - @@ fun () -> - Block_store_status.set_idle_status - block_store.status_data) + (Block_store_status.set_idle_status + block_store.status_data + [@profiler.record_s "set idle status"])) (fun () -> unlock block_store.stored_data_lockfile) in return_unit)) @@ -1603,7 +1609,7 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store Prometheus.Gauge.set Store_metrics.metrics.last_store_merge_time (Ptime.Span.to_float_s merging_time) ; - Merge_profiler.stop () ; + () [@profiler.stop] ; return_unit in block_store.merging_thread <- Some (new_head_lpbl, merging_thread) ; diff --git a/src/lib_store/unix/cemented_block_store.ml b/src/lib_store/unix/cemented_block_store.ml index 2ad60f14cc2a..6c9ccbcbf78d 100644 --- a/src/lib_store/unix/cemented_block_store.ml +++ b/src/lib_store/unix/cemented_block_store.ml @@ -715,31 +715,30 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) in let metadata_writer (block_bytes, total_block_length, block_level, metadata_offset) = - Profiler.aggregate_s "write metadata" @@ fun () -> - Lwt_preemptive.detach - (fun () -> - let add, finish = - Zip.add_entry_generator - out_file - ~level:default_compression_level - (Int32.to_string block_level) - in - add - block_bytes - metadata_offset - (total_block_length - metadata_offset) ; - finish ()) - () + (Lwt_preemptive.detach + (fun () -> + let add, finish = + Zip.add_entry_generator + out_file + ~level:default_compression_level + (Int32.to_string block_level) + in + add + block_bytes + metadata_offset + (total_block_length - metadata_offset) ; + finish ()) + () [@profiler.record_s "finalize metadata"]) in let metadata_finalizer () = - Profiler.record_s "finalize metadata" @@ fun () -> - let*! () = Lwt_preemptive.detach Zip.close_out out_file in - let metadata_file_path = - Naming.cemented_blocks_metadata_file cemented_metadata_dir file - |> Naming.file_path - in - let*! () = Lwt_unix.rename tmp_metadata_file_path metadata_file_path in - return_unit + (let*! () = Lwt_preemptive.detach Zip.close_out out_file in + let metadata_file_path = + Naming.cemented_blocks_metadata_file cemented_metadata_dir file + |> Naming.file_path + in + let*! () = Lwt_unix.rename tmp_metadata_file_path metadata_file_path in + return_unit) + [@profiler.record_s "finalize metadata"] in return (metadata_writer, metadata_finalizer) else return ((fun _ -> Lwt.return_unit), fun () -> return_unit) @@ -759,80 +758,82 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) let first_offset = preamble_length in (* Cursor is now at the beginning of the element section *) let*! _ = - Profiler.record_s "write cemented cycle" @@ fun () -> - Seq.ES.fold_left - (fun (i, current_offset) block_read -> - let* block_hash, total_block_length, block_bytes = block_read in - let pruned_block_length = - (* This call rewrites [block_bytes] to a pruned block - (with its size modified) *) - Profiler.aggregate_f "prune raw block" @@ fun () -> - Block_repr_unix.prune_raw_block_bytes block_bytes - in - (* We start by blitting the corresponding offset in the preamble part *) - Bytes.set_int64_be - offsets_buffer - (i * offset_length) - (Int64.of_int current_offset) ; - (* We write the block in the file *) - let*! () = - Profiler.aggregate_s "write pruned block" @@ fun () -> - Lwt_utils_unix.write_bytes - ~pos:0 - ~len:pruned_block_length - fd - block_bytes - in - let block_level = Int32.(add first_block_level (of_int i)) in - let* () = - protect (fun () -> - if total_block_length > pruned_block_length then - (* Do not try to write to block's metadata if - there are none *) - let*! () = - metadata_writer - ( block_bytes, - total_block_length, - block_level, - pruned_block_length ) - in - return_unit - else return_unit) - in - (* We also populate the indexes *) - Profiler.record_s "update index" @@ fun () -> - Cemented_block_level_index.replace - cemented_store.cemented_block_level_index - block_hash - block_level ; - Cemented_block_hash_index.replace - cemented_store.cemented_block_hash_index - block_level - block_hash ; - return (succ i, current_offset + pruned_block_length)) - (0, first_offset) - reading_sequence + (Seq.ES.fold_left + (fun (i, current_offset) block_read -> + let* block_hash, total_block_length, block_bytes = block_read in + let pruned_block_length = + (* This call rewrites [block_bytes] to a pruned block + (with its size modified) *) + (Block_repr_unix.prune_raw_block_bytes + block_bytes [@profiler.aggregate_f "prune raw block"]) + in + (* We start by blitting the corresponding offset in the preamble part *) + Bytes.set_int64_be + offsets_buffer + (i * offset_length) + (Int64.of_int current_offset) ; + (* We write the block in the file *) + let*! () = + (Lwt_utils_unix.write_bytes + ~pos:0 + ~len:pruned_block_length + fd + block_bytes [@profiler.aggregate_s "write pruned block"]) + in + let block_level = Int32.(add first_block_level (of_int i)) in + let* () = + protect (fun () -> + if total_block_length > pruned_block_length then + (* Do not try to write to block's metadata if + there are none *) + let*! () = + metadata_writer + ( block_bytes, + total_block_length, + block_level, + pruned_block_length ) + in + return_unit + else return_unit) + in + (* We also populate the indexes *) + ((Cemented_block_level_index.replace + cemented_store.cemented_block_level_index + block_hash + block_level ; + Cemented_block_hash_index.replace + cemented_store.cemented_block_hash_index + block_level + block_hash ; + return (succ i, current_offset + pruned_block_length)) + [@profiler.record_s "write cemented cycle"])) + (0, first_offset) + reading_sequence [@profiler.record_s "write cemented cycle"]) in (* We now write the real offsets in the preamble *) let*! _ofs = Lwt_unix.lseek fd 0 Unix.SEEK_SET in - Profiler.record_s "blit cemented cycle offsets" @@ fun () -> - Lwt_utils_unix.write_bytes ~pos:0 ~len:preamble_length fd offsets_buffer) + (Lwt_utils_unix.write_bytes + ~pos:0 + ~len:preamble_length + fd + offsets_buffer [@profiler.record_s "blit cemented cycle offsets"])) (fun () -> let*! _ = Lwt_utils_unix.safe_close fd in Lwt.return_unit) in let*! () = - Profiler.record_s "mv temp file to final file" @@ fun () -> - Lwt_unix.rename tmp_file_path final_path + (Lwt_unix.rename + tmp_file_path + final_path [@profiler.record_s "mv temp file to final file"]) in (* Flush the indexes to make sure that the data is stored on disk *) - Profiler.record_f "flush indexes" (fun () -> - Cemented_block_level_index.flush - ~with_fsync:true - cemented_store.cemented_block_level_index ; - Cemented_block_hash_index.flush - ~with_fsync:true - cemented_store.cemented_block_hash_index) ; + (Cemented_block_level_index.flush + ~with_fsync:true + cemented_store.cemented_block_level_index ; + Cemented_block_hash_index.flush + ~with_fsync:true + cemented_store.cemented_block_hash_index) + [@profiler.record_f "flush indexes"] ; (* Update table *) let cemented_block_interval = {start_level = first_block_level; end_level = last_block_level; file} @@ -854,7 +855,7 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) let trigger_full_gc cemented_store cemented_blocks_files offset = let open Lwt_syntax in let nb_files = Array.length cemented_blocks_files in - Profiler.mark ["trigger full gc"] ; + () [@profiler.mark ["trigger full gc"]] ; if nb_files <= offset then Lwt.return_unit else let cemented_files = Array.to_list cemented_blocks_files in @@ -882,7 +883,7 @@ let trigger_full_gc cemented_store cemented_blocks_files offset = let trigger_rolling_gc cemented_store cemented_blocks_files offset = let open Lwt_syntax in let nb_files = Array.length cemented_blocks_files in - Profiler.mark ["trigger rolling gc"] ; + () [@profiler.mark ["trigger rolling gc"]] ; if nb_files <= offset then Lwt.return_unit else let {end_level = last_level_to_purge; _} = @@ -924,8 +925,9 @@ let trigger_rolling_gc cemented_store cemented_blocks_files offset = let trigger_gc cemented_store history_mode = let open Lwt_syntax in let* () = Store_events.(emit start_store_garbage_collection) () in - Profiler.record_s "trigger gc" @@ fun () -> - match cemented_store.cemented_blocks_files with + match[@profiler.record_s "trigger gc"] + cemented_store.cemented_blocks_files + with | None -> return_unit | Some cemented_blocks_files -> ( match history_mode with @@ -1119,10 +1121,10 @@ let get_and_upgrade_offsets fd nb_blocks = Data_encoding.(Variable.array ~max_length:nb_blocks int64) offsets_64_bits -(** [is_using_32_bit_offsets fd nb_blocks] checks whether the cemented file +(** [is_using_32_bit_offsets fd nb_blocks] checks whether the cemented file given by [fd] is formatted with 32 bit offsets; the decision is taken based on whether the first offset points correctly to the first - block in the file or not; + block in the file or not; - offset = first 32 bits decoded as an int32 - first_block_offset = 4 (bytes) * [nb_blocks] (first block offset, given that the file has 32-bit offsets) diff --git a/src/lib_store/unix/dune b/src/lib_store/unix/dune index 36f0dfa8661f..7bfca44946c5 100644 --- a/src/lib_store/unix/dune +++ b/src/lib_store/unix/dune @@ -25,6 +25,7 @@ tar tar-unix octez-libs.prometheus) + (preprocess (pps octez-libs.ppx_profiler)) (flags (:standard) -open Tezos_shell_services diff --git a/src/lib_store/unix/store.ml b/src/lib_store/unix/store.ml index e8c1b3907375..b8179df60a39 100644 --- a/src/lib_store/unix/store.ml +++ b/src/lib_store/unix/store.ml @@ -29,7 +29,7 @@ open Store_errors module Profiler = struct include (val Profiler.wrap Shell_profiling.store_profiler) - let reset_block_section = + let[@warning "-32"] reset_block_section = Shell_profiling.create_reset_block_section Shell_profiling.store_profiler end @@ -507,196 +507,197 @@ module Block = struct let open Lwt_result_syntax in let bytes = Block_header.to_bytes block_header in let hash = Block_header.hash_raw bytes in - Profiler.reset_block_section hash ; - Profiler.record_s "store_block" @@ fun () -> - let { - Block_validation.validation_store = - { - resulting_context_hash; - timestamp = _; - message; - max_operations_ttl; - last_preserved_block_level; - last_finalized_block_level; - }; - block_metadata; - ops_metadata; - shell_header_hash = _; - } = - validation_result - in - let operations_length = List.length operations in - let operation_metadata_length = - match ops_metadata with - | Block_validation.No_metadata_hash x -> List.length x - | Block_validation.Metadata_hash x -> List.length x - in - let validation_passes = block_header.shell.validation_passes in - let* () = - fail_unless - (validation_passes = operations_length) - (Cannot_store_block - ( hash, - Invalid_operations_length - {validation_passes; operations = operations_length} )) - in - let* () = - fail_unless - (validation_passes = operation_metadata_length) - (Cannot_store_block - ( hash, - Invalid_operations_length - {validation_passes; operations = operation_metadata_length} )) - in - let* () = - match ops_metadata with - | No_metadata_hash ops_metadata -> - check_metadata_list ~block_hash:hash ~operations ~ops_metadata - | Metadata_hash ops_metadata -> - check_metadata_list ~block_hash:hash ~operations ~ops_metadata - in - let*! genesis_block = Stored_data.get chain_store.genesis_block_data in - let is_main_chain = - Chain_id.equal - chain_store.chain_id - (WithExceptions.Option.get - ~loc:__LOC__ - chain_store.global_store.main_chain_store) - .chain_id - in - let genesis_level = Block_repr.level genesis_block in - let* last_preserved_block_level = - if is_main_chain then - let* () = - fail_unless - Compare.Int32.(last_preserved_block_level >= genesis_level) - (Cannot_store_block - ( hash, - Invalid_last_preserved_block_level - {last_preserved_block_level; genesis_level} )) - in - return last_preserved_block_level - else if Compare.Int32.(last_preserved_block_level < genesis_level) then - (* Hack: on the testchain, the block's lpbl depends on the - lpbl and is not max(genesis_level, expected_lpbl) *) - return genesis_level - else return last_preserved_block_level - in - let*! b = is_known_valid chain_store hash in - match b with - | true -> return_none - | false -> - (* Safety check: never ever commit a block that is not - compatible with the current checkpoint/target. *) - let*! acceptable_block, known_invalid = - Shared.use chain_store.chain_state (fun chain_state -> - let*! acceptable_block = - locked_is_acceptable_block - chain_state - (hash, block_header.shell.level) - in - let*! known_invalid = locked_is_known_invalid chain_state hash in - Lwt.return (acceptable_block, known_invalid)) - in - let* () = - fail_unless - acceptable_block - (Validation_errors.Checkpoint_error (hash, None)) - in - let* () = - fail_when - known_invalid - Store_errors.(Cannot_store_block (hash, Invalid_block)) - in - let contents = - { - Block_repr.header = block_header; - operations; - block_metadata_hash = snd block_metadata; - operations_metadata_hashes = - (match ops_metadata with - | Block_validation.No_metadata_hash _ -> None - | Block_validation.Metadata_hash ops_metadata -> - Some (List.map (List.map snd) ops_metadata)); - } - in - let metadata = - Some - { - message; - max_operations_ttl; - last_preserved_block_level; - block_metadata = fst block_metadata; - operations_metadata = - (match ops_metadata with - | Block_validation.No_metadata_hash ops_metadata -> ops_metadata - | Block_validation.Metadata_hash ops_metadata -> - List.map (List.map fst) ops_metadata); - } - in - let block = {Block_repr.hash; contents; metadata} in - let* () = - Block_store.store_block - chain_store.block_store - block - resulting_context_hash - in - let protocol_level = Block_repr.proto_level block in - let* pred_block = - read_block chain_store (Block_repr.predecessor block) - in - let pred_proto_level = Block_repr.proto_level pred_block in - (* We update the protocol_table when a block contains a - protocol level change. *) - let* () = - if Compare.Int.(pred_proto_level < protocol_level) then - let context_index = chain_store.global_store.context_index in - let* resulting_context = - protect (fun () -> - let*! c = - Context_ops.checkout_exn - context_index - resulting_context_hash - in - return c) - in - let*! protocol_hash = Context_ops.get_protocol resulting_context in - let* (module NewProto) = - Registered_protocol.get_result protocol_hash - in - set_protocol_level - chain_store - ~protocol_level - ( block, - protocol_hash, - NewProto.expected_context_hash = Predecessor_resulting_context - ) - else return_unit - in - let*! () = - Store_events.(emit store_block) (hash, block_header.shell.level) - in - let* () = - Shared.update_with chain_store.chain_state (fun chain_state -> - Block_lru_cache.remove chain_state.validated_blocks hash ; - let new_last_finalized_block_level = - match chain_state.last_finalized_block_level with - | None -> Some last_finalized_block_level - | Some prev_lfbl -> - Some (Int32.max last_finalized_block_level prev_lfbl) - in - let new_chain_state = - { - chain_state with - last_finalized_block_level = new_last_finalized_block_level; - } - in - return (Some new_chain_state, ())) - in - Lwt_watcher.notify - chain_store.global_store.global_block_watcher - (chain_store, block) ; - return_some block + () [@profiler.reset_block_section hash] ; + (let { + Block_validation.validation_store = + { + resulting_context_hash; + timestamp = _; + message; + max_operations_ttl; + last_preserved_block_level; + last_finalized_block_level; + }; + block_metadata; + ops_metadata; + shell_header_hash = _; + } = + validation_result + in + let operations_length = List.length operations in + let operation_metadata_length = + match ops_metadata with + | Block_validation.No_metadata_hash x -> List.length x + | Block_validation.Metadata_hash x -> List.length x + in + let validation_passes = block_header.shell.validation_passes in + let* () = + fail_unless + (validation_passes = operations_length) + (Cannot_store_block + ( hash, + Invalid_operations_length + {validation_passes; operations = operations_length} )) + in + let* () = + fail_unless + (validation_passes = operation_metadata_length) + (Cannot_store_block + ( hash, + Invalid_operations_length + {validation_passes; operations = operation_metadata_length} )) + in + let* () = + match ops_metadata with + | No_metadata_hash ops_metadata -> + check_metadata_list ~block_hash:hash ~operations ~ops_metadata + | Metadata_hash ops_metadata -> + check_metadata_list ~block_hash:hash ~operations ~ops_metadata + in + let*! genesis_block = Stored_data.get chain_store.genesis_block_data in + let is_main_chain = + Chain_id.equal + chain_store.chain_id + (WithExceptions.Option.get + ~loc:__LOC__ + chain_store.global_store.main_chain_store) + .chain_id + in + let genesis_level = Block_repr.level genesis_block in + let* last_preserved_block_level = + if is_main_chain then + let* () = + fail_unless + Compare.Int32.(last_preserved_block_level >= genesis_level) + (Cannot_store_block + ( hash, + Invalid_last_preserved_block_level + {last_preserved_block_level; genesis_level} )) + in + return last_preserved_block_level + else if Compare.Int32.(last_preserved_block_level < genesis_level) then + (* Hack: on the testchain, the block's lpbl depends on the + lpbl and is not max(genesis_level, expected_lpbl) *) + return genesis_level + else return last_preserved_block_level + in + let*! b = is_known_valid chain_store hash in + match b with + | true -> return_none + | false -> + (* Safety check: never ever commit a block that is not + compatible with the current checkpoint/target. *) + let*! acceptable_block, known_invalid = + Shared.use chain_store.chain_state (fun chain_state -> + let*! acceptable_block = + locked_is_acceptable_block + chain_state + (hash, block_header.shell.level) + in + let*! known_invalid = locked_is_known_invalid chain_state hash in + Lwt.return (acceptable_block, known_invalid)) + in + let* () = + fail_unless + acceptable_block + (Validation_errors.Checkpoint_error (hash, None)) + in + let* () = + fail_when + known_invalid + Store_errors.(Cannot_store_block (hash, Invalid_block)) + in + let contents = + { + Block_repr.header = block_header; + operations; + block_metadata_hash = snd block_metadata; + operations_metadata_hashes = + (match ops_metadata with + | Block_validation.No_metadata_hash _ -> None + | Block_validation.Metadata_hash ops_metadata -> + Some (List.map (List.map snd) ops_metadata)); + } + in + let metadata = + Some + { + message; + max_operations_ttl; + last_preserved_block_level; + block_metadata = fst block_metadata; + operations_metadata = + (match ops_metadata with + | Block_validation.No_metadata_hash ops_metadata -> + ops_metadata + | Block_validation.Metadata_hash ops_metadata -> + List.map (List.map fst) ops_metadata); + } + in + let block = {Block_repr.hash; contents; metadata} in + let* () = + Block_store.store_block + chain_store.block_store + block + resulting_context_hash + in + let protocol_level = Block_repr.proto_level block in + let* pred_block = + read_block chain_store (Block_repr.predecessor block) + in + let pred_proto_level = Block_repr.proto_level pred_block in + (* We update the protocol_table when a block contains a + protocol level change. *) + let* () = + if Compare.Int.(pred_proto_level < protocol_level) then + let context_index = chain_store.global_store.context_index in + let* resulting_context = + protect (fun () -> + let*! c = + Context_ops.checkout_exn + context_index + resulting_context_hash + in + return c) + in + let*! protocol_hash = Context_ops.get_protocol resulting_context in + let* (module NewProto) = + Registered_protocol.get_result protocol_hash + in + set_protocol_level + chain_store + ~protocol_level + ( block, + protocol_hash, + NewProto.expected_context_hash = Predecessor_resulting_context + ) + else return_unit + in + let*! () = + Store_events.(emit store_block) (hash, block_header.shell.level) + in + let* () = + Shared.update_with chain_store.chain_state (fun chain_state -> + Block_lru_cache.remove chain_state.validated_blocks hash ; + let new_last_finalized_block_level = + match chain_state.last_finalized_block_level with + | None -> Some last_finalized_block_level + | Some prev_lfbl -> + Some (Int32.max last_finalized_block_level prev_lfbl) + in + let new_chain_state = + { + chain_state with + last_finalized_block_level = new_last_finalized_block_level; + } + in + return (Some new_chain_state, ())) + in + Lwt_watcher.notify + chain_store.global_store.global_block_watcher + (chain_store, block) ; + return_some block) + [@profiler.record_s "store_block"] let store_validated_block chain_store ~hash ~block_header ~operations = let open Lwt_result_syntax in @@ -1274,45 +1275,44 @@ module Chain = struct (Block.predecessor block) (Block.hash current_head) && Ringo.Ring.capacity live_data = expected_capacity -> ( - (* The block candidate is on top of the current head. It - corresponds to a new promoted head. We need to move the - live data window one stop forward, including that new head - and discarding the oldest block of the previous - state. Checking the expected capacity allows to force - recomputing the livedata as soon as a max_op_ttl changes - between blocks. *) - Profiler.record_s "Compute live blocks with new head" - @@ fun () -> - let most_recent_block = Block.hash block in - let most_recent_ops = - Block.all_operation_hashes block - |> List.flatten |> Operation_hash.Set.of_list - in - let new_live_blocks = - Block_hash.Set.add most_recent_block live_blocks - in - let new_live_operations = - Operation_hash.Set.union most_recent_ops live_operations - in - match - Ringo.Ring.add_and_return_erased - live_data - (most_recent_block, most_recent_ops) - with - | None -> return (new_live_blocks, new_live_operations) - | Some (last_block, last_ops) -> - let diffed_new_live_blocks = - Block_hash.Set.remove last_block new_live_blocks - in - let diffed_new_live_operations = - Operation_hash.Set.diff new_live_operations last_ops - in - chain_state.live_data_cache <- - { - chain_state.live_data_cache with - pred = Some (last_block, last_ops); - } ; - return (diffed_new_live_blocks, diffed_new_live_operations)) + ((* The block candidate is on top of the current head. It + corresponds to a new promoted head. We need to move the + live data window one stop forward, including that new head + and discarding the oldest block of the previous + state. Checking the expected capacity allows to force + recomputing the livedata as soon as a max_op_ttl changes + between blocks. *) + let most_recent_block = Block.hash block in + let most_recent_ops = + Block.all_operation_hashes block + |> List.flatten |> Operation_hash.Set.of_list + in + let new_live_blocks = + Block_hash.Set.add most_recent_block live_blocks + in + let new_live_operations = + Operation_hash.Set.union most_recent_ops live_operations + in + match + Ringo.Ring.add_and_return_erased + live_data + (most_recent_block, most_recent_ops) + with + | None -> return (new_live_blocks, new_live_operations) + | Some (last_block, last_ops) -> + let diffed_new_live_blocks = + Block_hash.Set.remove last_block new_live_blocks + in + let diffed_new_live_operations = + Operation_hash.Set.diff new_live_operations last_ops + in + chain_state.live_data_cache <- + { + chain_state.live_data_cache with + pred = Some (last_block, last_ops); + } ; + return (diffed_new_live_blocks, diffed_new_live_operations)) + [@profiler.record_s "Compute live blocks with new head"]) | Some live_data, Some _ when Block_hash.equal (Block.predecessor block) @@ -1322,8 +1322,6 @@ module Chain = struct predecessor. It is an alternate head. We update the current cache by substituting the current head live data with the block's candidate one. *) - Profiler.record_s "compute live blocks with alternative head" - @@ fun () -> replace_head_from_live_data chain_state ~update_cache @@ -1332,36 +1330,39 @@ module Chain = struct live_operations ~new_head:block ~cache_expected_capacity:expected_capacity + [@profiler.record_s "compute live blocks with alternative head"] | _ when update_cache -> (* The block candidate is not on top of the current head. It is likely to be an alternate branch. We recompute the whole live data. We may keep this new state in the cache. *) - Profiler.record_s "compute live blocks with alternative branch" - @@ fun () -> - let new_cache = Ringo.Ring.create expected_capacity in - let*! () = - Chain_traversal.live_blocks_with_ring - chain_store - block - expected_capacity - new_cache - in - chain_state.live_data_cache <- {live_data = Some new_cache; pred = None} ; - let live_blocks, live_ops = - Ringo.Ring.fold - new_cache - ~init:(Block_hash.Set.empty, Operation_hash.Set.empty) - ~f:(fun (bhs, opss) (bh, ops) -> - (Block_hash.Set.add bh bhs, Operation_hash.Set.union ops opss)) - in - return (live_blocks, live_ops) + (let new_cache = Ringo.Ring.create expected_capacity in + let*! () = + Chain_traversal.live_blocks_with_ring + chain_store + block + expected_capacity + new_cache + in + chain_state.live_data_cache <- + {live_data = Some new_cache; pred = None} ; + let live_blocks, live_ops = + Ringo.Ring.fold + new_cache + ~init:(Block_hash.Set.empty, Operation_hash.Set.empty) + ~f:(fun (bhs, opss) (bh, ops) -> + (Block_hash.Set.add bh bhs, Operation_hash.Set.union ops opss)) + in + return (live_blocks, live_ops)) + [@profiler.record_s "compute live blocks with alternative branch"] | _ -> (* The block candidate is not on top of the current head. It is likely to be an alternate head. We recompute the whole live data. *) - Profiler.record_s "compute whole live blocks" @@ fun () -> let*! new_live_blocks = - Chain_traversal.live_blocks chain_store block expected_capacity + (Chain_traversal.live_blocks + chain_store + block + expected_capacity [@profiler.record_s "compute whole live blocks"]) in return new_live_blocks @@ -1390,33 +1391,35 @@ module Chain = struct let pred_cache = WithExceptions.Option.get ~loc:__LOC__ live_data_cache.pred in - Profiler.record_s "rollback livedata" @@ fun () -> - rollback_livedata ~current_head live_blocks live_operations ~pred_cache + (rollback_livedata + ~current_head + live_blocks + live_operations + ~pred_cache [@profiler.record_s "rollback livedata"]) else - Profiler.record_s "locked compute live blocks with cache" @@ fun () -> locked_compute_live_blocks_with_cache ~update_cache chain_store chain_state block - metadata + metadata [@profiler.record_s "locked compute live blocks with cache"] in return res let compute_live_blocks chain_store ~block = let open Lwt_result_syntax in - Profiler.record_s "compute live blocks" @@ fun () -> - Shared.use chain_store.chain_state (fun chain_state -> - let* metadata = Block.get_block_metadata chain_store block in - let* r = - locked_compute_live_blocks - ~update_cache:false - chain_store - chain_state - block - metadata - in - return r) + (Shared.use chain_store.chain_state (fun chain_state -> + let* metadata = Block.get_block_metadata chain_store block in + let* r = + locked_compute_live_blocks + ~update_cache:false + chain_store + chain_state + block + metadata + in + return r) + [@profiler.record_s "compute live blocks"]) let is_ancestor chain_store ~head:(hash, lvl) ~ancestor:(hash', lvl') = let open Lwt_syntax in @@ -1814,275 +1817,270 @@ module Chain = struct let set_head chain_store new_head = let open Lwt_result_syntax in - Profiler.record_s "set_head" @@ fun () -> - Shared.update_with chain_store.chain_state (fun chain_state -> - (* The merge cannot finish until we release the lock on the - chain state so its status cannot change while this - function is executed. *) - (* Also check the status to be extra-safe *) - let*! store_status = Block_store.status chain_store.block_store in - let* is_merge_ongoing = - match Block_store.get_merge_status chain_store.block_store with - | Merge_failed errs -> - (* If the merge has failed, notify in the logs but don't - trigger any merge. *) - let*! () = Store_events.(emit notify_merge_error errs) in - (* We mark the merge as on-going to prevent the merge from - being triggered and to update on-disk values. *) - return_true - | Not_running when not @@ Block_store_status.is_idle store_status -> - (* Degenerate case, do the same as the Merge_failed case *) - let*! () = Store_events.(emit notify_merge_error []) in - return_true - | Not_running -> return_false - | Running -> return_true - in - let previous_head = chain_state.current_head in - let*! checkpoint = Stored_data.get chain_state.checkpoint_data in - let new_head_descr = Block.descriptor new_head in - (* Check that the new_head is consistent with the checkpoint *) - let* () = - fail_unless - Compare.Int32.(Block.level new_head >= snd checkpoint) - (Invalid_head_switch - {checkpoint_level = snd checkpoint; given_head = new_head_descr}) - in - (* Check that its predecessor exists and has metadata *) - let predecessor = Block.predecessor new_head in - let* new_head_metadata = - Profiler.record_s "get_pred_block" @@ fun () -> - trace - Bad_head_invariant - (let* pred_block = Block.read_block chain_store predecessor in - (* check that predecessor's block metadata is - available *) - let* _pred_head_metadata = - Block.get_block_metadata chain_store pred_block + (Shared.update_with chain_store.chain_state (fun chain_state -> + (* The merge cannot finish until we release the lock on the + chain state so its status cannot change while this + function is executed. *) + (* Also check the status to be extra-safe *) + let*! store_status = Block_store.status chain_store.block_store in + let* is_merge_ongoing = + match Block_store.get_merge_status chain_store.block_store with + | Merge_failed errs -> + (* If the merge has failed, notify in the logs but don't + trigger any merge. *) + let*! () = Store_events.(emit notify_merge_error errs) in + (* We mark the merge as on-going to prevent the merge from + being triggered and to update on-disk values. *) + return_true + | Not_running when not @@ Block_store_status.is_idle store_status -> + (* Degenerate case, do the same as the Merge_failed case *) + let*! () = Store_events.(emit notify_merge_error []) in + return_true + | Not_running -> return_false + | Running -> return_true + in + let previous_head = chain_state.current_head in + let*! checkpoint = Stored_data.get chain_state.checkpoint_data in + let new_head_descr = Block.descriptor new_head in + (* Check that the new_head is consistent with the checkpoint *) + let* () = + fail_unless + Compare.Int32.(Block.level new_head >= snd checkpoint) + (Invalid_head_switch + {checkpoint_level = snd checkpoint; given_head = new_head_descr}) + in + (* Check that its predecessor exists and has metadata *) + let predecessor = Block.predecessor new_head in + let* new_head_metadata = + (trace + Bad_head_invariant + (let* pred_block = Block.read_block chain_store predecessor in + (* check that predecessor's block metadata is + available *) + let* _pred_head_metadata = + Block.get_block_metadata chain_store pred_block + in + Block.get_block_metadata chain_store new_head) + [@profiler.record_s "get_pred_block"]) + in + let*! target = Stored_data.get chain_state.target_data in + let new_head_lpbl = + Block.last_preserved_block_level new_head_metadata + in + let* () = + (may_split_context + ~disable_context_pruning:chain_store.disable_context_pruning + chain_store + new_head_lpbl + previous_head [@profiler.record_s "may_split_context"]) + in + let*! cementing_highwatermark = + locked_determine_cementing_highwatermark + chain_store + chain_state + new_head_lpbl + in + (* This write call will initialize the cementing + highwatermark when it is not yet set or do nothing + otherwise. *) + let* () = + locked_may_update_cementing_highwatermark + chain_state + cementing_highwatermark + in + let* lfbl_block_opt = + match chain_state.last_finalized_block_level with + | None -> return_none + | Some lfbl -> + let distance = + Int32.(to_int @@ max 0l (sub (Block.level new_head) lfbl)) + in + Block_store.read_block + chain_store.block_store + ~read_metadata:false + (Block (Block.hash new_head, distance)) + in + let* new_checkpoint, new_target = + match lfbl_block_opt with + | None -> + (* This case may occur when importing a rolling snapshot + where the lfbl block is not known or when a node was + just started. We may use the checkpoint instead. *) + return (checkpoint, target) + | Some lfbl_block -> + may_update_checkpoint_and_target + chain_store + ~new_head:new_head_descr + ~new_head_lfbl:(Block.descriptor lfbl_block) + ~checkpoint + ~target + in + (* [should_merge] is a placeholder acknowledging that a + storage maintenance can be triggered, thanks to several + fulfilled parameters. *) + let should_merge = + (* Make sure that the previous merge is completed before + starting a new merge. If the lock on the chain_state is + retained, the merge thread will never be able to + complete. *) + (not is_merge_ongoing) + && + match cementing_highwatermark with + | None -> + (* Do not merge if the cementing highwatermark is not + set. *) + false + | Some cementing_highwatermark -> + Compare.Int32.(new_head_lpbl > cementing_highwatermark) + in + let* new_cementing_highwatermark = + if should_merge then + (* [trigger_merge] is a placeholder that depends on + [should_merge] and that controls the delayed + maintenance. Thus, even if we [should_merge], + [trigger_merge] may interfere with the actual merge to + delay it. *) + let* trigger_merge = + match chain_store.storage_maintenance.maintenance_delay with + | Disabled -> + (* The storage maintenance delay is off -- merging right now. *) + let* () = + (* Reset scheduled maintenance flag. It could be + necessary if the node was stopped during a + delay and restarted with the delay as + disabled. *) + Stored_data.write + chain_store.storage_maintenance.scheduled_maintenance + None + in + return_true + | Custom delay -> + custom_delayed_maintenance chain_store new_head delay + | Auto -> + auto_delayed_maintenance chain_store chain_state new_head in - Block.get_block_metadata chain_store new_head) - in - let*! target = Stored_data.get chain_state.target_data in - let new_head_lpbl = - Block.last_preserved_block_level new_head_metadata - in - let* () = - Profiler.record_s "may_split_context" @@ fun () -> - may_split_context - ~disable_context_pruning:chain_store.disable_context_pruning - chain_store - new_head_lpbl - previous_head - in - let*! cementing_highwatermark = - locked_determine_cementing_highwatermark - chain_store - chain_state - new_head_lpbl - in - (* This write call will initialize the cementing - highwatermark when it is not yet set or do nothing - otherwise. *) - let* () = - locked_may_update_cementing_highwatermark - chain_state - cementing_highwatermark - in - let* lfbl_block_opt = - match chain_state.last_finalized_block_level with - | None -> return_none - | Some lfbl -> - let distance = - Int32.(to_int @@ max 0l (sub (Block.level new_head) lfbl)) - in - Block_store.read_block - chain_store.block_store - ~read_metadata:false - (Block (Block.hash new_head, distance)) - in - let* new_checkpoint, new_target = - match lfbl_block_opt with - | None -> - (* This case may occur when importing a rolling snapshot - where the lfbl block is not known or when a node was - just started. We may use the checkpoint instead. *) - return (checkpoint, target) - | Some lfbl_block -> - may_update_checkpoint_and_target - chain_store - ~new_head:new_head_descr - ~new_head_lfbl:(Block.descriptor lfbl_block) - ~checkpoint - ~target - in - (* [should_merge] is a placeholder acknowledging that a - storage maintenance can be triggered, thanks to several - fulfilled parameters. *) - let should_merge = - (* Make sure that the previous merge is completed before - starting a new merge. If the lock on the chain_state is - retained, the merge thread will never be able to - complete. *) - (not is_merge_ongoing) - && - match cementing_highwatermark with - | None -> - (* Do not merge if the cementing highwatermark is not - set. *) - false - | Some cementing_highwatermark -> - Compare.Int32.(new_head_lpbl > cementing_highwatermark) - in - let* new_cementing_highwatermark = - if should_merge then - (* [trigger_merge] is a placeholder that depends on - [should_merge] and that controls the delayed - maintenance. Thus, even if we [should_merge], - [trigger_merge] may interfere with the actual merge to - delay it. *) - let* trigger_merge = - match chain_store.storage_maintenance.maintenance_delay with - | Disabled -> - (* The storage maintenance delay is off -- merging right now. *) - let* () = - (* Reset scheduled maintenance flag. It could be - necessary if the node was stopped during a - delay and restarted with the delay as - disabled. *) - Stored_data.write - chain_store.storage_maintenance.scheduled_maintenance - None - in - (* Set the storage maintenance target to -1 to notify that no - target is set. *) - Prometheus.Gauge.set - Store_metrics.metrics.maintenance_target - Float.minus_one ; - return_true - | Custom delay -> - custom_delayed_maintenance chain_store new_head delay - | Auto -> - auto_delayed_maintenance chain_store chain_state new_head - in - (* We effectively trigger the merge only if the delayed - maintenance is disabled or if the targeted delay is - reached. *) - if trigger_merge then - let*! b = try_lock_for_write chain_store.lockfile in - match b with - | false -> - (* Delay the merge until the lock is available *) - return cementing_highwatermark - | true -> - (* Lock on lockfile is now taken *) - let finalizer new_highest_cemented_level = - let* () = - merge_finalizer chain_store new_highest_cemented_level - in - let*! () = may_unlock chain_store.lockfile in - return_unit - in - let on_error errs = - (* Release the lockfile *) - let*! () = may_unlock chain_store.lockfile in - Lwt.return (Error errs) - in - (* Notes: - - The lock will be released when the merge - terminates. i.e. in [finalizer] or in - [on_error]. - - The heavy-work of this function is asynchronously - done so this call is expected to return quickly. *) - let* () = - Profiler.span_s ["start merge store"] @@ fun () -> - Block_store.merge_stores - chain_store.block_store - ~on_error - ~finalizer - ~history_mode:(history_mode chain_store) - ~new_head - ~new_head_metadata - ~cementing_highwatermark: - (WithExceptions.Option.get - ~loc:__LOC__ - cementing_highwatermark) - ~disable_context_pruning: - chain_store.disable_context_pruning - in - (* The new memory highwatermark is new_head_lpbl, the disk - value will be updated after the merge completion. *) - return_some new_head_lpbl - else return cementing_highwatermark - else return cementing_highwatermark - in - let*! new_checkpoint = - match new_cementing_highwatermark with - | None -> Lwt.return new_checkpoint - | Some new_cementing_highwatermark -> ( - if - Compare.Int32.( - snd new_checkpoint >= new_cementing_highwatermark) - then Lwt.return new_checkpoint - else - let*! o = - read_ancestor_hash_by_level - chain_store - new_head - new_cementing_highwatermark - in - match o with - | None -> Lwt.return new_checkpoint - | Some h -> Lwt.return (h, new_cementing_highwatermark)) - in - let* () = - Lwt.finalize - (fun () -> - let*! () = lock_for_write chain_store.stored_data_lockfile in - let* () = - if Compare.Int32.(snd new_checkpoint > snd checkpoint) then - (* Remove potentially outdated invalid blocks if the - checkpoint changed *) - let* () = - Stored_data.update_with - chain_state.invalid_blocks_data - (fun invalid_blocks -> - Lwt.return - (Block_hash.Map.filter - (fun _k {level; _} -> level > snd new_checkpoint) - invalid_blocks)) - in - write_checkpoint chain_state new_checkpoint - else return_unit - in - (* Update values on disk but not the cementing highwatermark - which will be updated by the merge finalizer. *) - let* () = - Profiler.record_s "write_new_head" @@ fun () -> - Stored_data.write chain_state.current_head_data new_head_descr - in - Profiler.record_s "write_new_target" @@ fun () -> - Stored_data.write chain_state.target_data new_target) - (fun () -> unlock chain_store.stored_data_lockfile) - in - (* Update live_data *) - let* live_blocks, live_operations = - Profiler.record_s "updating live blocks" @@ fun () -> - locked_compute_live_blocks - ~update_cache:true - chain_store - chain_state - new_head - new_head_metadata - in - let new_chain_state = - { - chain_state with - live_blocks; - live_operations; - current_head = new_head; - } - in - let*! () = Store_events.(emit set_head) new_head_descr in - return (Some new_chain_state, previous_head)) + (* We effectively trigger the merge only if the delayed + maintenance is disabled or if the targeted delay is + reached. *) + if trigger_merge then + let*! b = try_lock_for_write chain_store.lockfile in + match b with + | false -> + (* Delay the merge until the lock is available *) + return cementing_highwatermark + | true -> + (* Lock on lockfile is now taken *) + let finalizer new_highest_cemented_level = + let* () = + merge_finalizer chain_store new_highest_cemented_level + in + let*! () = may_unlock chain_store.lockfile in + return_unit + in + let on_error errs = + (* Release the lockfile *) + let*! () = may_unlock chain_store.lockfile in + Lwt.return (Error errs) + in + (* Notes: + - The lock will be released when the merge + terminates. i.e. in [finalizer] or in + [on_error]. + - The heavy-work of this function is asynchronously + done so this call is expected to return quickly. *) + let* () = + (Block_store.merge_stores + chain_store.block_store + ~on_error + ~finalizer + ~history_mode:(history_mode chain_store) + ~new_head + ~new_head_metadata + ~cementing_highwatermark: + (WithExceptions.Option.get + ~loc:__LOC__ + cementing_highwatermark) + ~disable_context_pruning: + chain_store.disable_context_pruning + [@profiler.span_s ["start merge store"]]) + in + (* The new memory highwatermark is new_head_lpbl, the disk + value will be updated after the merge completion. *) + return_some new_head_lpbl + else return cementing_highwatermark + else return cementing_highwatermark + in + let*! new_checkpoint = + match new_cementing_highwatermark with + | None -> Lwt.return new_checkpoint + | Some new_cementing_highwatermark -> ( + if + Compare.Int32.( + snd new_checkpoint >= new_cementing_highwatermark) + then Lwt.return new_checkpoint + else + let*! o = + read_ancestor_hash_by_level + chain_store + new_head + new_cementing_highwatermark + in + match o with + | None -> Lwt.return new_checkpoint + | Some h -> Lwt.return (h, new_cementing_highwatermark)) + in + let* () = + Lwt.finalize + (fun () -> + let*! () = lock_for_write chain_store.stored_data_lockfile in + let* () = + if Compare.Int32.(snd new_checkpoint > snd checkpoint) then + (* Remove potentially outdated invalid blocks if the + checkpoint changed *) + let* () = + Stored_data.update_with + chain_state.invalid_blocks_data + (fun invalid_blocks -> + Lwt.return + (Block_hash.Map.filter + (fun _k {level; _} -> level > snd new_checkpoint) + invalid_blocks)) + in + write_checkpoint chain_state new_checkpoint + else return_unit + in + (* Update values on disk but not the cementing highwatermark + which will be updated by the merge finalizer. *) + let* () = + (Stored_data.write + chain_state.current_head_data + new_head_descr [@profiler.record_s "write_new_head"]) + in + (Stored_data.write + chain_state.target_data + new_target [@profiler.record_s "write_new_target"])) + (fun () -> unlock chain_store.stored_data_lockfile) + in + (* Update live_data *) + let* live_blocks, live_operations = + (locked_compute_live_blocks + ~update_cache:true + chain_store + chain_state + new_head + new_head_metadata [@profiler.record_s "updating live blocks"]) + in + let new_chain_state = + { + chain_state with + live_blocks; + live_operations; + current_head = new_head; + } + in + let*! () = Store_events.(emit set_head) new_head_descr in + return (Some new_chain_state, previous_head)) + [@profiler.record_s "set_head"]) let set_target chain_store new_target = let open Lwt_result_syntax in -- GitLab From 9967b1cd2a8f208539be2696ed4c6334a33e92d2 Mon Sep 17 00:00:00 2001 From: Vincent Botbol Date: Tue, 13 Aug 2024 11:45:42 +0200 Subject: [PATCH 07/19] Profiler: plug p2p reader profiler --- src/lib_shell/p2p_reader.ml | 39 +++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index ec52100d7b1f..9372c0c168d2 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -27,6 +27,10 @@ module Message = Distributed_db_message module P2p_reader_event = Distributed_db_event.P2p_reader_event +module Profiler = (val Profiler.wrap Shell_profiling.p2p_reader_profiler) + +let profiler_init = ref false + type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net type connection = @@ -175,6 +179,7 @@ let handle_msg state msg = in match msg with | Get_current_branch chain_id -> + Profiler.span_s ["Get_current_branch"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Branch ; may_handle_global state chain_id @@ fun chain_db -> activate state chain_id chain_db ; @@ -183,6 +188,8 @@ let handle_msg state msg = in let* current_head = Store.Chain.current_head chain_db.chain_store in let* locator = + Profiler.span_s ["Get_current_branch"; "compute_current_branch_locator"] + @@ fun () -> Store.Chain.compute_locator chain_db.chain_store current_head seed in Peer_metadata.update_responses meta Branch @@ -190,6 +197,7 @@ let handle_msg state msg = @@ Current_branch (chain_id, locator) ; Lwt.return_unit | Current_branch (chain_id, locator) -> + Profiler.span_s ["Current_branch"] @@ fun () -> may_handle state chain_id @@ fun chain_db -> let {Block_locator.head_hash; head_header; history} = locator in let* known_invalid = @@ -219,11 +227,13 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_advertisement Branch ; Lwt.return_unit) | Deactivate chain_id -> + Profiler.span_s ["Deactivate"] @@ fun () -> may_handle state chain_id @@ fun chain_db -> deactivate state.gid chain_db ; Chain_id.Table.remove state.peer_active_chains chain_id ; Lwt.return_unit | Get_current_head chain_id -> + Profiler.span_s ["Get_current_head"] @@ fun () -> may_handle state chain_id @@ fun chain_db -> Peer_metadata.incr meta @@ Received_request Head ; let {Connection_metadata.disable_mempool; _} = @@ -241,6 +251,7 @@ let handle_msg state msg = @@ Current_head (chain_id, head, mempool) ; Lwt.return_unit | Current_head (chain_id, header, mempool) -> + Profiler.span_s ["Current_head"] @@ fun () -> may_handle state chain_id @@ fun chain_db -> let header_hash = Block_header.hash header in let* known_invalid = @@ -276,6 +287,7 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_advertisement Head ; Lwt.return_unit) | Get_block_headers hashes -> + Profiler.span_s ["Get_block_headers"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Block_header ; List.iter_p (fun hash -> @@ -291,6 +303,7 @@ let handle_msg state msg = Lwt.return_unit) hashes | Block_header block -> ( + Profiler.span_s ["Block_header"] @@ fun () -> let hash = Block_header.hash block in match find_pending_block_header state hash with | None -> @@ -307,6 +320,9 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Block_header ; Lwt.return_unit) | Get_operations hashes -> + Profiler.span_s + ["Get_operations"; P2p_peer_id.to_short_b58check state.gid] + @@ fun () -> Peer_metadata.incr meta @@ Received_request Operations ; List.iter_p (fun hash -> @@ -323,6 +339,16 @@ let handle_msg state msg = hashes | Operation operation -> ( let hash = Operation.hash operation in + Profiler.span_s + [ + "Operation"; + (match Char.code (Bytes.get operation.proto 0) with + | 0x14 -> "preendorsement" + | 0x15 -> "endorsement" + | _ -> "other"); + P2p_peer_id.to_short_b58check state.gid; + ] + @@ fun () -> match find_pending_operation state hash with | None -> Peer_metadata.incr meta Unexpected_response ; @@ -338,6 +364,7 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations ; Lwt.return_unit) | Get_protocols hashes -> + Profiler.span_s ["Get_protocols"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Protocols ; List.iter_p (fun hash -> @@ -353,6 +380,7 @@ let handle_msg state msg = Lwt.return_unit) hashes | Protocol protocol -> + Profiler.span_s ["Protocol"] @@ fun () -> let hash = Protocol.hash protocol in let* () = Distributed_db_requester.Raw_protocol.notify @@ -364,6 +392,7 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Protocols ; Lwt.return_unit | Get_operations_for_blocks blocks -> + Profiler.span_s ["Get_operations_for_blocks"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Operations_for_block ; List.iter_p (fun (hash, ofs) -> @@ -378,6 +407,7 @@ let handle_msg state msg = Lwt.return_unit) blocks | Operations_for_block (block, ofs, ops, path) -> ( + Profiler.span_s ["Operations_for_block"] @@ fun () -> match find_pending_operations state block ofs with | None -> Peer_metadata.incr meta Unexpected_response ; @@ -393,6 +423,7 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations_for_block ; Lwt.return_unit) | Get_checkpoint chain_id -> ( + Profiler.span_s ["Get_checkpoint"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Checkpoint ; may_handle_global state chain_id @@ fun chain_db -> let* checkpoint_hash, _ = Store.Chain.checkpoint chain_db.chain_store in @@ -408,11 +439,13 @@ let handle_msg state msg = @@ Checkpoint (chain_id, checkpoint_header) ; Lwt.return_unit) | Checkpoint _ -> + Profiler.span_s ["Checkpoint"] @@ fun () -> (* This message is currently unused: it will be used for future bootstrap heuristics. *) Peer_metadata.incr meta @@ Received_response Checkpoint ; Lwt.return_unit | Get_protocol_branch (chain_id, proto_level) -> ( + Profiler.span_s ["Get_protocol_branch"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Protocol_branch ; may_handle_global state chain_id @@ fun chain_db -> activate state chain_id chain_db ; @@ -433,11 +466,13 @@ let handle_msg state msg = Lwt.return_unit | None -> Lwt.return_unit) | Protocol_branch (_chain, _proto_level, _locator) -> + Profiler.span_s ["Protocol_branch"] @@ fun () -> (* This message is currently unused: it will be used for future multipass. *) Peer_metadata.incr meta @@ Received_response Protocol_branch ; Lwt.return_unit | Get_predecessor_header (block_hash, offset) -> ( + Profiler.span_s ["Get_predecessor_header"] @@ fun () -> Peer_metadata.incr meta @@ Received_request Predecessor_header ; let* o = read_predecessor_header state block_hash offset in match o with @@ -452,6 +487,7 @@ let handle_msg state msg = @@ Predecessor_header (block_hash, offset, header) ; Lwt.return_unit) | Predecessor_header (_block_hash, _offset, _header) -> + Profiler.span_s ["Predecessor_header"] @@ fun () -> (* This message is currently unused: it will be used to improve bootstrapping. *) Peer_metadata.incr meta @@ Received_response Predecessor_header ; @@ -474,6 +510,9 @@ let rec worker_loop state = Lwt.return_unit let run ~register ~unregister p2p disk protocol_db active_chains gid conn = + if not !profiler_init then ( + Profiler.record "start" ; + profiler_init := true) ; let canceler = Lwt_canceler.create () in let state = { -- GitLab From f93ae10775293757926fd15abb81f544a5e0eb8a Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Tue, 13 Aug 2024 11:36:59 +0200 Subject: [PATCH 08/19] Lib_shell: p2p_reader.ml - use ppx profiler --- src/lib_shell/p2p_reader.ml | 387 ++++++++++++++++++------------------ 1 file changed, 195 insertions(+), 192 deletions(-) diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index 9372c0c168d2..384006d29c79 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -179,26 +179,28 @@ let handle_msg state msg = in match msg with | Get_current_branch chain_id -> - Profiler.span_s ["Get_current_branch"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Branch ; - may_handle_global state chain_id @@ fun chain_db -> - activate state chain_id chain_db ; - let seed = - {Block_locator.receiver_id = state.gid; sender_id = my_peer_id state} - in - let* current_head = Store.Chain.current_head chain_db.chain_store in - let* locator = - Profiler.span_s ["Get_current_branch"; "compute_current_branch_locator"] - @@ fun () -> - Store.Chain.compute_locator chain_db.chain_store current_head seed - in - Peer_metadata.update_responses meta Branch - @@ P2p.try_send state.p2p state.conn - @@ Current_branch (chain_id, locator) ; - Lwt.return_unit - | Current_branch (chain_id, locator) -> - Profiler.span_s ["Current_branch"] @@ fun () -> - may_handle state chain_id @@ fun chain_db -> + (Peer_metadata.incr meta @@ Received_request Branch ; + may_handle_global state chain_id @@ fun chain_db -> + activate state chain_id chain_db ; + let seed = + {Block_locator.receiver_id = state.gid; sender_id = my_peer_id state} + in + let* current_head = Store.Chain.current_head chain_db.chain_store in + let* locator = + (Store.Chain.compute_locator + chain_db.chain_store + current_head + seed + [@profiler.span_s + ["Get_current_branch"; "compute_current_branch_locator"]]) + in + Peer_metadata.update_responses meta Branch + @@ P2p.try_send state.p2p state.conn + @@ Current_branch (chain_id, locator) ; + Lwt.return_unit) + [@profiler.span_s ["Get_current_branch"]] + | Current_branch (chain_id, locator) -> ( + (may_handle state chain_id @@ fun chain_db -> let {Block_locator.head_hash; head_header; history} = locator in let* known_invalid = List.exists_p @@ -225,16 +227,16 @@ let handle_msg state msg = (* TODO discriminate between received advertisements and responses? *) Peer_metadata.incr meta @@ Received_advertisement Branch ; - Lwt.return_unit) - | Deactivate chain_id -> - Profiler.span_s ["Deactivate"] @@ fun () -> - may_handle state chain_id @@ fun chain_db -> + Lwt.return_unit)) + [@profiler.span_s ["Current_branch"]]) + | Deactivate chain_id -> ( + (may_handle state chain_id @@ fun chain_db -> deactivate state.gid chain_db ; Chain_id.Table.remove state.peer_active_chains chain_id ; - Lwt.return_unit - | Get_current_head chain_id -> - Profiler.span_s ["Get_current_head"] @@ fun () -> - may_handle state chain_id @@ fun chain_db -> + Lwt.return_unit) + [@profiler.span_s ["Deactivate"]]) + | Get_current_head chain_id -> ( + (may_handle state chain_id @@ fun chain_db -> Peer_metadata.incr meta @@ Received_request Head ; let {Connection_metadata.disable_mempool; _} = P2p.connection_remote_metadata state.p2p state.conn @@ -249,10 +251,10 @@ let handle_msg state msg = Peer_metadata.update_responses meta Head @@ P2p.try_send state.p2p state.conn @@ Current_head (chain_id, head, mempool) ; - Lwt.return_unit - | Current_head (chain_id, header, mempool) -> - Profiler.span_s ["Current_head"] @@ fun () -> - may_handle state chain_id @@ fun chain_db -> + Lwt.return_unit) + [@profiler.span_s ["Get_current_head"]]) + | Current_head (chain_id, header, mempool) -> ( + (may_handle state chain_id @@ fun chain_db -> let header_hash = Block_header.hash header in let* known_invalid = Store.Block.is_known_invalid chain_db.chain_store header_hash @@ -285,71 +287,71 @@ let handle_msg state msg = (* TODO discriminate between received advertisements and responses? *) Peer_metadata.incr meta @@ Received_advertisement Head ; - Lwt.return_unit) + Lwt.return_unit)) + [@profiler.span_s ["Current_head"]]) | Get_block_headers hashes -> - Profiler.span_s ["Get_block_headers"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Block_header ; - List.iter_p - (fun hash -> - let* o = read_block_header state hash in - match o with - | None -> - Peer_metadata.incr meta @@ Unadvertised Block ; - Lwt.return_unit - | Some (_chain_id, header) -> - Peer_metadata.update_responses meta Block_header - @@ P2p.try_send state.p2p state.conn - @@ Block_header header ; - Lwt.return_unit) - hashes + (Peer_metadata.incr meta @@ Received_request Block_header ; + List.iter_p + (fun hash -> + let* o = read_block_header state hash in + match o with + | None -> + Peer_metadata.incr meta @@ Unadvertised Block ; + Lwt.return_unit + | Some (_chain_id, header) -> + Peer_metadata.update_responses meta Block_header + @@ P2p.try_send state.p2p state.conn + @@ Block_header header ; + Lwt.return_unit) + hashes) + [@profiler.span_s ["Get_block_headers"]] | Block_header block -> ( - Profiler.span_s ["Block_header"] @@ fun () -> - let hash = Block_header.hash block in - match find_pending_block_header state hash with - | None -> - Peer_metadata.incr meta Unexpected_response ; - Lwt.return_unit - | Some chain_db -> - let* () = - Distributed_db_requester.Raw_block_header.notify - chain_db.block_header_db - state.gid - hash - block - in - Peer_metadata.incr meta @@ Received_response Block_header ; - Lwt.return_unit) + (let hash = Block_header.hash block in + match find_pending_block_header state hash with + | None -> + Peer_metadata.incr meta Unexpected_response ; + Lwt.return_unit + | Some chain_db -> + let* () = + Distributed_db_requester.Raw_block_header.notify + chain_db.block_header_db + state.gid + hash + block + in + Peer_metadata.incr meta @@ Received_response Block_header ; + Lwt.return_unit) + [@profiler.span_s ["Block_header"]]) | Get_operations hashes -> - Profiler.span_s - ["Get_operations"; P2p_peer_id.to_short_b58check state.gid] - @@ fun () -> - Peer_metadata.incr meta @@ Received_request Operations ; - List.iter_p - (fun hash -> - let* o = read_operation state hash in - match o with - | None -> - Peer_metadata.incr meta @@ Unadvertised Operations ; - Lwt.return_unit - | Some (_chain_id, op) -> - Peer_metadata.update_responses meta Operations - @@ P2p.try_send state.p2p state.conn - @@ Operation op ; - Lwt.return_unit) - hashes + (Peer_metadata.incr meta @@ Received_request Operations ; + List.iter_p + (fun hash -> + let* o = read_operation state hash in + match o with + | None -> + Peer_metadata.incr meta @@ Unadvertised Operations ; + Lwt.return_unit + | Some (_chain_id, op) -> + Peer_metadata.update_responses meta Operations + @@ P2p.try_send state.p2p state.conn + @@ Operation op ; + Lwt.return_unit) + hashes) + [@profiler.span_s + ["Get_operations"; P2p_peer_id.to_short_b58check state.gid]] | Operation operation -> ( let hash = Operation.hash operation in - Profiler.span_s - [ - "Operation"; - (match Char.code (Bytes.get operation.proto 0) with - | 0x14 -> "preendorsement" - | 0x15 -> "endorsement" - | _ -> "other"); - P2p_peer_id.to_short_b58check state.gid; - ] - @@ fun () -> - match find_pending_operation state hash with + match[@profiler.span_s + [ + "Operation"; + (match Char.code (Bytes.get operation.proto 0) with + | 0x14 -> "preendorsement" + | 0x15 -> "endorsement" + | _ -> "other"); + P2p_peer_id.to_short_b58check state.gid; + ]] + find_pending_operation state hash + with | None -> Peer_metadata.incr meta Unexpected_response ; Lwt.return_unit @@ -364,51 +366,52 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations ; Lwt.return_unit) | Get_protocols hashes -> - Profiler.span_s ["Get_protocols"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Protocols ; - List.iter_p - (fun hash -> - let* o = Store.Protocol.read state.disk hash in - match o with - | None -> - Peer_metadata.incr meta @@ Unadvertised Protocol ; - Lwt.return_unit - | Some p -> - Peer_metadata.update_responses meta Protocols - @@ P2p.try_send state.p2p state.conn - @@ Protocol p ; - Lwt.return_unit) - hashes + (Peer_metadata.incr meta @@ Received_request Protocols ; + List.iter_p + (fun hash -> + let* o = Store.Protocol.read state.disk hash in + match o with + | None -> + Peer_metadata.incr meta @@ Unadvertised Protocol ; + Lwt.return_unit + | Some p -> + Peer_metadata.update_responses meta Protocols + @@ P2p.try_send state.p2p state.conn + @@ Protocol p ; + Lwt.return_unit) + hashes) + [@profiler.span_s ["Get_protocols"]] | Protocol protocol -> - Profiler.span_s ["Protocol"] @@ fun () -> - let hash = Protocol.hash protocol in - let* () = - Distributed_db_requester.Raw_protocol.notify - state.protocol_db - state.gid - hash - protocol - in - Peer_metadata.incr meta @@ Received_response Protocols ; - Lwt.return_unit + (let hash = Protocol.hash protocol in + let* () = + Distributed_db_requester.Raw_protocol.notify + state.protocol_db + state.gid + hash + protocol + in + Peer_metadata.incr meta @@ Received_response Protocols ; + Lwt.return_unit) + [@profiler.span_s ["Protocol"]] | Get_operations_for_blocks blocks -> - Profiler.span_s ["Get_operations_for_blocks"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Operations_for_block ; - List.iter_p - (fun (hash, ofs) -> - let* o = read_block state hash in - match o with - | None -> Lwt.return_unit - | Some (_, block) -> - let ops, path = Store.Block.operations_path block ofs in - Peer_metadata.update_responses meta Operations_for_block - @@ P2p.try_send state.p2p state.conn - @@ Operations_for_block (hash, ofs, ops, path) ; - Lwt.return_unit) - blocks + (Peer_metadata.incr meta @@ Received_request Operations_for_block ; + List.iter_p + (fun (hash, ofs) -> + let* o = read_block state hash in + match o with + | None -> Lwt.return_unit + | Some (_, block) -> + let ops, path = Store.Block.operations_path block ofs in + Peer_metadata.update_responses meta Operations_for_block + @@ P2p.try_send state.p2p state.conn + @@ Operations_for_block (hash, ofs, ops, path) ; + Lwt.return_unit) + blocks) + [@profiler.span_s ["Get_operations_for_blocks"]] | Operations_for_block (block, ofs, ops, path) -> ( - Profiler.span_s ["Operations_for_block"] @@ fun () -> - match find_pending_operations state block ofs with + match[@profiler.span_s ["Operations_for_block"]] + find_pending_operations state block ofs + with | None -> Peer_metadata.incr meta Unexpected_response ; Lwt.return_unit @@ -423,75 +426,75 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations_for_block ; Lwt.return_unit) | Get_checkpoint chain_id -> ( - Profiler.span_s ["Get_checkpoint"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Checkpoint ; - may_handle_global state chain_id @@ fun chain_db -> - let* checkpoint_hash, _ = Store.Chain.checkpoint chain_db.chain_store in - let* o = - Store.Block.read_block_opt chain_db.chain_store checkpoint_hash - in - match o with - | None -> Lwt.return_unit - | Some checkpoint -> - let checkpoint_header = Store.Block.header checkpoint in - Peer_metadata.update_responses meta Checkpoint - @@ P2p.try_send state.p2p state.conn - @@ Checkpoint (chain_id, checkpoint_header) ; - Lwt.return_unit) + (Peer_metadata.incr meta @@ Received_request Checkpoint ; + may_handle_global state chain_id @@ fun chain_db -> + let* checkpoint_hash, _ = Store.Chain.checkpoint chain_db.chain_store in + let* o = + Store.Block.read_block_opt chain_db.chain_store checkpoint_hash + in + match o with + | None -> Lwt.return_unit + | Some checkpoint -> + let checkpoint_header = Store.Block.header checkpoint in + Peer_metadata.update_responses meta Checkpoint + @@ P2p.try_send state.p2p state.conn + @@ Checkpoint (chain_id, checkpoint_header) ; + Lwt.return_unit) + [@profiler.span_s ["Get_checkpoint"]]) | Checkpoint _ -> - Profiler.span_s ["Checkpoint"] @@ fun () -> (* This message is currently unused: it will be used for future bootstrap heuristics. *) - Peer_metadata.incr meta @@ Received_response Checkpoint ; - Lwt.return_unit + (Peer_metadata.incr meta @@ Received_response Checkpoint ; + Lwt.return_unit) + [@profiler.span_s ["Checkpoint"]] | Get_protocol_branch (chain_id, proto_level) -> ( - Profiler.span_s ["Get_protocol_branch"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Protocol_branch ; - may_handle_global state chain_id @@ fun chain_db -> - activate state chain_id chain_db ; - let seed = - {Block_locator.receiver_id = state.gid; sender_id = my_peer_id state} - in - let* o = - Store.Chain.compute_protocol_locator - chain_db.chain_store - ~proto_level - seed - in - match o with - | Some locator -> - Peer_metadata.update_responses meta Protocol_branch - @@ P2p.try_send state.p2p state.conn - @@ Protocol_branch (chain_id, proto_level, locator) ; - Lwt.return_unit - | None -> Lwt.return_unit) + (Peer_metadata.incr meta @@ Received_request Protocol_branch ; + may_handle_global state chain_id @@ fun chain_db -> + activate state chain_id chain_db ; + let seed = + {Block_locator.receiver_id = state.gid; sender_id = my_peer_id state} + in + let* o = + Store.Chain.compute_protocol_locator + chain_db.chain_store + ~proto_level + seed + in + match o with + | Some locator -> + Peer_metadata.update_responses meta Protocol_branch + @@ P2p.try_send state.p2p state.conn + @@ Protocol_branch (chain_id, proto_level, locator) ; + Lwt.return_unit + | None -> Lwt.return_unit) + [@profiler.span_s ["Get_protocol_branch"]]) | Protocol_branch (_chain, _proto_level, _locator) -> - Profiler.span_s ["Protocol_branch"] @@ fun () -> (* This message is currently unused: it will be used for future multipass. *) - Peer_metadata.incr meta @@ Received_response Protocol_branch ; - Lwt.return_unit + (Peer_metadata.incr meta @@ Received_response Protocol_branch ; + Lwt.return_unit) + [@profiler.span_s ["Protocol_branch"]] | Get_predecessor_header (block_hash, offset) -> ( - Profiler.span_s ["Get_predecessor_header"] @@ fun () -> - Peer_metadata.incr meta @@ Received_request Predecessor_header ; - let* o = read_predecessor_header state block_hash offset in - match o with - | None -> - (* The peer is not expected to request blocks that are beyond - our locator. *) - Peer_metadata.incr meta @@ Unadvertised Block ; - Lwt.return_unit - | Some header -> - Peer_metadata.update_responses meta Predecessor_header - @@ P2p.try_send state.p2p state.conn - @@ Predecessor_header (block_hash, offset, header) ; - Lwt.return_unit) + (Peer_metadata.incr meta @@ Received_request Predecessor_header ; + let* o = read_predecessor_header state block_hash offset in + match o with + | None -> + (* The peer is not expected to request blocks that are beyond + our locator. *) + Peer_metadata.incr meta @@ Unadvertised Block ; + Lwt.return_unit + | Some header -> + Peer_metadata.update_responses meta Predecessor_header + @@ P2p.try_send state.p2p state.conn + @@ Predecessor_header (block_hash, offset, header) ; + Lwt.return_unit) + [@profiler.span_s ["Get_predecessor_header"]]) | Predecessor_header (_block_hash, _offset, _header) -> - Profiler.span_s ["Predecessor_header"] @@ fun () -> (* This message is currently unused: it will be used to improve bootstrapping. *) - Peer_metadata.incr meta @@ Received_response Predecessor_header ; - Lwt.return_unit + (Peer_metadata.incr meta @@ Received_response Predecessor_header ; + Lwt.return_unit) + [@profiler.span_s ["Predecessor_header"]] let rec worker_loop state = let open Lwt_syntax in -- GitLab From 9b0dd0821c54b959caa973c4f309940d1a19fe03 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:34:53 +0200 Subject: [PATCH 09/19] Profiler: plug chain validator profiler --- src/lib_shell/chain_validator.ml | 10 ++++++++++ src/lib_shell/peer_validator.ml | 24 ++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 6f70134e361b..8935dd48eb3f 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -487,6 +487,10 @@ let reset_profilers block = let on_validation_request w peer start_testchain active_chains spawn_child block = let open Lwt_result_syntax in + Profiler.span_s + Shell_profiling.chain_validator_profiler + ["chain_validator"; "validation request (set_head)"] + @@ fun () -> let*! () = Option.iter_s (update_synchronisation_state w (Store.Block.header block)) @@ -541,6 +545,9 @@ let on_notify_branch w peer_id locator = let* () = check_and_update_synchronisation_state w (head_hash, head_header) peer_id in + Profiler.mark + Shell_profiling.chain_validator_profiler + ["chain_validator"; "notify branch received"] ; with_activated_peer_validator w peer_id (fun pv -> Peer_validator.notify_branch pv locator ; return_ok_unit) @@ -548,6 +555,9 @@ let on_notify_branch w peer_id locator = let on_notify_head w peer_id (block_hash, header) mempool = let open Lwt_syntax in let nv = Worker.state w in + Profiler.mark + Shell_profiling.chain_validator_profiler + ["chain_validator"; "notify head received"] ; let* () = check_and_update_synchronisation_state w (block_hash, header) peer_id in diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index ff88ba53d648..19295156d1b1 100644 --- a/src/lib_shell/peer_validator.ml +++ b/src/lib_shell/peer_validator.ml @@ -28,6 +28,8 @@ open Peer_validator_worker_state +module Profiler = (val Profiler.wrap Shell_profiling.chain_validator_profiler) + module Name = struct type t = Chain_id.t * P2p_peer.Id.t @@ -158,8 +160,15 @@ let validate_new_head w hash (header : Block_header.t) = let open Lwt_result_syntax in let pv = Worker.state w in let block_received = (pv.peer_id, hash) in + let sym_prefix l = + "peer_validator" + :: Block_hash.to_short_b58check hash + :: "validate new head" :: l + in let*! () = Events.(emit fetching_operations_for_head) block_received in + Profiler.span_s (sym_prefix ["validate new head"]) @@ fun () -> let* operations = + Profiler.span_s (sym_prefix ["operation fetching"]) @@ fun () -> List.map_ep (fun i -> protect ~canceler:(Worker.canceler w) (fun () -> @@ -187,6 +196,7 @@ let validate_new_head w hash (header : Block_header.t) = | `Ok -> ( let*! () = Events.(emit requesting_new_head_validation) block_received in let*! v = + Profiler.span_s (sym_prefix ["validate"]) @@ fun () -> Block_validator.validate_and_apply ~notify_new_block:pv.parameters.notify_new_block ~advertise_after_validation:true @@ -230,6 +240,12 @@ let assert_acceptable_head w hash (header : Block_header.t) = let may_validate_new_head w hash (header : Block_header.t) = let open Lwt_result_syntax in + Profiler.mark + [ + "peer_validator"; + Block_hash.to_short_b58check hash; + "may validate new head"; + ] ; let pv = Worker.state w in let chain_store = Distributed_db.chain_store pv.parameters.chain_db in let*! valid_block = Store.Block.is_known_valid chain_store hash in @@ -267,6 +283,14 @@ let may_validate_new_head w hash (header : Block_header.t) = only_if_fitness_increases w header hash @@ function | `Known_valid | `Lower_fitness -> return_unit | `Ok -> + Profiler.mark + [ + "peer_validator"; + Block_hash.to_short_b58check hash; + "may validate new head"; + "validate new head"; + ] ; + let* () = assert_acceptable_head w hash header in validate_new_head w hash header -- GitLab From e7a27320357f674f62b53cf87a64d9e7b19beeea Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Tue, 13 Aug 2024 15:11:12 +0200 Subject: [PATCH 10/19] Lib_shell: peer/chain_validator.ml - use ppx profiler --- src/lib_shell/chain_validator.ml | 119 ++++++++++++------------ src/lib_shell/peer_validator.ml | 151 ++++++++++++++++--------------- 2 files changed, 140 insertions(+), 130 deletions(-) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 8935dd48eb3f..1ddedd46116d 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -38,6 +38,10 @@ module Name = struct let equal = Chain_id.equal end +module Profiler = struct + include (val Profiler.wrap Shell_profiling.chain_validator_profiler) +end + module Request = struct include Request @@ -333,7 +337,9 @@ let instantiate_prevalidator parameters set_prevalidator block chain_db = ~block_hash:(Store.Block.hash block) new_protocol_hash in - let instances = Profiler.plugged Shell_profiling.mempool_profiler in + let instances = + Tezos_base.Profiler.plugged Shell_profiling.mempool_profiler + in List.iter Tezos_protocol_environment.Environment_profiler.plug instances ; Prevalidator.create parameters.prevalidator_limits proto chain_db in @@ -487,57 +493,56 @@ let reset_profilers block = let on_validation_request w peer start_testchain active_chains spawn_child block = let open Lwt_result_syntax in - Profiler.span_s - Shell_profiling.chain_validator_profiler - ["chain_validator"; "validation request (set_head)"] - @@ fun () -> - let*! () = - Option.iter_s - (update_synchronisation_state w (Store.Block.header block)) - peer - in - let nv = Worker.state w in - let chain_store = nv.parameters.chain_store in - let*! head = Store.Chain.current_head chain_store in - let head_header = Store.Block.header head - and head_hash = Store.Block.hash head - and block_header = Store.Block.header block in - let head_fitness = head_header.shell.fitness in - let new_fitness = block_header.shell.fitness in - let accepted_head = Fitness.(new_fitness > head_fitness) in - if not accepted_head then return Ignored_head - else - let* previous = Store.Chain.set_head chain_store block in - reset_profilers block ; - let () = - if is_bootstrapped nv then - Distributed_db.Advertise.current_head nv.chain_db block - in - let*! () = - if start_testchain then - may_switch_test_chain w active_chains spawn_child chain_store block - else Lwt.return_unit - in - Lwt_watcher.notify nv.new_head_input (Store.Block.hash block, block_header) ; - let is_head_increment = - Block_hash.equal head_hash block_header.shell.predecessor - in - let event = if is_head_increment then Head_increment else Branch_switch in - let* () = - when_ (not is_head_increment) (fun () -> - Store.Chain.may_update_ancestor_protocol_level chain_store ~head:block) - in - let*! () = may_synchronise_context nv.synchronisation_state chain_store in - let* () = - may_flush_or_update_prevalidator - nv.parameters - event - nv.prevalidator - nv.chain_db - ~prev:previous - ~block - in - return event + (let*! () = + Option.iter_s + (update_synchronisation_state w (Store.Block.header block)) + peer + in + let nv = Worker.state w in + let chain_store = nv.parameters.chain_store in + let*! head = Store.Chain.current_head chain_store in + let head_header = Store.Block.header head + and head_hash = Store.Block.hash head + and block_header = Store.Block.header block in + let head_fitness = head_header.shell.fitness in + let new_fitness = block_header.shell.fitness in + let accepted_head = Fitness.(new_fitness > head_fitness) in + if not accepted_head then return Ignored_head + else + let* previous = Store.Chain.set_head chain_store block in + reset_profilers block ; + let () = + if is_bootstrapped nv then + Distributed_db.Advertise.current_head nv.chain_db block + in + let*! () = + if start_testchain then + may_switch_test_chain w active_chains spawn_child chain_store block + else Lwt.return_unit + in + Lwt_watcher.notify nv.new_head_input (Store.Block.hash block, block_header) ; + let is_head_increment = + Block_hash.equal head_hash block_header.shell.predecessor + in + let event = if is_head_increment then Head_increment else Branch_switch in + let* () = + when_ (not is_head_increment) (fun () -> + Store.Chain.may_update_ancestor_protocol_level + chain_store + ~head:block) + in + let*! () = may_synchronise_context nv.synchronisation_state chain_store in + let* () = + may_flush_or_update_prevalidator + nv.parameters + event + nv.prevalidator + nv.chain_db + ~prev:previous + ~block + in + return event) + [@profiler.span_s ["chain_validator"; "validation request (set_head)"]] let on_notify_branch w peer_id locator = let open Lwt_syntax in @@ -545,9 +550,9 @@ let on_notify_branch w peer_id locator = let* () = check_and_update_synchronisation_state w (head_hash, head_header) peer_id in - Profiler.mark - Shell_profiling.chain_validator_profiler - ["chain_validator"; "notify branch received"] ; + let () = + (() [@profiler.mark ["chain_validator"; "notify branch received"]]) + in with_activated_peer_validator w peer_id (fun pv -> Peer_validator.notify_branch pv locator ; return_ok_unit) @@ -555,9 +560,7 @@ let on_notify_branch w peer_id locator = let on_notify_head w peer_id (block_hash, header) mempool = let open Lwt_syntax in let nv = Worker.state w in - Profiler.mark - Shell_profiling.chain_validator_profiler - ["chain_validator"; "notify head received"] ; + () [@profiler.mark ["chain_validator"; "notify head received"]] ; let* () = check_and_update_synchronisation_state w (block_hash, header) peer_id in diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index 19295156d1b1..bcaefcd85848 100644 --- a/src/lib_shell/peer_validator.ml +++ b/src/lib_shell/peer_validator.ml @@ -160,72 +160,73 @@ let validate_new_head w hash (header : Block_header.t) = let open Lwt_result_syntax in let pv = Worker.state w in let block_received = (pv.peer_id, hash) in - let sym_prefix l = + let[@warning "-26"] sym_prefix l = "peer_validator" :: Block_hash.to_short_b58check hash :: "validate new head" :: l in let*! () = Events.(emit fetching_operations_for_head) block_received in - Profiler.span_s (sym_prefix ["validate new head"]) @@ fun () -> - let* operations = - Profiler.span_s (sym_prefix ["operation fetching"]) @@ fun () -> - List.map_ep - (fun i -> - protect ~canceler:(Worker.canceler w) (fun () -> - Distributed_db.Operations.fetch - ~timeout:pv.parameters.limits.block_operations_timeout - pv.parameters.chain_db - ~peer:pv.peer_id - (hash, i) - header.shell.operations_hash)) - (0 -- (header.shell.validation_passes - 1)) - in - (* We redo a check for the fitness here because while waiting for the - operations, a new head better than this block might be validated. *) - only_if_fitness_increases w header hash @@ function - | `Known_valid | `Lower_fitness -> - (* If the block is known valid or if the fitness does not increase - we need to clear the fetched operation of the block from the ddb *) - List.iter + (let* operations = + (List.map_ep (fun i -> - Distributed_db.Operations.clear_or_cancel + protect ~canceler:(Worker.canceler w) (fun () -> + Distributed_db.Operations.fetch + ~timeout:pv.parameters.limits.block_operations_timeout + pv.parameters.chain_db + ~peer:pv.peer_id + (hash, i) + header.shell.operations_hash)) + (0 -- (header.shell.validation_passes - 1)) + [@profiler.span_s sym_prefix ["operation fetching"]]) + in + (* We redo a check for the fitness here because while waiting for the + operations, a new head better than this block might be validated. *) + only_if_fitness_increases w header hash @@ function + | `Known_valid | `Lower_fitness -> + (* If the block is known valid or if the fitness does not increase + we need to clear the fetched operation of the block from the ddb *) + List.iter + (fun i -> + Distributed_db.Operations.clear_or_cancel + pv.parameters.chain_db + (hash, i)) + (0 -- (header.shell.validation_passes - 1)) ; + return_unit + | `Ok -> ( + let*! () = Events.(emit requesting_new_head_validation) block_received in + let*! v = + (Block_validator.validate_and_apply + ~notify_new_block:pv.parameters.notify_new_block + ~advertise_after_validation:true + pv.parameters.block_validator pv.parameters.chain_db - (hash, i)) - (0 -- (header.shell.validation_passes - 1)) ; - return_unit - | `Ok -> ( - let*! () = Events.(emit requesting_new_head_validation) block_received in - let*! v = - Profiler.span_s (sym_prefix ["validate"]) @@ fun () -> - Block_validator.validate_and_apply - ~notify_new_block:pv.parameters.notify_new_block - ~advertise_after_validation:true - pv.parameters.block_validator - pv.parameters.chain_db - hash - header - operations - in - match v with - | Invalid errs -> - (* This will convert into a kickban when treated by [on_error] -- - or, at least, by a worker termination which will close the - connection. *) - Lwt.return_error errs - | Inapplicable_after_validation _errs -> - let*! () = Events.(emit ignoring_inapplicable_block) block_received in - (* We do not kickban the peer if the block received was - successfully validated but inapplicable -- this means that he - could have propagated a validated block before terminating - its application *) - return_unit - | Valid -> - let*! () = Events.(emit new_head_validation_end) block_received in - let meta = - Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id - in - Peer_metadata.incr meta Valid_blocks ; - return_unit) + hash + header + operations [@profiler.span_s sym_prefix ["validate"]]) + in + match v with + | Invalid errs -> + (* This will convert into a kickban when treated by [on_error] -- + or, at least, by a worker termination which will close the + connection. *) + Lwt.return_error errs + | Inapplicable_after_validation _errs -> + let*! () = + Events.(emit ignoring_inapplicable_block) block_received + in + (* We do not kickban the peer if the block received was + successfully validated but inapplicable -- this means that he + could have propagated a validated block before terminating + its application *) + return_unit + | Valid -> + let*! () = Events.(emit new_head_validation_end) block_received in + let meta = + Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id + in + Peer_metadata.incr meta Valid_blocks ; + return_unit)) + [@profiler.span_s sym_prefix ["validate new head"]] let assert_acceptable_head w hash (header : Block_header.t) = let open Lwt_result_syntax in @@ -240,12 +241,15 @@ let assert_acceptable_head w hash (header : Block_header.t) = let may_validate_new_head w hash (header : Block_header.t) = let open Lwt_result_syntax in - Profiler.mark - [ - "peer_validator"; - Block_hash.to_short_b58check hash; - "may validate new head"; - ] ; + let () = + (() + [@profiler.mark + [ + "peer_validator"; + Block_hash.to_short_b58check hash; + "may validate new head"; + ]]) + in let pv = Worker.state w in let chain_store = Distributed_db.chain_store pv.parameters.chain_db in let*! valid_block = Store.Block.is_known_valid chain_store hash in @@ -283,13 +287,16 @@ let may_validate_new_head w hash (header : Block_header.t) = only_if_fitness_increases w header hash @@ function | `Known_valid | `Lower_fitness -> return_unit | `Ok -> - Profiler.mark - [ - "peer_validator"; - Block_hash.to_short_b58check hash; - "may validate new head"; - "validate new head"; - ] ; + let () = + (() + [@profiler.mark + [ + "peer_validator"; + Block_hash.to_short_b58check hash; + "may validate new head"; + "validate new head"; + ]]) + in let* () = assert_acceptable_head w hash header in validate_new_head w hash header -- GitLab From e68c958d0d5e01a0e829d5e344c8d22c07144be6 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 26 Jul 2023 14:41:47 +0200 Subject: [PATCH 11/19] Profiler: plug block validator profiler --- src/bin_node/node_replay_command.ml | 7 ++-- src/lib_shell/block_validator.ml | 18 +++++++++- src/lib_shell/block_validator_process.ml | 46 ++++++++++++++---------- src/lib_validation/block_validation.ml | 42 +++++++++++++++++----- src/lib_validation/external_validator.ml | 6 +++- 5 files changed, 89 insertions(+), 30 deletions(-) diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index 459413942c7c..eadfeb2a990f 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -428,8 +428,11 @@ let replay ~internal_events ~singleprocess ~strict process_path = Sys.executable_name; }) in - let commit_genesis = - Block_validator_process.commit_genesis validator_process + let commit_genesis ~chain_id = + let* res = + Block_validator_process.commit_genesis validator_process ~chain_id + in + return res in let* store = Store.init diff --git a/src/lib_shell/block_validator.ml b/src/lib_shell/block_validator.ml index 583f449470d0..27556efe2c42 100644 --- a/src/lib_shell/block_validator.ml +++ b/src/lib_shell/block_validator.ml @@ -28,6 +28,14 @@ open Block_validator_worker_state open Block_validator_errors +module Profiler = struct + include (val Profiler.wrap Shell_profiling.block_validator_profiler) + + let reset_block_section = + Shell_profiling.create_reset_block_section + Shell_profiling.block_validator_profiler +end + type validation_result = | Already_committed | Already_known_invalid of error trace @@ -149,6 +157,7 @@ let check_chain_liveness chain_db hash (header : Block_header.t) = let check_operations_merkle_root hash header operations = let open Result_syntax in + Profiler.span_f ["checks"; "merkle_root"] @@ fun () -> let fail_unless b e = if b then return_unit else tzfail e in let computed_hash = let hashes = List.map (List.map Operation.hash) operations in @@ -324,11 +333,14 @@ let on_validation_request w advertise_after_validation; } = let open Lwt_result_syntax in + Profiler.reset_block_section hash ; let bv = Worker.state w in let chain_store = Distributed_db.chain_store chain_db in let*! b = Store.Block.is_known_valid chain_store hash in match b with - | true -> return Already_committed + | true -> + Profiler.mark ["checks"; "already_commited"] ; + return Already_committed | false -> ( (* This check might be redundant as operation paths are already checked when each pass is received from the network. However, @@ -349,6 +361,7 @@ let on_validation_request w | Some {errors; _} -> return (Already_known_invalid errors) | None -> ( let* pred = + Profiler.record_s "read_predecessor" @@ fun () -> Store.Block.read_block chain_store header.shell.predecessor in let*! mempool = Store.Chain.mempool chain_store in @@ -420,6 +433,7 @@ let on_validation_request w List.map (fun v -> Int.to_float (List.length v)) operations) ; + Profiler.record_s "commit_block" @@ fun () -> commit_and_notify_block notify_new_block chain_db @@ -654,6 +668,7 @@ let validate_and_apply w ?canceler ?peer ?(notify_new_block = fun _ -> ()) ~advertise_after_validation chain_db hash (header : Block_header.t) operations = let open Lwt_syntax in + Profiler.reset_block_section hash ; let chain_store = Distributed_db.chain_store chain_db in let* b = Store.Block.is_known_valid chain_store hash in match b with @@ -664,6 +679,7 @@ let validate_and_apply w ?canceler ?peer ?(notify_new_block = fun _ -> ()) let* r = let open Lwt_result_syntax in let* () = + Profiler.span_s ["checks"; "chain_liveness"] @@ fun () -> check_chain_liveness chain_db hash header |> Lwt_result.map_error (fun e -> Worker.Request_error e) in diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index 154c14c165a8..d6c7eff8eeba 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -405,43 +405,53 @@ module Internal_validator_process = struct `Inherited (block_cache, predecessor_resulting_context_hash) in let predecessor_block_hash = Store.Block.hash predecessor in - Block_validation.validate - ~chain_id - ~predecessor_block_header - ~predecessor_block_hash - ~predecessor_context - ~predecessor_resulting_context_hash - ~cache - header - operations + let* res = + Block_validation.validate + ~chain_id + ~predecessor_block_header + ~predecessor_block_hash + ~predecessor_context + ~predecessor_resulting_context_hash + ~cache + header + operations + in + return res let context_garbage_collection _validator context_index context_hash ~gc_lockfile_path:_ = let open Lwt_result_syntax in let*! () = Context_ops.gc context_index context_hash in - return_unit + return () let context_split _validator context_index = let open Lwt_result_syntax in let*! () = Context_ops.split context_index in - return_unit + return () let commit_genesis validator ~chain_id = + let open Lwt_result_syntax in let context_index = get_context_index validator.chain_store in let genesis = Store.Chain.genesis validator.chain_store in - Context_ops.commit_genesis - context_index - ~chain_id - ~time:genesis.time - ~protocol:genesis.protocol + let* res = + Context_ops.commit_genesis + context_index + ~chain_id + ~time:genesis.time + ~protocol:genesis.protocol + in + return res let init_test_chain validator chain_id forking_block = let open Lwt_result_syntax in let forked_header = Store.Block.header forking_block in let* context = Store.Block.context validator.chain_store forking_block in - Block_validation.init_test_chain chain_id context forked_header + let* res = + Block_validation.init_test_chain chain_id context forked_header + in + return res - let reconfigure_event_logging _ _ = Lwt_result_syntax.return_unit + let reconfigure_event_logging _ _ = Lwt_result_syntax.return () end (** Block validation using an external process *) diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 6e7880c6094c..c0ca1625554c 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -609,6 +609,7 @@ module Make (Proto : Protocol_plugin.T) = struct trace (invalid_block block_hash Economic_protocol_error) (let* state = + Tezos_base.Profiler.(record_s main) "begin_application" @@ fun () -> (Proto.begin_application context chain_id @@ -617,13 +618,20 @@ module Make (Proto : Protocol_plugin.T) = struct ~cache [@time.duration_lwt application_beginning]) in let* state, ops_metadata = - (List.fold_left_es - (fun (state, acc) ops -> + Tezos_base.Profiler.(record_s main) "apply_operations" @@ fun () -> + (List.fold_left_i_es + (fun i (state, acc) ops -> + let sec = "operation_list(" ^ string_of_int i ^ ")" in + Tezos_base.Profiler.(record_s main) sec @@ fun () -> let* state, ops_metadata = List.fold_left_es (fun (state, acc) (oph, op, _check_signature) -> let* state, op_metadata = - Proto.apply_operation state oph op + let sec = + "operation(" ^ Operation_hash.to_b58check oph ^ ")" + in + Tezos_base.Profiler.(record_s ~lod:Detailed main) sec + @@ fun () -> Proto.apply_operation state oph op in return (state, op_metadata :: acc)) (state, []) @@ -635,6 +643,7 @@ module Make (Proto : Protocol_plugin.T) = struct in let ops_metadata = List.rev ops_metadata in let* validation_result, block_data = + Tezos_base.Profiler.(record_s main) "finalize_application" @@ fun () -> (Proto.finalize_application state (Some block_header.shell) [@time.duration_lwt block_finalization]) @@ -723,11 +732,13 @@ module Make (Proto : Protocol_plugin.T) = struct let* () = check_operation_quota block_hash operations in let predecessor_hash = Block_header.hash predecessor_block_header in let* operations = + Tezos_base.Profiler.(record_s main) "parse_operations" @@ fun () -> (parse_operations block_hash operations [@time.duration_lwt operations_parsing]) in let* context = + Tezos_base.Profiler.(record_s main) "prepare_context" @@ fun () -> prepare_context predecessor_block_metadata_hash predecessor_ops_metadata_hash @@ -745,6 +756,7 @@ module Make (Proto : Protocol_plugin.T) = struct block_hash operations in + Tezos_base.Profiler.(record_s main) "post_validation" @@ fun () -> let*! validation_result = may_patch_protocol ~user_activated_upgrades @@ -783,6 +795,7 @@ module Make (Proto : Protocol_plugin.T) = struct in let* validation_result, new_protocol_env_version, expected_context_hash = + Tezos_base.Profiler.(record_s main) "record_protocol" @@ fun () -> may_init_new_protocol chain_id new_protocol @@ -797,6 +810,7 @@ module Make (Proto : Protocol_plugin.T) = struct in let validation_result = {validation_result with max_operations_ttl} in let* block_metadata, ops_metadata = + Tezos_base.Profiler.(record_s main) "compute_metadata" @@ fun () -> compute_metadata ~operation_metadata_size_limit new_protocol_env_version @@ -806,6 +820,7 @@ module Make (Proto : Protocol_plugin.T) = struct let (Context {cache; _}) = validation_result.context in let context = validation_result.context in let*! resulting_context_hash = + Tezos_base.Profiler.(record_s main) "commit" @@ fun () -> if simulate then Lwt.return @@ Context_ops.hash @@ -1286,8 +1301,12 @@ module Make (Proto : Protocol_plugin.T) = struct ~predecessor_hash:predecessor_block_hash block_header.shell.timestamp in - let* operations = parse_operations block_hash operations in + let* operations = + Tezos_base.Profiler.(record_s main) "parse_operations" @@ fun () -> + parse_operations block_hash operations + in let* state = + Tezos_base.Profiler.(record_s main) "begin_validation" @@ fun () -> Proto.begin_validation context chain_id @@ -1295,19 +1314,26 @@ module Make (Proto : Protocol_plugin.T) = struct ~predecessor:predecessor_block_header.shell ~cache in - let* state = - List.fold_left_es - (fun state ops -> + Tezos_base.Profiler.(record_s main) "validate_operations" @@ fun () -> + List.fold_left_i_es + (fun i state ops -> + let sec = "operation_list(" ^ string_of_int i ^ ")" in + Tezos_base.Profiler.(record_s main) sec @@ fun () -> List.fold_left_es (fun state (oph, op, check_signature) -> + let sec = "operation(" ^ Operation_hash.to_b58check oph ^ ")" in + Tezos_base.Profiler.(record_s ~lod:Detailed main) sec @@ fun () -> Proto.validate_operation ~check_signature state oph op) state ops) state operations in - let* () = Proto.finalize_validation state in + let* () = + Tezos_base.Profiler.(record_s main) "finalize_validation" @@ fun () -> + Proto.finalize_validation state + in return_unit let validate chain_id ~(predecessor_block_header : Block_header.t) diff --git a/src/lib_validation/external_validator.ml b/src/lib_validation/external_validator.ml index cc0d18f68c08..2ab1fb606970 100644 --- a/src/lib_validation/external_validator.ml +++ b/src/lib_validation/external_validator.ml @@ -149,6 +149,7 @@ module Processing = struct should_validate; simulate; } -> + Tezos_protocol_environment.Environment_profiler.record "apply_block" ; let*! block_application_result = let* predecessor_context = Error_monad.catch_es (fun () -> @@ -207,6 +208,7 @@ module Processing = struct cache; } ) in + Tezos_protocol_environment.Environment_profiler.stop () ; continue block_application_result cache None | Preapply { @@ -283,6 +285,7 @@ module Processing = struct operations; _; } -> + Tezos_protocol_environment.Environment_profiler.record "validate_block" ; let*! block_validate_result = let* predecessor_context = Error_monad.catch_es (fun () -> @@ -300,7 +303,7 @@ module Processing = struct in let cache = match cache with - | None -> `Lazy + | None -> `Load | Some cache -> `Inherited (cache, predecessor_resulting_context_hash) in @@ -317,6 +320,7 @@ module Processing = struct header operations) in + Tezos_protocol_environment.Environment_profiler.stop () ; continue block_validate_result cache cached_result | External_validation.Fork_test_chain {chain_id; context_hash; forked_header} -> -- GitLab From 62349910ed77d591980b49deea489189000f5d56 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Tue, 13 Aug 2024 18:13:24 +0200 Subject: [PATCH 12/19] Lib_shell, Lib_validation: block_validator.ml, block_validation.ml - use pxx profiler --- src/lib_shell/block_validator.ml | 59 ++-- src/lib_validation/block_validation.ml | 366 ++++++++++++----------- src/lib_validation/dune | 1 + src/lib_validation/external_validator.ml | 6 +- 4 files changed, 227 insertions(+), 205 deletions(-) diff --git a/src/lib_shell/block_validator.ml b/src/lib_shell/block_validator.ml index 27556efe2c42..b40cfa93895a 100644 --- a/src/lib_shell/block_validator.ml +++ b/src/lib_shell/block_validator.ml @@ -31,7 +31,7 @@ open Block_validator_errors module Profiler = struct include (val Profiler.wrap Shell_profiling.block_validator_profiler) - let reset_block_section = + let[@warning "-32"] reset_block_section = Shell_profiling.create_reset_block_section Shell_profiling.block_validator_profiler end @@ -157,23 +157,23 @@ let check_chain_liveness chain_db hash (header : Block_header.t) = let check_operations_merkle_root hash header operations = let open Result_syntax in - Profiler.span_f ["checks"; "merkle_root"] @@ fun () -> - let fail_unless b e = if b then return_unit else tzfail e in - let computed_hash = - let hashes = List.map (List.map Operation.hash) operations in - Operation_list_list_hash.compute - (List.map Operation_list_hash.compute hashes) - in - fail_unless - (Operation_list_list_hash.equal - computed_hash - header.Block_header.shell.operations_hash) - (Inconsistent_operations_hash - { - block = hash; - expected = header.shell.operations_hash; - found = computed_hash; - }) + (let fail_unless b e = if b then return_unit else tzfail e in + let computed_hash = + let hashes = List.map (List.map Operation.hash) operations in + Operation_list_list_hash.compute + (List.map Operation_list_hash.compute hashes) + in + fail_unless + (Operation_list_list_hash.equal + computed_hash + header.Block_header.shell.operations_hash) + (Inconsistent_operations_hash + { + block = hash; + expected = header.shell.operations_hash; + found = computed_hash; + })) + [@profiler.span_f ["checks"; "merkle_root"]] (* [with_retry_to_load_protocol bv peer f] tries to call [f], if it fails with an [Unavailable_protocol] error, it fetches the protocol from the [peer] and retries @@ -333,14 +333,13 @@ let on_validation_request w advertise_after_validation; } = let open Lwt_result_syntax in - Profiler.reset_block_section hash ; + () [@profiler.reset_block_section hash] ; let bv = Worker.state w in let chain_store = Distributed_db.chain_store chain_db in let*! b = Store.Block.is_known_valid chain_store hash in match b with | true -> - Profiler.mark ["checks"; "already_commited"] ; - return Already_committed + return Already_committed [@profiler.mark ["checks"; "already_commited"]] | false -> ( (* This check might be redundant as operation paths are already checked when each pass is received from the network. However, @@ -361,8 +360,10 @@ let on_validation_request w | Some {errors; _} -> return (Already_known_invalid errors) | None -> ( let* pred = - Profiler.record_s "read_predecessor" @@ fun () -> - Store.Block.read_block chain_store header.shell.predecessor + (Store.Block.read_block + chain_store + header.shell.predecessor + [@profiler.record_s "read_predecessor"]) in let*! mempool = Store.Chain.mempool chain_store in let bv_operations = @@ -433,14 +434,14 @@ let on_validation_request w List.map (fun v -> Int.to_float (List.length v)) operations) ; - Profiler.record_s "commit_block" @@ fun () -> commit_and_notify_block notify_new_block chain_db hash header operations - application_result)))) + application_result [@profiler.record_s "commit_block"])) + )) let on_preapplication_request w { @@ -668,7 +669,7 @@ let validate_and_apply w ?canceler ?peer ?(notify_new_block = fun _ -> ()) ~advertise_after_validation chain_db hash (header : Block_header.t) operations = let open Lwt_syntax in - Profiler.reset_block_section hash ; + () [@profiler.reset_block_section hash] ; let chain_store = Distributed_db.chain_store chain_db in let* b = Store.Block.is_known_valid chain_store hash in match b with @@ -679,9 +680,9 @@ let validate_and_apply w ?canceler ?peer ?(notify_new_block = fun _ -> ()) let* r = let open Lwt_result_syntax in let* () = - Profiler.span_s ["checks"; "chain_liveness"] @@ fun () -> - check_chain_liveness chain_db hash header - |> Lwt_result.map_error (fun e -> Worker.Request_error e) + (check_chain_liveness chain_db hash header + |> Lwt_result.map_error (fun e -> Worker.Request_error e)) + [@profiler.span_s ["checks"; "chain_liveness"]] in Worker.Queue.push_request_and_wait w diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index c0ca1625554c..3dc02ef8f7ed 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -28,6 +28,10 @@ open Block_validator_errors open Validation_errors +module Profiler = struct + include (val Profiler.wrap Tezos_base.Profiler.main) +end + module Event = struct include Internal_event.Simple @@ -609,44 +613,53 @@ module Make (Proto : Protocol_plugin.T) = struct trace (invalid_block block_hash Economic_protocol_error) (let* state = - Tezos_base.Profiler.(record_s main) "begin_application" @@ fun () -> (Proto.begin_application context chain_id (Application block_header) ~predecessor:predecessor_block_header.shell - ~cache [@time.duration_lwt application_beginning]) + ~cache + [@time.duration_lwt application_beginning] + [@profiler.record_s "begin_application"]) in let* state, ops_metadata = - Tezos_base.Profiler.(record_s main) "apply_operations" @@ fun () -> (List.fold_left_i_es (fun i (state, acc) ops -> - let sec = "operation_list(" ^ string_of_int i ^ ")" in - Tezos_base.Profiler.(record_s main) sec @@ fun () -> - let* state, ops_metadata = - List.fold_left_es - (fun (state, acc) (oph, op, _check_signature) -> - let* state, op_metadata = - let sec = - "operation(" ^ Operation_hash.to_b58check oph ^ ")" - in - Tezos_base.Profiler.(record_s ~lod:Detailed main) sec - @@ fun () -> Proto.apply_operation state oph op - in - return (state, op_metadata :: acc)) - (state, []) - ops + let[@warning "-26"] sec = + "operation_list(" ^ string_of_int i ^ ")" in - return (state, List.rev ops_metadata :: acc)) + (let* state, ops_metadata = + List.fold_left_es + (fun (state, acc) (oph, op, _check_signature) -> + let* state, op_metadata = + let[@warning "-26"] sec = + "operation(" ^ Operation_hash.to_b58check oph ^ ")" + in + (Proto.apply_operation + state + oph + op + [@profiler.record_s sec] + (* TODO: Add a ~lod:detailed payload *)) + in + return (state, op_metadata :: acc)) + (state, []) + ops + in + return (state, List.rev ops_metadata :: acc)) + [@profiler.record_s sec]) (state, []) - operations [@time.duration_lwt operations_application]) + operations + [@time.duration_lwt operations_application] + [@profiler.record_s "apply_operations"]) in let ops_metadata = List.rev ops_metadata in let* validation_result, block_data = - Tezos_base.Profiler.(record_s main) "finalize_application" @@ fun () -> (Proto.finalize_application state - (Some block_header.shell) [@time.duration_lwt block_finalization]) + (Some block_header.shell) + [@time.duration_lwt block_finalization] + [@profiler.record_s "finalize_application"]) in return (validation_result, block_data, ops_metadata)) @@ -732,19 +745,19 @@ module Make (Proto : Protocol_plugin.T) = struct let* () = check_operation_quota block_hash operations in let predecessor_hash = Block_header.hash predecessor_block_header in let* operations = - Tezos_base.Profiler.(record_s main) "parse_operations" @@ fun () -> (parse_operations block_hash - operations [@time.duration_lwt operations_parsing]) + operations + [@time.duration_lwt operations_parsing] + [@profiler.record_s "parse_operations"]) in let* context = - Tezos_base.Profiler.(record_s main) "prepare_context" @@ fun () -> - prepare_context - predecessor_block_metadata_hash - predecessor_ops_metadata_hash - block_header - predecessor_context - predecessor_hash + (prepare_context + predecessor_block_metadata_hash + predecessor_ops_metadata_hash + block_header + predecessor_context + predecessor_hash [@profiler.record_s "prepare_context"]) in let* validation_result, block_metadata, ops_metadata = proto_apply_operations @@ -756,124 +769,122 @@ module Make (Proto : Protocol_plugin.T) = struct block_hash operations in - Tezos_base.Profiler.(record_s main) "post_validation" @@ fun () -> - let*! validation_result = - may_patch_protocol - ~user_activated_upgrades - ~user_activated_protocol_overrides - ~level:block_header.shell.level - validation_result - in - let context = validation_result.context in - let*! new_protocol = Context_ops.get_protocol context in - let expected_proto_level = - if Protocol_hash.equal new_protocol Proto.hash then - predecessor_block_header.shell.proto_level - else (predecessor_block_header.shell.proto_level + 1) mod 256 - in - let* () = - fail_when - (block_header.shell.proto_level <> expected_proto_level) - (invalid_block - block_hash - (Invalid_proto_level - { - found = block_header.shell.proto_level; - expected = expected_proto_level; - })) - in - let* () = - fail_when - Fitness.(validation_result.fitness <> block_header.shell.fitness) - (invalid_block - block_hash - (Invalid_fitness - { - expected = block_header.shell.fitness; - found = validation_result.fitness; - })) - in - let* validation_result, new_protocol_env_version, expected_context_hash - = - Tezos_base.Profiler.(record_s main) "record_protocol" @@ fun () -> - may_init_new_protocol - chain_id - new_protocol - block_header - block_hash - validation_result - in - let max_operations_ttl = - max - 0 - (min (max_operations_ttl + 1) validation_result.max_operations_ttl) - in - let validation_result = {validation_result with max_operations_ttl} in - let* block_metadata, ops_metadata = - Tezos_base.Profiler.(record_s main) "compute_metadata" @@ fun () -> - compute_metadata - ~operation_metadata_size_limit - new_protocol_env_version - block_metadata - ops_metadata - in - let (Context {cache; _}) = validation_result.context in - let context = validation_result.context in - let*! resulting_context_hash = - Tezos_base.Profiler.(record_s main) "commit" @@ fun () -> - if simulate then - Lwt.return - @@ Context_ops.hash - ~time:block_header.shell.timestamp - ?message:validation_result.message - context - else - Context_ops.commit - ~time:block_header.shell.timestamp - ?message:validation_result.message - context [@time.duration_lwt context_commitment] [@time.flush] - in - let* () = - let is_context_consistent = - match expected_context_hash with - | Predecessor_resulting_context -> - (* The check that the header's context is the - predecessor's resulting context has already been - performed in the [check_block_header] call above. *) - true - | Resulting_context -> - Context_hash.equal - resulting_context_hash - block_header.shell.context - in - fail_unless - is_context_consistent - (Validation_errors.Inconsistent_hash - (resulting_context_hash, block_header.shell.context)) - in - let validation_store = - { - resulting_context_hash; - timestamp = block_header.shell.timestamp; - message = validation_result.message; - max_operations_ttl = validation_result.max_operations_ttl; - last_finalized_block_level = - validation_result.last_finalized_block_level; - last_preserved_block_level = - validation_result.last_preserved_block_level; - } - in - return - { - result = - { - shell_header_hash = hash_shell_header block_header.shell; - validation_store; - block_metadata; - ops_metadata; - }; - cache; - } + (let*! validation_result = + may_patch_protocol + ~user_activated_upgrades + ~user_activated_protocol_overrides + ~level:block_header.shell.level + validation_result + in + let context = validation_result.context in + let*! new_protocol = Context_ops.get_protocol context in + let expected_proto_level = + if Protocol_hash.equal new_protocol Proto.hash then + predecessor_block_header.shell.proto_level + else (predecessor_block_header.shell.proto_level + 1) mod 256 + in + let* () = + fail_when + (block_header.shell.proto_level <> expected_proto_level) + (invalid_block + block_hash + (Invalid_proto_level + { + found = block_header.shell.proto_level; + expected = expected_proto_level; + })) + in + let* () = + fail_when + Fitness.(validation_result.fitness <> block_header.shell.fitness) + (invalid_block + block_hash + (Invalid_fitness + { + expected = block_header.shell.fitness; + found = validation_result.fitness; + })) + in + let* validation_result, new_protocol_env_version, expected_context_hash + = + (may_init_new_protocol + chain_id + new_protocol + block_header + block_hash + validation_result [@profiler.record_s "record_protocol"]) + in + let max_operations_ttl = + max + 0 + (min (max_operations_ttl + 1) validation_result.max_operations_ttl) + in + let validation_result = {validation_result with max_operations_ttl} in + let* block_metadata, ops_metadata = + (compute_metadata + ~operation_metadata_size_limit + new_protocol_env_version + block_metadata + ops_metadata [@profiler.record_s "compute_metadata"]) + in + let (Context {cache; _}) = validation_result.context in + let context = validation_result.context in + let*! resulting_context_hash = + (if simulate then + Lwt.return + @@ Context_ops.hash + ~time:block_header.shell.timestamp + ?message:validation_result.message + context + else + Context_ops.commit + ~time:block_header.shell.timestamp + ?message:validation_result.message + context [@time.duration_lwt context_commitment] [@time.flush]) + [@profiler.record_s "commit"] + in + let* () = + let is_context_consistent = + match expected_context_hash with + | Predecessor_resulting_context -> + (* The check that the header's context is the + predecessor's resulting context has already been + performed in the [check_block_header] call above. *) + true + | Resulting_context -> + Context_hash.equal + resulting_context_hash + block_header.shell.context + in + fail_unless + is_context_consistent + (Validation_errors.Inconsistent_hash + (resulting_context_hash, block_header.shell.context)) + in + let validation_store = + { + resulting_context_hash; + timestamp = block_header.shell.timestamp; + message = validation_result.message; + max_operations_ttl = validation_result.max_operations_ttl; + last_finalized_block_level = + validation_result.last_finalized_block_level; + last_preserved_block_level = + validation_result.last_preserved_block_level; + } + in + return + { + result = + { + shell_header_hash = hash_shell_header block_header.shell; + validation_store; + block_metadata; + ops_metadata; + }; + cache; + }) + [@profiler.record_s "post_validation"] let recompute_metadata chain_id ~cache ~(predecessor_block_header : Block_header.t) @@ -1302,37 +1313,44 @@ module Make (Proto : Protocol_plugin.T) = struct block_header.shell.timestamp in let* operations = - Tezos_base.Profiler.(record_s main) "parse_operations" @@ fun () -> - parse_operations block_hash operations + (parse_operations + block_hash + operations [@profiler.record_s "parse_operations"]) in let* state = - Tezos_base.Profiler.(record_s main) "begin_validation" @@ fun () -> - Proto.begin_validation - context - chain_id - (Application block_header) - ~predecessor:predecessor_block_header.shell - ~cache + (Proto.begin_validation + context + chain_id + (Application block_header) + ~predecessor:predecessor_block_header.shell + ~cache [@profiler.record_s "begin_validation"]) in let* state = - Tezos_base.Profiler.(record_s main) "validate_operations" @@ fun () -> - List.fold_left_i_es - (fun i state ops -> - let sec = "operation_list(" ^ string_of_int i ^ ")" in - Tezos_base.Profiler.(record_s main) sec @@ fun () -> - List.fold_left_es - (fun state (oph, op, check_signature) -> - let sec = "operation(" ^ Operation_hash.to_b58check oph ^ ")" in - Tezos_base.Profiler.(record_s ~lod:Detailed main) sec @@ fun () -> - Proto.validate_operation ~check_signature state oph op) - state - ops) - state - operations + (List.fold_left_i_es + (fun i state ops -> + let[@warning "-26"] sec = + "operation_list(" ^ string_of_int i ^ ")" + in + (List.fold_left_es + (fun state (oph, op, check_signature) -> + let[@warning "-26"] sec = + "operation(" ^ Operation_hash.to_b58check oph ^ ")" + in + (Proto.validate_operation + ~check_signature + state + oph + op + [@profiler.record_s sec] + (* TODO: add a ~lod option for record_s *))) + state + ops [@profiler.record_s sec])) + state + operations [@profiler.record_s "validate_operations"]) in let* () = - Tezos_base.Profiler.(record_s main) "finalize_validation" @@ fun () -> - Proto.finalize_validation state + (Proto.finalize_validation + state [@profiler.record_s "finalize_validation"]) in return_unit diff --git a/src/lib_validation/dune b/src/lib_validation/dune index af4aa84baa3d..cb7bad946453 100644 --- a/src/lib_validation/dune +++ b/src/lib_validation/dune @@ -15,6 +15,7 @@ octez-shell-libs.protocol-updater octez-libs.stdlib-unix octez-version.value) + (preprocess (pps octez-libs.ppx_profiler)) (flags (:standard) -open Tezos_base.TzPervasives diff --git a/src/lib_validation/external_validator.ml b/src/lib_validation/external_validator.ml index 2ab1fb606970..99c145bc3a08 100644 --- a/src/lib_validation/external_validator.ml +++ b/src/lib_validation/external_validator.ml @@ -24,6 +24,8 @@ (* *) (*****************************************************************************) +module Profiler = Tezos_protocol_environment.Environment_profiler + module Events = struct open Internal_event.Simple @@ -149,7 +151,7 @@ module Processing = struct should_validate; simulate; } -> - Tezos_protocol_environment.Environment_profiler.record "apply_block" ; + () [@profiler.record "apply_block"] ; let*! block_application_result = let* predecessor_context = Error_monad.catch_es (fun () -> @@ -285,7 +287,7 @@ module Processing = struct operations; _; } -> - Tezos_protocol_environment.Environment_profiler.record "validate_block" ; + () [@profiler.record "validate_block"] ; let*! block_validate_result = let* predecessor_context = Error_monad.catch_es (fun () -> -- GitLab From 6d73f7a0714e5c137d74c6046d4af2451e2ea7a4 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 28 Feb 2024 16:58:22 +0100 Subject: [PATCH 13/19] Profiler: plug baker profilers --- .../lib_delegate/baking_actions.ml | 58 +++++++++++++++++- .../lib_delegate/baking_nonces.ml | 19 +++++- .../lib_delegate/baking_profiler.ml | 39 ++++++++++++ .../lib_delegate/baking_scheduling.ml | 57 ++++++++++++++++-- .../lib_delegate/baking_simulator.ml | 3 + .../lib_delegate/baking_state.ml | 15 +++++ .../lib_delegate/baking_state.mli | 2 + .../lib_delegate/block_forge.ml | 17 +++++- .../lib_delegate/client_daemon.ml | 19 ++++++ .../lib_delegate/node_rpc.ml | 58 +++++++++++++++++- .../lib_delegate/operation_selection.ml | 17 +++++- .../lib_delegate/baking_actions.ml | 59 ++++++++++++++++++- src/proto_alpha/lib_delegate/baking_nonces.ml | 19 +++++- .../lib_delegate/baking_profiler.ml | 39 ++++++++++++ .../lib_delegate/baking_scheduling.ml | 57 ++++++++++++++++-- .../lib_delegate/baking_simulator.ml | 3 + src/proto_alpha/lib_delegate/baking_state.ml | 15 +++++ src/proto_alpha/lib_delegate/baking_state.mli | 2 + src/proto_alpha/lib_delegate/block_forge.ml | 17 +++++- src/proto_alpha/lib_delegate/client_daemon.ml | 19 ++++++ src/proto_alpha/lib_delegate/node_rpc.ml | 58 +++++++++++++++++- .../lib_delegate/operation_selection.ml | 17 +++++- src/proto_beta/lib_delegate/baking_actions.ml | 59 ++++++++++++++++++- .../lib_delegate/baking_profiler.ml | 39 ++++++++++++ .../lib_delegate/baking_scheduling.ml | 57 ++++++++++++++++-- .../lib_delegate/baking_simulator.ml | 3 + src/proto_beta/lib_delegate/baking_state.ml | 15 +++++ src/proto_beta/lib_delegate/baking_state.mli | 2 + src/proto_beta/lib_delegate/block_forge.ml | 17 +++++- src/proto_beta/lib_delegate/client_daemon.ml | 19 ++++++ src/proto_beta/lib_delegate/node_rpc.ml | 59 ++++++++++++++++++- .../lib_delegate/operation_selection.ml | 17 +++++- 32 files changed, 859 insertions(+), 37 deletions(-) create mode 100644 src/proto_020_PsParisC/lib_delegate/baking_profiler.ml create mode 100644 src/proto_alpha/lib_delegate/baking_profiler.ml create mode 100644 src/proto_beta/lib_delegate/baking_profiler.ml diff --git a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml index 3157d35a39d1..97a9652c0e7a 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml @@ -44,6 +44,7 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( + Baking_profiler.record_s "retrieve external operations" @@ fun () -> let fail reason details = let path = match operations with @@ -187,6 +188,7 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = + Baking_profiler.record_f "serializing" @@ fun () -> Data_encoding.Binary.to_bytes_exn Alpha_context.Block_header.unsigned_encoding (shell, contents) @@ -194,12 +196,15 @@ let sign_block_header global_state proposer unsigned_block_header = let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in + Baking_profiler.record "waiting for lockfile" ; let* result = cctxt#with_lock (fun () -> + Baking_profiler.stop () ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = + Baking_profiler.record_s "check highwatermark" @@ fun () -> may_sign_block cctxt block_location @@ -210,6 +215,7 @@ let sign_block_header global_state proposer unsigned_block_header = match may_sign with | true -> let* () = + Baking_profiler.record_s "record highwatermark" @@ fun () -> record_block cctxt block_location @@ -226,6 +232,7 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = + Baking_profiler.record_s "signing block" @@ fun () -> Client_keys.sign cctxt proposer.secret_key_uri @@ -257,6 +264,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let simulation_mode = global_state.validation_mode in let round_durations = global_state.round_durations in let*? timestamp = + Baking_profiler.record_f "timestamp of round" @@ fun () -> Environment.wrap_tzresult (Round.timestamp_of_round round_durations @@ -293,12 +301,14 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) in let* injection_level = + Baking_profiler.record_s "retrieve injection level" @@ fun () -> Plugin.RPC.current_level cctxt ~offset:1l (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) in let* seed_nonce_opt = + Baking_profiler.record_s "generate seed nonce" @@ fun () -> generate_seed_nonce_hash global_state.config.Baking_configuration.nonce consensus_key @@ -334,6 +344,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let chain = `Hash global_state.chain_id in let pred_block = `Hash (predecessor.hash, 0) in let* pred_resulting_context_hash = + Baking_profiler.record_s "retrieve resulting context hash" @@ fun () -> Shell_services.Blocks.resulting_context_hash cctxt ~chain @@ -341,6 +352,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) () in let* pred_live_blocks = + Baking_profiler.record_s "retrieve live blocks" @@ fun () -> Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () in let* {unsigned_block_header; operations} = @@ -364,6 +376,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = + Baking_profiler.record_s "sign block header" @@ fun () -> sign_block_header global_state consensus_key unsigned_block_header in let* () = @@ -373,6 +386,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) return_unit | Some (_, nonce) -> let block_hash = Block_header.hash signed_block_header in + Baking_profiler.record_s "register nonce" @@ fun () -> Baking_nonces.register_nonce cctxt ~chain_id @@ -548,8 +562,20 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = + Baking_profiler.record_s + (Format.sprintf + "filter consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> + Baking_profiler.record "wait for lock" ; cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in + Baking_profiler.stop () ; + let* highwatermarks = + Baking_profiler.record_s "load highwatermarks" @@ fun () -> + Baking_highwatermarks.load cctxt block_location + in let authorized_votes, unauthorized_votes = List.partition (fun consensus_vote -> @@ -569,6 +595,13 @@ let authorized_consensus_votes global_state in (* We exit the client's lock as soon as this function returns *) let* () = + Baking_profiler.record_s + (Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> record_all_consensus_vote highwatermarks cctxt @@ -649,6 +682,13 @@ let sign_consensus_votes (global_state : global_state) unsigned_consensus_vote) -> let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in let*! signed_consensus_vote_r = + Baking_profiler.record_s + (Format.sprintf + "forge and sign consensus vote: %s" + (match vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> forge_and_sign_consensus_vote global_state ~branch:batch_branch @@ -702,6 +742,13 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = + Baking_profiler.record_s + (Format.sprintf + "injecting consensus vote: %s" + (match unsigned_consensus_vote.vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> Node_rpc.inject_operation cctxt ~chain:(`Hash chain_id) @@ -752,6 +799,7 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = + Baking_profiler.record_s "inject block to node" @@ fun () -> Node_rpc.inject_block state.global_state.cctxt ~force:state.global_state.config.force @@ -857,6 +905,7 @@ let compute_round proposal round_durations = let open Baking_state in let timestamp = Time.System.now () |> Time.System.to_protocol in let predecessor_block = proposal.predecessor in + Baking_profiler.record_f "compute round" @@ fun () -> Environment.wrap_tzresult @@ Alpha_context.Round.round_of_timestamp round_durations @@ -881,6 +930,7 @@ let update_to_level state level_update = if Int32.(new_level = succ state.level_state.current_level) then return state.level_state.next_level_delegate_slots else + Baking_profiler.record_s "compute predecessor delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -888,6 +938,7 @@ let update_to_level state level_update = ~chain in let* next_level_delegate_slots = + Baking_profiler.record_s "compute current delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -989,6 +1040,7 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> + Baking_profiler.record_s "inject preattestations" @@ fun () -> let* () = inject_consensus_vote state signed_preattestation in (* Here, we do not need to wait for the prequorum, it has already been triggered by the @@ -1000,14 +1052,18 @@ let rec perform_action state (action : action) = event *) perform_action state Watch_quorum | Update_to_level level_update -> + Baking_profiler.record_s "update to level" @@ fun () -> let* new_state, new_action = update_to_level state level_update in perform_action new_state new_action | Synchronize_round round_update -> + Baking_profiler.record_s "synchronize round" @@ fun () -> let* new_state, new_action = synchronize_round state round_update in perform_action new_state new_action | Watch_prequorum -> + Baking_profiler.record_s "wait for preattestation quorum" @@ fun () -> let*! () = start_waiting_for_preattestation_quorum state in return state | Watch_quorum -> + Baking_profiler.record_s "wait for attestation quorum" @@ fun () -> let*! () = start_waiting_for_attestation_quorum state in return state diff --git a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml index 7d38c52f8db9..3229a761a36d 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml @@ -28,6 +28,8 @@ open Protocol open Alpha_context module Events = Baking_events.Nonces +module Profiler = (val Profiler.wrap Baking_profiler.nonce_profiler) + type state = { cctxt : Protocol_client_context.full; chain : Chain_services.chain; @@ -480,8 +482,12 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) + Profiler.record "waiting lock" ; cctxt#with_lock @@ fun () -> - let*! nonces = load cctxt ~stateful_location in + let*! nonces = + Profiler.record_s "load nonce file" @@ fun () -> + load cctxt ~stateful_location + in match nonces with | Error err -> let*! () = Events.(emit cannot_read_nonces err) in @@ -491,6 +497,7 @@ let reveal_potential_nonces state new_proposal = Plugin.RPC.current_level cctxt (chain, `Head 0) in let*! partitioned_nonces = + Profiler.record_s "get unrevealed nonces" @@ fun () -> partition_unrevealed_nonces state nonces cycle level in match partitioned_nonces with @@ -570,6 +577,7 @@ let start_revelation_worker cctxt config chain_id constants block_stream = format. *) let* () = try_migrate_legacy_nonces state in + let last_proposal = ref None in let rec worker_loop () = Lwt_canceler.on_cancel canceler (fun () -> should_shutdown := true ; @@ -581,9 +589,16 @@ let start_revelation_worker cctxt config chain_id constants block_stream = with the node was interrupted: exit *) return_unit | Some new_proposal -> + Option.iter (fun _ -> Profiler.stop ()) !last_proposal ; + Profiler.record + (Block_hash.to_b58check new_proposal.Baking_state.block.hash) ; + last_proposal := Some new_proposal.Baking_state.block.hash ; if !should_shutdown then return_unit else - let* _ = reveal_potential_nonces state new_proposal in + let* _ = + Profiler.record_s "reveal potential nonces" @@ fun () -> + reveal_potential_nonces state new_proposal + in worker_loop () in Lwt.dont_wait diff --git a/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml b/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml new file mode 100644 index 000000000000..f3cf98af7244 --- /dev/null +++ b/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Profiler + +let nonce_profiler = unplugged () + +let operation_worker_profiler = unplugged () + +let node_rpc_profiler = unplugged () + +let profiler = unplugged () + +let init profiler_maker = + let baker_instance = profiler_maker ~name:"baker" in + plug profiler baker_instance ; + plug Tezos_protocol_environment.Environment_profiler.profiler baker_instance ; + plug nonce_profiler (profiler_maker ~name:"nonce") ; + plug node_rpc_profiler (profiler_maker ~name:"node_rpc") ; + plug operation_worker_profiler (profiler_maker ~name:"op_worker") + +let create_reset_block_section profiler = + let last_block = ref None in + fun b -> + match !last_block with + | None -> + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + | Some b' when Block_hash.equal b' b -> () + | Some _ -> + stop profiler ; + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + +include (val wrap profiler) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml index 208fb1426d06..64b8b6dda565 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml @@ -577,8 +577,14 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t in (* TODO: re-use what has been done in round_synchronizer.ml *) (* Compute the timestamp of the next possible round. *) - let next_round = compute_next_round_time state in - let*! next_baking = compute_next_potential_baking_time_at_next_level state in + let next_round = + Baking_profiler.record_f "compute next round time" @@ fun () -> + compute_next_round_time state + in + let*! next_baking = + Baking_profiler.record_s "compute next potential baking time" @@ fun () -> + compute_next_potential_baking_time_at_next_level state + in match (next_round, next_baking) with | None, None -> let*! () = Events.(emit waiting_for_new_head ()) in @@ -816,6 +822,27 @@ let compute_bootstrap_event state = in return @@ Baking_state.Timeout (End_of_round {ending_round}) +let may_reset_profiler = + let prev_head = ref None in + let () = + at_exit (fun () -> + Option.iter (fun _ -> Baking_profiler.stop ()) !prev_head) + in + function + | Baking_state.New_head_proposal proposal + | Baking_state.New_valid_proposal proposal -> ( + let curr_head_hash = proposal.block.hash in + match !prev_head with + | None -> + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | Some prev_head_hash when prev_head_hash <> curr_head_hash -> + Baking_profiler.stop () ; + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | _ -> ()) + | _ -> () + let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error loop_state state event = let open Lwt_result_syntax in @@ -825,10 +852,25 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error Baking_state.may_record_new_state ~previous_state:state ~new_state | Baking_configuration.Memory -> return_unit in - let*! state', action = State_transitions.step state event in + may_reset_profiler event ; + let*! state', action = + Format.kasprintf + Baking_profiler.record_s + "do step with event '%a'" + pp_short_event + event + @@ fun () -> State_transitions.step state event + in let* state'' = let*! state_res = - let* state'' = Baking_actions.perform_action state' action in + let* state'' = + Format.kasprintf + Baking_profiler.record_s + "perform action '%a'" + Baking_actions.pp_action + action + @@ fun () -> Baking_actions.perform_action state' action + in let* () = may_record_new_state ~previous_state:state ~new_state:state'' in return state'' in @@ -841,7 +883,10 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error let*! _ = state_recorder ~new_state:state' in return state' in - let* next_timeout = compute_next_timeout state'' in + let* next_timeout = + Baking_profiler.record_s "compute next timeout" @@ fun () -> + compute_next_timeout state'' + in let* event_opt = wait_next_event ~timeout: @@ -1020,6 +1065,8 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in + Baking_profiler.stop () ; + may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> let*! _ = Option.iter_es Lwt_canceler.cancel canceler in diff --git a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml b/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml index 4184b4033f0d..f65aac61eab4 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml @@ -60,6 +60,7 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) pred_block chain_id = let open Lwt_result_syntax in + Baking_profiler.record_s "begin construction" @@ fun () -> protect (fun () -> let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in let*! context_opt = @@ -133,6 +134,7 @@ let add_operation st (op : Operation.packed) = let validation_state, application_state = st.state in let oph = Operation.hash_packed op in let** validation_state = + Baking_profiler.aggregate_s "validating operation" @@ fun () -> Protocol.validate_operation ~check_signature:false (* We assume that the operation has already been validated in the @@ -147,6 +149,7 @@ let add_operation st (op : Operation.packed) = match application_state with | Some application_state -> let* application_state, receipt = + Baking_profiler.aggregate_s "applying operation" @@ fun () -> Protocol.apply_operation application_state oph op in return (Some application_state, Some receipt) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.ml b/src/proto_020_PsParisC/lib_delegate/baking_state.ml index fb1384c1c727..6b45d49d0532 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_state.ml @@ -795,6 +795,7 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in + Baking_profiler.record_s "record state" @@ fun () -> let cctxt = state.global_state.cctxt in let location = Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State @@ -803,17 +804,21 @@ let record_state (state : state) = Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) in protect @@ fun () -> + Baking_profiler.record "waiting lock" ; cctxt#with_lock @@ fun () -> + Baking_profiler.stop () ; let level_data = state.level_state.current_level in let locked_round_data = state.level_state.locked_round in let attestable_payload_data = state.level_state.attestable_payload in let bytes = + Baking_profiler.record_f "serializing baking state" @@ fun () -> Data_encoding.Binary.to_bytes_exn state_data_encoding {level_data; locked_round_data; attestable_payload_data} in let filename_tmp = filename ^ "_tmp" in let*! () = + Baking_profiler.record_s "writing baking state" @@ fun () -> Lwt_io.with_file ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] ~mode:Output @@ -1390,3 +1395,13 @@ let pp_event fmt = function Format.fprintf fmt "new forge event: %a" pp_forge_event forge_event | Timeout kind -> Format.fprintf fmt "timeout reached: %a" pp_timeout_kind kind + +let pp_short_event fmt = + let open Format in + function + | New_valid_proposal _ -> fprintf fmt "new valid proposal" + | New_head_proposal _ -> fprintf fmt "new head proposal" + | Prequorum_reached (_, _) -> fprintf fmt "prequorum reached" + | Quorum_reached (_, _) -> fprintf fmt "quorum reached" + | Timeout _ -> fprintf fmt "timeout" + | New_forge_event _ -> fprintf fmt "new forge event" diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.mli b/src/proto_020_PsParisC/lib_delegate/baking_state.mli index 689b85c0b009..5ecb460fd8e4 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.mli +++ b/src/proto_020_PsParisC/lib_delegate/baking_state.mli @@ -409,4 +409,6 @@ val pp_timeout_kind : Format.formatter -> timeout_kind -> unit val pp_event : Format.formatter -> event -> unit +val pp_short_event : Format.formatter -> event -> unit + val pp_forge_event : Format.formatter -> forge_event -> unit diff --git a/src/proto_020_PsParisC/lib_delegate/block_forge.ml b/src/proto_020_PsParisC/lib_delegate/block_forge.ml index 7338ce67d0db..49b0e5ae88c0 100644 --- a/src/proto_020_PsParisC/lib_delegate/block_forge.ml +++ b/src/proto_020_PsParisC/lib_delegate/block_forge.ml @@ -249,6 +249,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -260,6 +261,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block in let operations = List.map (List.map convert_operation) operations in let payload_hash = + Baking_profiler.record_f "compute payload hash" @@ fun () -> let operation_hashes = Stdlib.List.tl operations |> List.flatten |> List.map Tezos_base.Operation.hash @@ -300,6 +302,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades ~context_index ~payload_hash cctxt = let open Lwt_result_syntax in let* incremental = + Baking_profiler.record_s "begin construction" @@ fun () -> Baking_simulator.begin_construction ~timestamp ~protocol_data:faked_protocol_data @@ -312,12 +315,14 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (* We still need to filter attestations. Two attestations could be referring to the same slot. *) let* incremental, ordered_pool = + Baking_profiler.record_s "filter consensus operations" @@ fun () -> Operation_selection.filter_consensus_operations_only incremental ordered_pool in let operations = Operation_pool.ordered_to_list_list ordered_pool in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -329,7 +334,10 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades let incremental = {incremental with header = {incremental.header with operations_hash}} in - let* validation_result = Baking_simulator.finalize_construction incremental in + let* validation_result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction incremental + in let validation_result = Option.map fst validation_result in let* changed = check_protocol_changed @@ -362,6 +370,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -391,6 +400,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id (* We cannot include operations that are not live with respect to our predecessor otherwise the node would reject the block. *) let filtered_pool = + Baking_profiler.record_f "filter non live operations" @@ fun () -> retain_live_operations_only ~live_blocks:pred_live_blocks operation_pool @@ -409,6 +419,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter via node" @@ fun () -> filter_via_node ~chain_id ~faked_protocol_data @@ -429,6 +440,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply via node" @@ fun () -> apply_via_node ~chain_id ~faked_protocol_data @@ -446,6 +458,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter with context" @@ fun () -> filter_with_context ~chain_id ~faked_protocol_data @@ -471,6 +484,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply with context" @@ fun () -> apply_with_context ~chain_id ~faked_protocol_data @@ -486,6 +500,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id cctxt in let* contents = + Baking_profiler.record_s "compute proof of work" @@ fun () -> Baking_pow.mine ~proof_of_work_threshold:constants.proof_of_work_threshold shell_header diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml index a51235b8547b..5231886132f0 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -56,6 +56,23 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with + | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let profiler_maker ~name = + Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker + | _ -> () + module Baker = struct let run (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes @@ -134,6 +151,8 @@ module Baker = struct let*! _ = Lwt_canceler.cancel canceler in Lwt.return_unit) in + let () = may_start_profiler cctxt#get_base_dir in + Baking_profiler.record "initialization" ; let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml index 8538f928049f..c2bb081db7e0 100644 --- a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml +++ b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml @@ -30,6 +30,13 @@ open Baking_state module Block_services = Block_services.Make (Protocol) (Protocol) module Events = Baking_events.Node_rpc +module Profiler = struct + include (val Profiler.wrap Baking_profiler.node_rpc_profiler) + + let reset_block_section = + Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler +end + let inject_block cctxt ?(force = false) ~chain signed_block_header operations = let signed_shell_header_bytes = Data_encoding.Binary.to_bytes_exn Block_header.encoding signed_block_header @@ -99,6 +106,7 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = + Profiler.record_f "operations classification" @@ fun () -> WithExceptions.Option.get ~loc:__LOC__ (Operation_pool.extract_operations_of_list_list operations) @@ -121,11 +129,19 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash block_header = let open Lwt_result_syntax in + Profiler.record_s + ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info") + @@ fun () -> let* operations = match operations with | None when not in_protocol -> return_nil | None -> let open Protocol_client_context in + Profiler.record_s + ("retrieve block " + ^ Block_hash.to_short_b58check block_hash + ^ " operations") + @@ fun () -> let* operations = Alpha_block_services.Operations.operations cctxt @@ -146,13 +162,23 @@ let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash | Some operations -> let parse_op (raw_op : Tezos_base.Operation.t) = let protocol_data = + Profiler.aggregate_f "parse operation" @@ fun () -> Data_encoding.Binary.of_bytes_exn Operation.protocol_data_encoding raw_op.proto in {shell = raw_op.shell; protocol_data} in - protect @@ fun () -> return (List.map (List.map parse_op) operations) + protect @@ fun () -> + return + (List.mapi + (fun i -> function + | [] -> [] + | l -> + Profiler.record_f + (Printf.sprintf "parse operations (pass:%d)" i) + @@ fun () -> List.map parse_op l) + operations) in let*? block_info = info_of_header_and_ops ~in_protocol block_hash block_header operations @@ -170,14 +196,27 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* is_proposal_in_protocol, predecessor = match predecessor_opt with | Some predecessor -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_hit"; + ] ; return ( predecessor.shell.proto_level = block_header.shell.proto_level, predecessor ) | None -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_miss"; + ] ; let* { current_protocol = pred_current_protocol; next_protocol = pred_next_protocol; } = + Profiler.record_s "pred block protocol RPC" @@ fun () -> Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () in let is_proposal_in_protocol = @@ -191,6 +230,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () in let predecessor_header = + Profiler.record_f "parse pred block header" @@ fun () -> Data_encoding.Binary.of_bytes_exn Tezos_base.Block_header.encoding raw_header_b @@ -212,8 +252,17 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain in let* block = match block_opt with - | Some pi -> return pi + | Some pi -> + Profiler.mark + ["new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"] ; + return pi | None -> + Profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ] ; let* pi = compute_block_info cctxt @@ -229,6 +278,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain return {block; predecessor} let proposal cctxt ?cache ?operations ~chain block_hash block_header = + Profiler.record_s "proposal_computation" @@ fun () -> protect @@ fun () -> proposal cctxt ?cache ?operations ~chain block_hash block_header @@ -240,6 +290,8 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received valid proposal" @@ fun () -> let*! map_result = proposal cctxt ?cache ~operations ~chain block_hash block_header in @@ -261,6 +313,8 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received new head" @@ fun () -> let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in match map_result with | Ok proposal -> Lwt.return_some proposal diff --git a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml index d83f7c55369a..c9ce27b90f79 100644 --- a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml +++ b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml @@ -181,6 +181,8 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( + Baking_profiler.record_f "checking operation receipt roundtrip" + @@ fun () -> (* Check that the metadata are serializable/deserializable *) let encoding_result = let enc = Protocol.operation_receipt_encoding in @@ -218,7 +220,9 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = max_op ; let* inc'_opt = validate_operation inc op in match inc'_opt with - | None -> return (inc, curr_size, nb_ops, acc) + | None -> + Baking_profiler.mark ["invalid operation filtered"] ; + return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) ops @@ -277,22 +281,26 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = + Baking_profiler.record_s "simulate and filter consensus" @@ fun () -> filter_valid_operations_up_to_quota initial_inc (Prioritized_operation_set.operations consensus, consensus_quota) in let*! inc, votes = + Baking_profiler.record_s "simulate and filter votes" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations votes, votes_quota) in let*! inc, anonymous = + Baking_profiler.record_s "simulate and filter anonymous" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations anonymous, anonymous_quota) in (* Sort the managers *) let prioritized_managers = + Baking_profiler.record_f "prioritize managers" @@ fun () -> prioritize_managers ~hard_gas_limit_per_block ~minimal_fees @@ -301,6 +309,7 @@ let filter_operations_with_simulation initial_inc fees_config managers in let*! inc, managers = + Baking_profiler.record_s "simulate and filter managers" @@ fun () -> filter_valid_managers_up_to_quota inc ~hard_gas_limit_per_block @@ -308,6 +317,7 @@ let filter_operations_with_simulation initial_inc fees_config in let operations = [consensus; votes; anonymous; managers] in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -315,7 +325,10 @@ let filter_operations_with_simulation initial_inc fees_config operations) in let inc = {inc with header = {inc.header with operations_hash}} in - let* result = Baking_simulator.finalize_construction inc in + let* result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction inc + in match result with | Some (validation_result, block_header_metadata) -> return diff --git a/src/proto_alpha/lib_delegate/baking_actions.ml b/src/proto_alpha/lib_delegate/baking_actions.ml index ecb2dc9a5dbe..74bca0325e30 100644 --- a/src/proto_alpha/lib_delegate/baking_actions.ml +++ b/src/proto_alpha/lib_delegate/baking_actions.ml @@ -44,6 +44,7 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( + Baking_profiler.record_s "retrieve external operations" @@ fun () -> let fail reason details = let path = match operations with @@ -187,6 +188,7 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = + Baking_profiler.record_f "serializing" @@ fun () -> Data_encoding.Binary.to_bytes_exn Alpha_context.Block_header.unsigned_encoding (shell, contents) @@ -194,12 +196,15 @@ let sign_block_header global_state proposer unsigned_block_header = let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in + Baking_profiler.record "waiting for lockfile" ; let* result = cctxt#with_lock (fun () -> + Baking_profiler.stop () ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = + Baking_profiler.record_s "check highwatermark" @@ fun () -> may_sign_block cctxt block_location @@ -210,6 +215,7 @@ let sign_block_header global_state proposer unsigned_block_header = match may_sign with | true -> let* () = + Baking_profiler.record_s "record highwatermark" @@ fun () -> record_block cctxt block_location @@ -226,6 +232,7 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = + Baking_profiler.record_s "signing block" @@ fun () -> Client_keys.sign cctxt proposer.secret_key_uri @@ -257,6 +264,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let simulation_mode = global_state.validation_mode in let round_durations = global_state.round_durations in let*? timestamp = + Baking_profiler.record_f "timestamp of round" @@ fun () -> Environment.wrap_tzresult (Round.timestamp_of_round round_durations @@ -293,12 +301,14 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) in let* injection_level = + Baking_profiler.record_s "retrieve injection level" @@ fun () -> Plugin.RPC.current_level cctxt ~offset:1l (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) in let* seed_nonce_opt = + Baking_profiler.record_s "generate seed nonce" @@ fun () -> generate_seed_nonce_hash global_state.config.Baking_configuration.nonce consensus_key @@ -334,6 +344,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let chain = `Hash global_state.chain_id in let pred_block = `Hash (predecessor.hash, 0) in let* pred_resulting_context_hash = + Baking_profiler.record_s "retrieve resulting context hash" @@ fun () -> Shell_services.Blocks.resulting_context_hash cctxt ~chain @@ -341,6 +352,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) () in let* pred_live_blocks = + Baking_profiler.record_s "retrieve live blocks" @@ fun () -> Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () in let* {unsigned_block_header; operations} = @@ -364,6 +376,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = + Baking_profiler.record_s "sign block header" @@ fun () -> sign_block_header global_state consensus_key unsigned_block_header in let* () = @@ -373,6 +386,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) return_unit | Some (_, nonce) -> let block_hash = Block_header.hash signed_block_header in + Baking_profiler.record_s "register nonce" @@ fun () -> Baking_nonces.register_nonce cctxt ~chain_id @@ -550,8 +564,20 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = + Baking_profiler.record_s + (Format.sprintf + "filter consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> + Baking_profiler.record "wait for lock" ; cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in + Baking_profiler.stop () ; + let* highwatermarks = + Baking_profiler.record_s "load highwatermarks" @@ fun () -> + Baking_highwatermarks.load cctxt block_location + in let authorized_votes, unauthorized_votes = List.partition (fun consensus_vote -> @@ -571,6 +597,13 @@ let authorized_consensus_votes global_state in (* We exit the client's lock as soon as this function returns *) let* () = + Baking_profiler.record_s + (Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> record_all_consensus_vote highwatermarks cctxt @@ -651,6 +684,13 @@ let sign_consensus_votes (global_state : global_state) unsigned_consensus_vote) -> let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in let*! signed_consensus_vote_r = + Baking_profiler.record_s + (Format.sprintf + "forge and sign consensus vote: %s" + (match vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> forge_and_sign_consensus_vote global_state ~branch:batch_branch @@ -704,6 +744,13 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = + Baking_profiler.record_s + (Format.sprintf + "injecting consensus vote: %s" + (match unsigned_consensus_vote.vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> Node_rpc.inject_operation cctxt ~chain:(`Hash chain_id) @@ -754,6 +801,7 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = + Baking_profiler.record_s "inject block to node" @@ fun () -> Node_rpc.inject_block state.global_state.cctxt ~force:state.global_state.config.force @@ -859,6 +907,7 @@ let compute_round proposal round_durations = let open Baking_state in let timestamp = Time.System.now () |> Time.System.to_protocol in let predecessor_block = proposal.predecessor in + Baking_profiler.record_f "compute round" @@ fun () -> Environment.wrap_tzresult @@ Alpha_context.Round.round_of_timestamp round_durations @@ -883,6 +932,7 @@ let update_to_level state level_update = if Int32.(new_level = succ state.level_state.current_level) then return state.level_state.next_level_delegate_slots else + Baking_profiler.record_s "compute predecessor delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -890,6 +940,7 @@ let update_to_level state level_update = ~chain in let* next_level_delegate_slots = + Baking_profiler.record_s "compute current delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -991,25 +1042,31 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> + Baking_profiler.record_s "inject preattestations" @@ fun () -> let* () = inject_consensus_vote state signed_preattestation in (* Here, we do not need to wait for the prequorum, it has already been triggered by the [Prepare_(preattestation|consensus_votes)] action *) return state | Inject_attestations {signed_attestations} -> + Baking_profiler.record_s "inject attestations" @@ fun () -> let* () = inject_consensus_votes state signed_attestations in (* We wait for attestations to trigger the [Quorum_reached] event *) perform_action state Watch_quorum | Update_to_level level_update -> + Baking_profiler.record_s "update to level" @@ fun () -> let* new_state, new_action = update_to_level state level_update in perform_action new_state new_action | Synchronize_round round_update -> + Baking_profiler.record_s "synchronize round" @@ fun () -> let* new_state, new_action = synchronize_round state round_update in perform_action new_state new_action | Watch_prequorum -> + Baking_profiler.record_s "wait for preattestation quorum" @@ fun () -> let*! () = start_waiting_for_preattestation_quorum state in return state | Watch_quorum -> + Baking_profiler.record_s "wait for attestation quorum" @@ fun () -> let*! () = start_waiting_for_attestation_quorum state in return state diff --git a/src/proto_alpha/lib_delegate/baking_nonces.ml b/src/proto_alpha/lib_delegate/baking_nonces.ml index 7d38c52f8db9..3229a761a36d 100644 --- a/src/proto_alpha/lib_delegate/baking_nonces.ml +++ b/src/proto_alpha/lib_delegate/baking_nonces.ml @@ -28,6 +28,8 @@ open Protocol open Alpha_context module Events = Baking_events.Nonces +module Profiler = (val Profiler.wrap Baking_profiler.nonce_profiler) + type state = { cctxt : Protocol_client_context.full; chain : Chain_services.chain; @@ -480,8 +482,12 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) + Profiler.record "waiting lock" ; cctxt#with_lock @@ fun () -> - let*! nonces = load cctxt ~stateful_location in + let*! nonces = + Profiler.record_s "load nonce file" @@ fun () -> + load cctxt ~stateful_location + in match nonces with | Error err -> let*! () = Events.(emit cannot_read_nonces err) in @@ -491,6 +497,7 @@ let reveal_potential_nonces state new_proposal = Plugin.RPC.current_level cctxt (chain, `Head 0) in let*! partitioned_nonces = + Profiler.record_s "get unrevealed nonces" @@ fun () -> partition_unrevealed_nonces state nonces cycle level in match partitioned_nonces with @@ -570,6 +577,7 @@ let start_revelation_worker cctxt config chain_id constants block_stream = format. *) let* () = try_migrate_legacy_nonces state in + let last_proposal = ref None in let rec worker_loop () = Lwt_canceler.on_cancel canceler (fun () -> should_shutdown := true ; @@ -581,9 +589,16 @@ let start_revelation_worker cctxt config chain_id constants block_stream = with the node was interrupted: exit *) return_unit | Some new_proposal -> + Option.iter (fun _ -> Profiler.stop ()) !last_proposal ; + Profiler.record + (Block_hash.to_b58check new_proposal.Baking_state.block.hash) ; + last_proposal := Some new_proposal.Baking_state.block.hash ; if !should_shutdown then return_unit else - let* _ = reveal_potential_nonces state new_proposal in + let* _ = + Profiler.record_s "reveal potential nonces" @@ fun () -> + reveal_potential_nonces state new_proposal + in worker_loop () in Lwt.dont_wait diff --git a/src/proto_alpha/lib_delegate/baking_profiler.ml b/src/proto_alpha/lib_delegate/baking_profiler.ml new file mode 100644 index 000000000000..f3cf98af7244 --- /dev/null +++ b/src/proto_alpha/lib_delegate/baking_profiler.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Profiler + +let nonce_profiler = unplugged () + +let operation_worker_profiler = unplugged () + +let node_rpc_profiler = unplugged () + +let profiler = unplugged () + +let init profiler_maker = + let baker_instance = profiler_maker ~name:"baker" in + plug profiler baker_instance ; + plug Tezos_protocol_environment.Environment_profiler.profiler baker_instance ; + plug nonce_profiler (profiler_maker ~name:"nonce") ; + plug node_rpc_profiler (profiler_maker ~name:"node_rpc") ; + plug operation_worker_profiler (profiler_maker ~name:"op_worker") + +let create_reset_block_section profiler = + let last_block = ref None in + fun b -> + match !last_block with + | None -> + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + | Some b' when Block_hash.equal b' b -> () + | Some _ -> + stop profiler ; + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + +include (val wrap profiler) diff --git a/src/proto_alpha/lib_delegate/baking_scheduling.ml b/src/proto_alpha/lib_delegate/baking_scheduling.ml index b9d0b5091ca7..50ca88a5b459 100644 --- a/src/proto_alpha/lib_delegate/baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/baking_scheduling.ml @@ -581,8 +581,14 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t (* TODO: https://gitlab.com/tezos/tezos/-/issues/7390 re-use what has been done in round_synchronizer.ml *) (* Compute the timestamp of the next possible round. *) - let next_round = compute_next_round_time state in - let*! next_baking = compute_next_potential_baking_time_at_next_level state in + let next_round = + Baking_profiler.record_f "compute next round time" @@ fun () -> + compute_next_round_time state + in + let*! next_baking = + Baking_profiler.record_s "compute next potential baking time" @@ fun () -> + compute_next_potential_baking_time_at_next_level state + in match (next_round, next_baking) with | None, None -> let*! () = Events.(emit waiting_for_new_head ()) in @@ -821,6 +827,27 @@ let compute_bootstrap_event state = in return @@ Baking_state.Timeout (End_of_round {ending_round}) +let may_reset_profiler = + let prev_head = ref None in + let () = + at_exit (fun () -> + Option.iter (fun _ -> Baking_profiler.stop ()) !prev_head) + in + function + | Baking_state.New_head_proposal proposal + | Baking_state.New_valid_proposal proposal -> ( + let curr_head_hash = proposal.block.hash in + match !prev_head with + | None -> + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | Some prev_head_hash when prev_head_hash <> curr_head_hash -> + Baking_profiler.stop () ; + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | _ -> ()) + | _ -> () + let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error loop_state state event = let open Lwt_result_syntax in @@ -830,10 +857,25 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error Baking_state.may_record_new_state ~previous_state:state ~new_state | Baking_configuration.Memory -> return_unit in - let*! state', action = State_transitions.step state event in + may_reset_profiler event ; + let*! state', action = + Format.kasprintf + Baking_profiler.record_s + "do step with event '%a'" + pp_short_event + event + @@ fun () -> State_transitions.step state event + in let* state'' = let*! state_res = - let* state'' = Baking_actions.perform_action state' action in + let* state'' = + Format.kasprintf + Baking_profiler.record_s + "perform action '%a'" + Baking_actions.pp_action + action + @@ fun () -> Baking_actions.perform_action state' action + in let* () = may_record_new_state ~previous_state:state ~new_state:state'' in return state'' in @@ -846,7 +888,10 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error let*! _ = state_recorder ~new_state:state' in return state' in - let* next_timeout = compute_next_timeout state'' in + let* next_timeout = + Baking_profiler.record_s "compute next timeout" @@ fun () -> + compute_next_timeout state'' + in let* event_opt = wait_next_event ~timeout: @@ -1021,6 +1066,8 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in + Baking_profiler.stop () ; + may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> let*! _ = Option.iter_es Lwt_canceler.cancel canceler in diff --git a/src/proto_alpha/lib_delegate/baking_simulator.ml b/src/proto_alpha/lib_delegate/baking_simulator.ml index a2e47c559bd2..0c2d4b173d19 100644 --- a/src/proto_alpha/lib_delegate/baking_simulator.ml +++ b/src/proto_alpha/lib_delegate/baking_simulator.ml @@ -43,6 +43,7 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) pred_block chain_id = let open Lwt_result_syntax in + Baking_profiler.record_s "begin construction" @@ fun () -> protect (fun () -> let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in let*! context_opt = @@ -116,6 +117,7 @@ let add_operation st (op : Operation.packed) = let validation_state, application_state = st.state in let oph = Operation.hash_packed op in let** validation_state = + Baking_profiler.aggregate_s "validating operation" @@ fun () -> Protocol.validate_operation ~check_signature:false (* We assume that the operation has already been validated in the @@ -130,6 +132,7 @@ let add_operation st (op : Operation.packed) = match application_state with | Some application_state -> let* application_state, receipt = + Baking_profiler.aggregate_s "applying operation" @@ fun () -> Protocol.apply_operation application_state oph op in return (Some application_state, Some receipt) diff --git a/src/proto_alpha/lib_delegate/baking_state.ml b/src/proto_alpha/lib_delegate/baking_state.ml index fb1384c1c727..6b45d49d0532 100644 --- a/src/proto_alpha/lib_delegate/baking_state.ml +++ b/src/proto_alpha/lib_delegate/baking_state.ml @@ -795,6 +795,7 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in + Baking_profiler.record_s "record state" @@ fun () -> let cctxt = state.global_state.cctxt in let location = Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State @@ -803,17 +804,21 @@ let record_state (state : state) = Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) in protect @@ fun () -> + Baking_profiler.record "waiting lock" ; cctxt#with_lock @@ fun () -> + Baking_profiler.stop () ; let level_data = state.level_state.current_level in let locked_round_data = state.level_state.locked_round in let attestable_payload_data = state.level_state.attestable_payload in let bytes = + Baking_profiler.record_f "serializing baking state" @@ fun () -> Data_encoding.Binary.to_bytes_exn state_data_encoding {level_data; locked_round_data; attestable_payload_data} in let filename_tmp = filename ^ "_tmp" in let*! () = + Baking_profiler.record_s "writing baking state" @@ fun () -> Lwt_io.with_file ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] ~mode:Output @@ -1390,3 +1395,13 @@ let pp_event fmt = function Format.fprintf fmt "new forge event: %a" pp_forge_event forge_event | Timeout kind -> Format.fprintf fmt "timeout reached: %a" pp_timeout_kind kind + +let pp_short_event fmt = + let open Format in + function + | New_valid_proposal _ -> fprintf fmt "new valid proposal" + | New_head_proposal _ -> fprintf fmt "new head proposal" + | Prequorum_reached (_, _) -> fprintf fmt "prequorum reached" + | Quorum_reached (_, _) -> fprintf fmt "quorum reached" + | Timeout _ -> fprintf fmt "timeout" + | New_forge_event _ -> fprintf fmt "new forge event" diff --git a/src/proto_alpha/lib_delegate/baking_state.mli b/src/proto_alpha/lib_delegate/baking_state.mli index 689b85c0b009..5ecb460fd8e4 100644 --- a/src/proto_alpha/lib_delegate/baking_state.mli +++ b/src/proto_alpha/lib_delegate/baking_state.mli @@ -409,4 +409,6 @@ val pp_timeout_kind : Format.formatter -> timeout_kind -> unit val pp_event : Format.formatter -> event -> unit +val pp_short_event : Format.formatter -> event -> unit + val pp_forge_event : Format.formatter -> forge_event -> unit diff --git a/src/proto_alpha/lib_delegate/block_forge.ml b/src/proto_alpha/lib_delegate/block_forge.ml index 7338ce67d0db..49b0e5ae88c0 100644 --- a/src/proto_alpha/lib_delegate/block_forge.ml +++ b/src/proto_alpha/lib_delegate/block_forge.ml @@ -249,6 +249,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -260,6 +261,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block in let operations = List.map (List.map convert_operation) operations in let payload_hash = + Baking_profiler.record_f "compute payload hash" @@ fun () -> let operation_hashes = Stdlib.List.tl operations |> List.flatten |> List.map Tezos_base.Operation.hash @@ -300,6 +302,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades ~context_index ~payload_hash cctxt = let open Lwt_result_syntax in let* incremental = + Baking_profiler.record_s "begin construction" @@ fun () -> Baking_simulator.begin_construction ~timestamp ~protocol_data:faked_protocol_data @@ -312,12 +315,14 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (* We still need to filter attestations. Two attestations could be referring to the same slot. *) let* incremental, ordered_pool = + Baking_profiler.record_s "filter consensus operations" @@ fun () -> Operation_selection.filter_consensus_operations_only incremental ordered_pool in let operations = Operation_pool.ordered_to_list_list ordered_pool in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -329,7 +334,10 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades let incremental = {incremental with header = {incremental.header with operations_hash}} in - let* validation_result = Baking_simulator.finalize_construction incremental in + let* validation_result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction incremental + in let validation_result = Option.map fst validation_result in let* changed = check_protocol_changed @@ -362,6 +370,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -391,6 +400,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id (* We cannot include operations that are not live with respect to our predecessor otherwise the node would reject the block. *) let filtered_pool = + Baking_profiler.record_f "filter non live operations" @@ fun () -> retain_live_operations_only ~live_blocks:pred_live_blocks operation_pool @@ -409,6 +419,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter via node" @@ fun () -> filter_via_node ~chain_id ~faked_protocol_data @@ -429,6 +440,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply via node" @@ fun () -> apply_via_node ~chain_id ~faked_protocol_data @@ -446,6 +458,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter with context" @@ fun () -> filter_with_context ~chain_id ~faked_protocol_data @@ -471,6 +484,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply with context" @@ fun () -> apply_with_context ~chain_id ~faked_protocol_data @@ -486,6 +500,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id cctxt in let* contents = + Baking_profiler.record_s "compute proof of work" @@ fun () -> Baking_pow.mine ~proof_of_work_threshold:constants.proof_of_work_threshold shell_header diff --git a/src/proto_alpha/lib_delegate/client_daemon.ml b/src/proto_alpha/lib_delegate/client_daemon.ml index a51235b8547b..5231886132f0 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.ml +++ b/src/proto_alpha/lib_delegate/client_daemon.ml @@ -56,6 +56,23 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with + | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let profiler_maker ~name = + Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker + | _ -> () + module Baker = struct let run (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes @@ -134,6 +151,8 @@ module Baker = struct let*! _ = Lwt_canceler.cancel canceler in Lwt.return_unit) in + let () = may_start_profiler cctxt#get_base_dir in + Baking_profiler.record "initialization" ; let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_alpha/lib_delegate/node_rpc.ml b/src/proto_alpha/lib_delegate/node_rpc.ml index 8538f928049f..c2bb081db7e0 100644 --- a/src/proto_alpha/lib_delegate/node_rpc.ml +++ b/src/proto_alpha/lib_delegate/node_rpc.ml @@ -30,6 +30,13 @@ open Baking_state module Block_services = Block_services.Make (Protocol) (Protocol) module Events = Baking_events.Node_rpc +module Profiler = struct + include (val Profiler.wrap Baking_profiler.node_rpc_profiler) + + let reset_block_section = + Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler +end + let inject_block cctxt ?(force = false) ~chain signed_block_header operations = let signed_shell_header_bytes = Data_encoding.Binary.to_bytes_exn Block_header.encoding signed_block_header @@ -99,6 +106,7 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = + Profiler.record_f "operations classification" @@ fun () -> WithExceptions.Option.get ~loc:__LOC__ (Operation_pool.extract_operations_of_list_list operations) @@ -121,11 +129,19 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash block_header = let open Lwt_result_syntax in + Profiler.record_s + ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info") + @@ fun () -> let* operations = match operations with | None when not in_protocol -> return_nil | None -> let open Protocol_client_context in + Profiler.record_s + ("retrieve block " + ^ Block_hash.to_short_b58check block_hash + ^ " operations") + @@ fun () -> let* operations = Alpha_block_services.Operations.operations cctxt @@ -146,13 +162,23 @@ let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash | Some operations -> let parse_op (raw_op : Tezos_base.Operation.t) = let protocol_data = + Profiler.aggregate_f "parse operation" @@ fun () -> Data_encoding.Binary.of_bytes_exn Operation.protocol_data_encoding raw_op.proto in {shell = raw_op.shell; protocol_data} in - protect @@ fun () -> return (List.map (List.map parse_op) operations) + protect @@ fun () -> + return + (List.mapi + (fun i -> function + | [] -> [] + | l -> + Profiler.record_f + (Printf.sprintf "parse operations (pass:%d)" i) + @@ fun () -> List.map parse_op l) + operations) in let*? block_info = info_of_header_and_ops ~in_protocol block_hash block_header operations @@ -170,14 +196,27 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* is_proposal_in_protocol, predecessor = match predecessor_opt with | Some predecessor -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_hit"; + ] ; return ( predecessor.shell.proto_level = block_header.shell.proto_level, predecessor ) | None -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_miss"; + ] ; let* { current_protocol = pred_current_protocol; next_protocol = pred_next_protocol; } = + Profiler.record_s "pred block protocol RPC" @@ fun () -> Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () in let is_proposal_in_protocol = @@ -191,6 +230,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () in let predecessor_header = + Profiler.record_f "parse pred block header" @@ fun () -> Data_encoding.Binary.of_bytes_exn Tezos_base.Block_header.encoding raw_header_b @@ -212,8 +252,17 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain in let* block = match block_opt with - | Some pi -> return pi + | Some pi -> + Profiler.mark + ["new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"] ; + return pi | None -> + Profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ] ; let* pi = compute_block_info cctxt @@ -229,6 +278,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain return {block; predecessor} let proposal cctxt ?cache ?operations ~chain block_hash block_header = + Profiler.record_s "proposal_computation" @@ fun () -> protect @@ fun () -> proposal cctxt ?cache ?operations ~chain block_hash block_header @@ -240,6 +290,8 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received valid proposal" @@ fun () -> let*! map_result = proposal cctxt ?cache ~operations ~chain block_hash block_header in @@ -261,6 +313,8 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received new head" @@ fun () -> let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in match map_result with | Ok proposal -> Lwt.return_some proposal diff --git a/src/proto_alpha/lib_delegate/operation_selection.ml b/src/proto_alpha/lib_delegate/operation_selection.ml index d83f7c55369a..c9ce27b90f79 100644 --- a/src/proto_alpha/lib_delegate/operation_selection.ml +++ b/src/proto_alpha/lib_delegate/operation_selection.ml @@ -181,6 +181,8 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( + Baking_profiler.record_f "checking operation receipt roundtrip" + @@ fun () -> (* Check that the metadata are serializable/deserializable *) let encoding_result = let enc = Protocol.operation_receipt_encoding in @@ -218,7 +220,9 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = max_op ; let* inc'_opt = validate_operation inc op in match inc'_opt with - | None -> return (inc, curr_size, nb_ops, acc) + | None -> + Baking_profiler.mark ["invalid operation filtered"] ; + return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) ops @@ -277,22 +281,26 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = + Baking_profiler.record_s "simulate and filter consensus" @@ fun () -> filter_valid_operations_up_to_quota initial_inc (Prioritized_operation_set.operations consensus, consensus_quota) in let*! inc, votes = + Baking_profiler.record_s "simulate and filter votes" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations votes, votes_quota) in let*! inc, anonymous = + Baking_profiler.record_s "simulate and filter anonymous" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations anonymous, anonymous_quota) in (* Sort the managers *) let prioritized_managers = + Baking_profiler.record_f "prioritize managers" @@ fun () -> prioritize_managers ~hard_gas_limit_per_block ~minimal_fees @@ -301,6 +309,7 @@ let filter_operations_with_simulation initial_inc fees_config managers in let*! inc, managers = + Baking_profiler.record_s "simulate and filter managers" @@ fun () -> filter_valid_managers_up_to_quota inc ~hard_gas_limit_per_block @@ -308,6 +317,7 @@ let filter_operations_with_simulation initial_inc fees_config in let operations = [consensus; votes; anonymous; managers] in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -315,7 +325,10 @@ let filter_operations_with_simulation initial_inc fees_config operations) in let inc = {inc with header = {inc.header with operations_hash}} in - let* result = Baking_simulator.finalize_construction inc in + let* result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction inc + in match result with | Some (validation_result, block_header_metadata) -> return diff --git a/src/proto_beta/lib_delegate/baking_actions.ml b/src/proto_beta/lib_delegate/baking_actions.ml index 3157d35a39d1..80a0e6ab686d 100644 --- a/src/proto_beta/lib_delegate/baking_actions.ml +++ b/src/proto_beta/lib_delegate/baking_actions.ml @@ -44,6 +44,7 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( + Baking_profiler.record_s "retrieve external operations" @@ fun () -> let fail reason details = let path = match operations with @@ -187,6 +188,7 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = + Baking_profiler.record_f "serializing" @@ fun () -> Data_encoding.Binary.to_bytes_exn Alpha_context.Block_header.unsigned_encoding (shell, contents) @@ -194,12 +196,15 @@ let sign_block_header global_state proposer unsigned_block_header = let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in + Baking_profiler.record "waiting for lockfile" ; let* result = cctxt#with_lock (fun () -> + Baking_profiler.stop () ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = + Baking_profiler.record_s "check highwatermark" @@ fun () -> may_sign_block cctxt block_location @@ -210,6 +215,7 @@ let sign_block_header global_state proposer unsigned_block_header = match may_sign with | true -> let* () = + Baking_profiler.record_s "record highwatermark" @@ fun () -> record_block cctxt block_location @@ -226,6 +232,7 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = + Baking_profiler.record_s "signing block" @@ fun () -> Client_keys.sign cctxt proposer.secret_key_uri @@ -257,6 +264,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let simulation_mode = global_state.validation_mode in let round_durations = global_state.round_durations in let*? timestamp = + Baking_profiler.record_f "timestamp of round" @@ fun () -> Environment.wrap_tzresult (Round.timestamp_of_round round_durations @@ -293,12 +301,14 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) in let* injection_level = + Baking_profiler.record_s "retrieve injection level" @@ fun () -> Plugin.RPC.current_level cctxt ~offset:1l (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) in let* seed_nonce_opt = + Baking_profiler.record_s "generate seed nonce" @@ fun () -> generate_seed_nonce_hash global_state.config.Baking_configuration.nonce consensus_key @@ -334,6 +344,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let chain = `Hash global_state.chain_id in let pred_block = `Hash (predecessor.hash, 0) in let* pred_resulting_context_hash = + Baking_profiler.record_s "retrieve resulting context hash" @@ fun () -> Shell_services.Blocks.resulting_context_hash cctxt ~chain @@ -341,6 +352,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) () in let* pred_live_blocks = + Baking_profiler.record_s "retrieve live blocks" @@ fun () -> Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () in let* {unsigned_block_header; operations} = @@ -364,6 +376,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = + Baking_profiler.record_s "sign block header" @@ fun () -> sign_block_header global_state consensus_key unsigned_block_header in let* () = @@ -373,6 +386,7 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) return_unit | Some (_, nonce) -> let block_hash = Block_header.hash signed_block_header in + Baking_profiler.record_s "register nonce" @@ fun () -> Baking_nonces.register_nonce cctxt ~chain_id @@ -548,8 +562,20 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = + Baking_profiler.record_s + (Format.sprintf + "filter consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> + Baking_profiler.record "wait for lock" ; cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in + Baking_profiler.stop () ; + let* highwatermarks = + Baking_profiler.record_s "load highwatermarks" @@ fun () -> + Baking_highwatermarks.load cctxt block_location + in let authorized_votes, unauthorized_votes = List.partition (fun consensus_vote -> @@ -569,6 +595,13 @@ let authorized_consensus_votes global_state in (* We exit the client's lock as soon as this function returns *) let* () = + Baking_profiler.record_s + (Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> record_all_consensus_vote highwatermarks cctxt @@ -649,6 +682,13 @@ let sign_consensus_votes (global_state : global_state) unsigned_consensus_vote) -> let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in let*! signed_consensus_vote_r = + Baking_profiler.record_s + (Format.sprintf + "forge and sign consensus vote: %s" + (match vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> forge_and_sign_consensus_vote global_state ~branch:batch_branch @@ -702,6 +742,13 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = + Baking_profiler.record_s + (Format.sprintf + "injecting consensus vote: %s" + (match unsigned_consensus_vote.vote_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")) + @@ fun () -> Node_rpc.inject_operation cctxt ~chain:(`Hash chain_id) @@ -752,6 +799,7 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = + Baking_profiler.record_s "inject block to node" @@ fun () -> Node_rpc.inject_block state.global_state.cctxt ~force:state.global_state.config.force @@ -857,6 +905,7 @@ let compute_round proposal round_durations = let open Baking_state in let timestamp = Time.System.now () |> Time.System.to_protocol in let predecessor_block = proposal.predecessor in + Baking_profiler.record_f "compute round" @@ fun () -> Environment.wrap_tzresult @@ Alpha_context.Round.round_of_timestamp round_durations @@ -881,6 +930,7 @@ let update_to_level state level_update = if Int32.(new_level = succ state.level_state.current_level) then return state.level_state.next_level_delegate_slots else + Baking_profiler.record_s "compute predecessor delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -888,6 +938,7 @@ let update_to_level state level_update = ~chain in let* next_level_delegate_slots = + Baking_profiler.record_s "compute current delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates @@ -989,25 +1040,31 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> + Baking_profiler.record_s "inject preattestations" @@ fun () -> let* () = inject_consensus_vote state signed_preattestation in (* Here, we do not need to wait for the prequorum, it has already been triggered by the [Prepare_(preattestation|consensus_votes)] action *) return state | Inject_attestations {signed_attestations} -> + Baking_profiler.record_s "inject attestations" @@ fun () -> let* () = inject_consensus_votes state signed_attestations in (* We wait for attestations to trigger the [Quorum_reached] event *) perform_action state Watch_quorum | Update_to_level level_update -> + Baking_profiler.record_s "update to level" @@ fun () -> let* new_state, new_action = update_to_level state level_update in perform_action new_state new_action | Synchronize_round round_update -> + Baking_profiler.record_s "synchronize round" @@ fun () -> let* new_state, new_action = synchronize_round state round_update in perform_action new_state new_action | Watch_prequorum -> + Baking_profiler.record_s "wait for preattestation quorum" @@ fun () -> let*! () = start_waiting_for_preattestation_quorum state in return state | Watch_quorum -> + Baking_profiler.record_s "wait for attestation quorum" @@ fun () -> let*! () = start_waiting_for_attestation_quorum state in return state diff --git a/src/proto_beta/lib_delegate/baking_profiler.ml b/src/proto_beta/lib_delegate/baking_profiler.ml new file mode 100644 index 000000000000..f3cf98af7244 --- /dev/null +++ b/src/proto_beta/lib_delegate/baking_profiler.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Profiler + +let nonce_profiler = unplugged () + +let operation_worker_profiler = unplugged () + +let node_rpc_profiler = unplugged () + +let profiler = unplugged () + +let init profiler_maker = + let baker_instance = profiler_maker ~name:"baker" in + plug profiler baker_instance ; + plug Tezos_protocol_environment.Environment_profiler.profiler baker_instance ; + plug nonce_profiler (profiler_maker ~name:"nonce") ; + plug node_rpc_profiler (profiler_maker ~name:"node_rpc") ; + plug operation_worker_profiler (profiler_maker ~name:"op_worker") + +let create_reset_block_section profiler = + let last_block = ref None in + fun b -> + match !last_block with + | None -> + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + | Some b' when Block_hash.equal b' b -> () + | Some _ -> + stop profiler ; + record profiler (Block_hash.to_b58check b) ; + last_block := Some b + +include (val wrap profiler) diff --git a/src/proto_beta/lib_delegate/baking_scheduling.ml b/src/proto_beta/lib_delegate/baking_scheduling.ml index 208fb1426d06..64b8b6dda565 100644 --- a/src/proto_beta/lib_delegate/baking_scheduling.ml +++ b/src/proto_beta/lib_delegate/baking_scheduling.ml @@ -577,8 +577,14 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t in (* TODO: re-use what has been done in round_synchronizer.ml *) (* Compute the timestamp of the next possible round. *) - let next_round = compute_next_round_time state in - let*! next_baking = compute_next_potential_baking_time_at_next_level state in + let next_round = + Baking_profiler.record_f "compute next round time" @@ fun () -> + compute_next_round_time state + in + let*! next_baking = + Baking_profiler.record_s "compute next potential baking time" @@ fun () -> + compute_next_potential_baking_time_at_next_level state + in match (next_round, next_baking) with | None, None -> let*! () = Events.(emit waiting_for_new_head ()) in @@ -816,6 +822,27 @@ let compute_bootstrap_event state = in return @@ Baking_state.Timeout (End_of_round {ending_round}) +let may_reset_profiler = + let prev_head = ref None in + let () = + at_exit (fun () -> + Option.iter (fun _ -> Baking_profiler.stop ()) !prev_head) + in + function + | Baking_state.New_head_proposal proposal + | Baking_state.New_valid_proposal proposal -> ( + let curr_head_hash = proposal.block.hash in + match !prev_head with + | None -> + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | Some prev_head_hash when prev_head_hash <> curr_head_hash -> + Baking_profiler.stop () ; + Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + prev_head := Some curr_head_hash + | _ -> ()) + | _ -> () + let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error loop_state state event = let open Lwt_result_syntax in @@ -825,10 +852,25 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error Baking_state.may_record_new_state ~previous_state:state ~new_state | Baking_configuration.Memory -> return_unit in - let*! state', action = State_transitions.step state event in + may_reset_profiler event ; + let*! state', action = + Format.kasprintf + Baking_profiler.record_s + "do step with event '%a'" + pp_short_event + event + @@ fun () -> State_transitions.step state event + in let* state'' = let*! state_res = - let* state'' = Baking_actions.perform_action state' action in + let* state'' = + Format.kasprintf + Baking_profiler.record_s + "perform action '%a'" + Baking_actions.pp_action + action + @@ fun () -> Baking_actions.perform_action state' action + in let* () = may_record_new_state ~previous_state:state ~new_state:state'' in return state'' in @@ -841,7 +883,10 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error let*! _ = state_recorder ~new_state:state' in return state' in - let* next_timeout = compute_next_timeout state'' in + let* next_timeout = + Baking_profiler.record_s "compute next timeout" @@ fun () -> + compute_next_timeout state'' + in let* event_opt = wait_next_event ~timeout: @@ -1020,6 +1065,8 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in + Baking_profiler.stop () ; + may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> let*! _ = Option.iter_es Lwt_canceler.cancel canceler in diff --git a/src/proto_beta/lib_delegate/baking_simulator.ml b/src/proto_beta/lib_delegate/baking_simulator.ml index a2e47c559bd2..0c2d4b173d19 100644 --- a/src/proto_beta/lib_delegate/baking_simulator.ml +++ b/src/proto_beta/lib_delegate/baking_simulator.ml @@ -43,6 +43,7 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) pred_block chain_id = let open Lwt_result_syntax in + Baking_profiler.record_s "begin construction" @@ fun () -> protect (fun () -> let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in let*! context_opt = @@ -116,6 +117,7 @@ let add_operation st (op : Operation.packed) = let validation_state, application_state = st.state in let oph = Operation.hash_packed op in let** validation_state = + Baking_profiler.aggregate_s "validating operation" @@ fun () -> Protocol.validate_operation ~check_signature:false (* We assume that the operation has already been validated in the @@ -130,6 +132,7 @@ let add_operation st (op : Operation.packed) = match application_state with | Some application_state -> let* application_state, receipt = + Baking_profiler.aggregate_s "applying operation" @@ fun () -> Protocol.apply_operation application_state oph op in return (Some application_state, Some receipt) diff --git a/src/proto_beta/lib_delegate/baking_state.ml b/src/proto_beta/lib_delegate/baking_state.ml index fb1384c1c727..6b45d49d0532 100644 --- a/src/proto_beta/lib_delegate/baking_state.ml +++ b/src/proto_beta/lib_delegate/baking_state.ml @@ -795,6 +795,7 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in + Baking_profiler.record_s "record state" @@ fun () -> let cctxt = state.global_state.cctxt in let location = Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State @@ -803,17 +804,21 @@ let record_state (state : state) = Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) in protect @@ fun () -> + Baking_profiler.record "waiting lock" ; cctxt#with_lock @@ fun () -> + Baking_profiler.stop () ; let level_data = state.level_state.current_level in let locked_round_data = state.level_state.locked_round in let attestable_payload_data = state.level_state.attestable_payload in let bytes = + Baking_profiler.record_f "serializing baking state" @@ fun () -> Data_encoding.Binary.to_bytes_exn state_data_encoding {level_data; locked_round_data; attestable_payload_data} in let filename_tmp = filename ^ "_tmp" in let*! () = + Baking_profiler.record_s "writing baking state" @@ fun () -> Lwt_io.with_file ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] ~mode:Output @@ -1390,3 +1395,13 @@ let pp_event fmt = function Format.fprintf fmt "new forge event: %a" pp_forge_event forge_event | Timeout kind -> Format.fprintf fmt "timeout reached: %a" pp_timeout_kind kind + +let pp_short_event fmt = + let open Format in + function + | New_valid_proposal _ -> fprintf fmt "new valid proposal" + | New_head_proposal _ -> fprintf fmt "new head proposal" + | Prequorum_reached (_, _) -> fprintf fmt "prequorum reached" + | Quorum_reached (_, _) -> fprintf fmt "quorum reached" + | Timeout _ -> fprintf fmt "timeout" + | New_forge_event _ -> fprintf fmt "new forge event" diff --git a/src/proto_beta/lib_delegate/baking_state.mli b/src/proto_beta/lib_delegate/baking_state.mli index 689b85c0b009..5ecb460fd8e4 100644 --- a/src/proto_beta/lib_delegate/baking_state.mli +++ b/src/proto_beta/lib_delegate/baking_state.mli @@ -409,4 +409,6 @@ val pp_timeout_kind : Format.formatter -> timeout_kind -> unit val pp_event : Format.formatter -> event -> unit +val pp_short_event : Format.formatter -> event -> unit + val pp_forge_event : Format.formatter -> forge_event -> unit diff --git a/src/proto_beta/lib_delegate/block_forge.ml b/src/proto_beta/lib_delegate/block_forge.ml index 7338ce67d0db..49b0e5ae88c0 100644 --- a/src/proto_beta/lib_delegate/block_forge.ml +++ b/src/proto_beta/lib_delegate/block_forge.ml @@ -249,6 +249,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -260,6 +261,7 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block in let operations = List.map (List.map convert_operation) operations in let payload_hash = + Baking_profiler.record_f "compute payload hash" @@ fun () -> let operation_hashes = Stdlib.List.tl operations |> List.flatten |> List.map Tezos_base.Operation.hash @@ -300,6 +302,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades ~context_index ~payload_hash cctxt = let open Lwt_result_syntax in let* incremental = + Baking_profiler.record_s "begin construction" @@ fun () -> Baking_simulator.begin_construction ~timestamp ~protocol_data:faked_protocol_data @@ -312,12 +315,14 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (* We still need to filter attestations. Two attestations could be referring to the same slot. *) let* incremental, ordered_pool = + Baking_profiler.record_s "filter consensus operations" @@ fun () -> Operation_selection.filter_consensus_operations_only incremental ordered_pool in let operations = Operation_pool.ordered_to_list_list ordered_pool in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -329,7 +334,10 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades let incremental = {incremental with header = {incremental.header with operations_hash}} in - let* validation_result = Baking_simulator.finalize_construction incremental in + let* validation_result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction incremental + in let validation_result = Option.map fst validation_result in let* changed = check_protocol_changed @@ -362,6 +370,7 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = + Baking_profiler.record_s "finalize block header" @@ fun () -> finalize_block_header ~shell_header:incremental.header ~validation_result @@ -391,6 +400,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id (* We cannot include operations that are not live with respect to our predecessor otherwise the node would reject the block. *) let filtered_pool = + Baking_profiler.record_f "filter non live operations" @@ fun () -> retain_live_operations_only ~live_blocks:pred_live_blocks operation_pool @@ -409,6 +419,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter via node" @@ fun () -> filter_via_node ~chain_id ~faked_protocol_data @@ -429,6 +440,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply via node" @@ fun () -> apply_via_node ~chain_id ~faked_protocol_data @@ -446,6 +458,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "filter with context" @@ fun () -> filter_with_context ~chain_id ~faked_protocol_data @@ -471,6 +484,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in + Baking_profiler.record_s "apply with context" @@ fun () -> apply_with_context ~chain_id ~faked_protocol_data @@ -486,6 +500,7 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id cctxt in let* contents = + Baking_profiler.record_s "compute proof of work" @@ fun () -> Baking_pow.mine ~proof_of_work_threshold:constants.proof_of_work_threshold shell_header diff --git a/src/proto_beta/lib_delegate/client_daemon.ml b/src/proto_beta/lib_delegate/client_daemon.ml index a51235b8547b..5231886132f0 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -56,6 +56,23 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with + | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let profiler_maker ~name = + Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker + | _ -> () + module Baker = struct let run (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes @@ -134,6 +151,8 @@ module Baker = struct let*! _ = Lwt_canceler.cancel canceler in Lwt.return_unit) in + let () = may_start_profiler cctxt#get_base_dir in + Baking_profiler.record "initialization" ; let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_beta/lib_delegate/node_rpc.ml b/src/proto_beta/lib_delegate/node_rpc.ml index 8538f928049f..019289f5ae62 100644 --- a/src/proto_beta/lib_delegate/node_rpc.ml +++ b/src/proto_beta/lib_delegate/node_rpc.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2023 Marigold *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -30,6 +31,13 @@ open Baking_state module Block_services = Block_services.Make (Protocol) (Protocol) module Events = Baking_events.Node_rpc +module Profiler = struct + include (val Profiler.wrap Baking_profiler.node_rpc_profiler) + + let reset_block_section = + Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler +end + let inject_block cctxt ?(force = false) ~chain signed_block_header operations = let signed_shell_header_bytes = Data_encoding.Binary.to_bytes_exn Block_header.encoding signed_block_header @@ -99,6 +107,7 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = + Profiler.record_f "operations classification" @@ fun () -> WithExceptions.Option.get ~loc:__LOC__ (Operation_pool.extract_operations_of_list_list operations) @@ -121,11 +130,19 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash block_header = let open Lwt_result_syntax in + Profiler.record_s + ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info") + @@ fun () -> let* operations = match operations with | None when not in_protocol -> return_nil | None -> let open Protocol_client_context in + Profiler.record_s + ("retrieve block " + ^ Block_hash.to_short_b58check block_hash + ^ " operations") + @@ fun () -> let* operations = Alpha_block_services.Operations.operations cctxt @@ -146,13 +163,23 @@ let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash | Some operations -> let parse_op (raw_op : Tezos_base.Operation.t) = let protocol_data = + Profiler.aggregate_f "parse operation" @@ fun () -> Data_encoding.Binary.of_bytes_exn Operation.protocol_data_encoding raw_op.proto in {shell = raw_op.shell; protocol_data} in - protect @@ fun () -> return (List.map (List.map parse_op) operations) + protect @@ fun () -> + return + (List.mapi + (fun i -> function + | [] -> [] + | l -> + Profiler.record_f + (Printf.sprintf "parse operations (pass:%d)" i) + @@ fun () -> List.map parse_op l) + operations) in let*? block_info = info_of_header_and_ops ~in_protocol block_hash block_header operations @@ -170,14 +197,27 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* is_proposal_in_protocol, predecessor = match predecessor_opt with | Some predecessor -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_hit"; + ] ; return ( predecessor.shell.proto_level = block_header.shell.proto_level, predecessor ) | None -> + Profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_miss"; + ] ; let* { current_protocol = pred_current_protocol; next_protocol = pred_next_protocol; } = + Profiler.record_s "pred block protocol RPC" @@ fun () -> Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () in let is_proposal_in_protocol = @@ -191,6 +231,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () in let predecessor_header = + Profiler.record_f "parse pred block header" @@ fun () -> Data_encoding.Binary.of_bytes_exn Tezos_base.Block_header.encoding raw_header_b @@ -212,8 +253,17 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain in let* block = match block_opt with - | Some pi -> return pi + | Some pi -> + Profiler.mark + ["new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"] ; + return pi | None -> + Profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ] ; let* pi = compute_block_info cctxt @@ -229,6 +279,7 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain return {block; predecessor} let proposal cctxt ?cache ?operations ~chain block_hash block_header = + Profiler.record_s "proposal_computation" @@ fun () -> protect @@ fun () -> proposal cctxt ?cache ?operations ~chain block_hash block_header @@ -240,6 +291,8 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received valid proposal" @@ fun () -> let*! map_result = proposal cctxt ?cache ~operations ~chain block_hash block_header in @@ -261,6 +314,8 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = + Profiler.reset_block_section block_hash ; + Profiler.record_s "received new head" @@ fun () -> let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in match map_result with | Ok proposal -> Lwt.return_some proposal diff --git a/src/proto_beta/lib_delegate/operation_selection.ml b/src/proto_beta/lib_delegate/operation_selection.ml index d83f7c55369a..c9ce27b90f79 100644 --- a/src/proto_beta/lib_delegate/operation_selection.ml +++ b/src/proto_beta/lib_delegate/operation_selection.ml @@ -181,6 +181,8 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( + Baking_profiler.record_f "checking operation receipt roundtrip" + @@ fun () -> (* Check that the metadata are serializable/deserializable *) let encoding_result = let enc = Protocol.operation_receipt_encoding in @@ -218,7 +220,9 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = max_op ; let* inc'_opt = validate_operation inc op in match inc'_opt with - | None -> return (inc, curr_size, nb_ops, acc) + | None -> + Baking_profiler.mark ["invalid operation filtered"] ; + return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) ops @@ -277,22 +281,26 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = + Baking_profiler.record_s "simulate and filter consensus" @@ fun () -> filter_valid_operations_up_to_quota initial_inc (Prioritized_operation_set.operations consensus, consensus_quota) in let*! inc, votes = + Baking_profiler.record_s "simulate and filter votes" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations votes, votes_quota) in let*! inc, anonymous = + Baking_profiler.record_s "simulate and filter anonymous" @@ fun () -> filter_valid_operations_up_to_quota inc (Prioritized_operation_set.operations anonymous, anonymous_quota) in (* Sort the managers *) let prioritized_managers = + Baking_profiler.record_f "prioritize managers" @@ fun () -> prioritize_managers ~hard_gas_limit_per_block ~minimal_fees @@ -301,6 +309,7 @@ let filter_operations_with_simulation initial_inc fees_config managers in let*! inc, managers = + Baking_profiler.record_s "simulate and filter managers" @@ fun () -> filter_valid_managers_up_to_quota inc ~hard_gas_limit_per_block @@ -308,6 +317,7 @@ let filter_operations_with_simulation initial_inc fees_config in let operations = [consensus; votes; anonymous; managers] in let operations_hash = + Baking_profiler.record_f "compute operations merkle root" @@ fun () -> Operation_list_list_hash.compute (List.map (fun sl -> @@ -315,7 +325,10 @@ let filter_operations_with_simulation initial_inc fees_config operations) in let inc = {inc with header = {inc.header with operations_hash}} in - let* result = Baking_simulator.finalize_construction inc in + let* result = + Baking_profiler.record_s "finalize construction" @@ fun () -> + Baking_simulator.finalize_construction inc + in match result with | Some (validation_result, block_header_metadata) -> return -- GitLab From af16e9011ef7334d6c677ce88c6c1a8babc239ae Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Mon, 19 Aug 2024 17:57:40 +0200 Subject: [PATCH 14/19] Proto 20/21: whole libraries - use ppx profiler --- .../lib_delegate/baking_actions.ml | 457 +++++++++-------- .../lib_delegate/baking_nonces.ml | 34 +- .../lib_delegate/baking_scheduling.ml | 50 +- .../lib_delegate/baking_simulator.ml | 150 +++--- .../lib_delegate/baking_state.ml | 67 +-- .../lib_delegate/block_forge.ml | 229 +++++---- .../lib_delegate/client_daemon.ml | 4 +- .../lib_delegate/node_rpc.ml | 231 +++++---- .../lib_delegate/operation_selection.ml | 98 ++-- src/proto_beta/lib_delegate/baking_actions.ml | 464 +++++++++--------- src/proto_beta/lib_delegate/baking_nonces.ml | 21 +- .../lib_delegate/baking_scheduling.ml | 50 +- .../lib_delegate/baking_simulator.ml | 150 +++--- src/proto_beta/lib_delegate/baking_state.ml | 67 +-- src/proto_beta/lib_delegate/block_forge.ml | 229 +++++---- src/proto_beta/lib_delegate/client_daemon.ml | 4 +- src/proto_beta/lib_delegate/node_rpc.ml | 231 +++++---- .../lib_delegate/operation_selection.ml | 98 ++-- 18 files changed, 1342 insertions(+), 1292 deletions(-) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml index 97a9652c0e7a..5987ae1c4b50 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Baking_state module Events = Baking_events.Actions +module Profiler = Baking_profiler module Operations_source = struct type error += @@ -44,79 +45,82 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( - Baking_profiler.record_s "retrieve external operations" @@ fun () -> - let fail reason details = - let path = - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - filename - | Baking_configuration.Operations_source.Remote {uri; _} -> - Uri.to_string uri - in - tzfail (Failed_operations_fetch {path; reason; details}) - in - let decode_operations json = - protect - ~on_error:(fun _ -> - fail "cannot decode the received JSON into operations" (Some json)) - (fun () -> - return (Data_encoding.Json.destruct operations_encoding json)) - in - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - if Sys.file_exists filename then - let*! result = - Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename - in - match result with - | Error _ -> - let*! () = Events.(emit invalid_json_file filename) in - Lwt.return_none - | Ok json -> ( - let*! operations = decode_operations json in - match operations with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none) - else - let*! () = Events.(emit no_operations_found_in_file filename) in - Lwt.return_none - | Baking_configuration.Operations_source.Remote {uri; http_headers} -> ( - let*! operations_opt = - let* result = - with_timeout - (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) - (fun _ -> - Tezos_rpc_http_client_unix.RPC_client_unix - .generic_media_type_call - ~accept:[Media_type.json] - ?headers:http_headers - `GET - uri) - in - let* rest = - match result with - | `Json json -> return json - | _ -> fail "json not returned" None - in - let* json = - match rest with - | `Ok json -> return json - | `Unauthorized json -> fail "unauthorized request" json - | `Gone json -> fail "gone" json - | `Error json -> fail "error" json - | `Not_found json -> fail "not found" json - | `Forbidden json -> fail "forbidden" json - | `Conflict json -> fail "conflict" json - in - decode_operations json - in - match operations_opt with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none)) + (let fail reason details = + let path = + match operations with + | Baking_configuration.Operations_source.Local {filename} -> + filename + | Baking_configuration.Operations_source.Remote {uri; _} -> + Uri.to_string uri + in + tzfail (Failed_operations_fetch {path; reason; details}) + in + let decode_operations json = + protect + ~on_error:(fun _ -> + fail + "cannot decode the received JSON into operations" + (Some json)) + (fun () -> + return (Data_encoding.Json.destruct operations_encoding json)) + in + match operations with + | Baking_configuration.Operations_source.Local {filename} -> + if Sys.file_exists filename then + let*! result = + Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename + in + match result with + | Error _ -> + let*! () = Events.(emit invalid_json_file filename) in + Lwt.return_none + | Ok json -> ( + let*! operations = decode_operations json in + match operations with + | Ok operations -> Lwt.return_some operations + | Error errs -> + let*! () = Events.(emit cannot_fetch_operations errs) in + Lwt.return_none) + else + let*! () = Events.(emit no_operations_found_in_file filename) in + Lwt.return_none + | Baking_configuration.Operations_source.Remote {uri; http_headers} + -> ( + let*! operations_opt = + let* result = + with_timeout + (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) + (fun _ -> + Tezos_rpc_http_client_unix.RPC_client_unix + .generic_media_type_call + ~accept:[Media_type.json] + ?headers:http_headers + `GET + uri) + in + let* rest = + match result with + | `Json json -> return json + | _ -> fail "json not returned" None + in + let* json = + match rest with + | `Ok json -> return json + | `Unauthorized json -> fail "unauthorized request" json + | `Gone json -> fail "gone" json + | `Error json -> fail "error" json + | `Not_found json -> fail "not found" json + | `Forbidden json -> fail "forbidden" json + | `Conflict json -> fail "conflict" json + in + decode_operations json + in + match operations_opt with + | Ok operations -> Lwt.return_some operations + | Error errs -> + let*! () = Events.(emit cannot_fetch_operations errs) in + Lwt.return_none)) + [@profiler.record_s "retrieve external operations"]) end type action = @@ -188,40 +192,37 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = - Baking_profiler.record_f "serializing" @@ fun () -> - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.unsigned_encoding - (shell, contents) + (Data_encoding.Binary.to_bytes_exn + Alpha_context.Block_header.unsigned_encoding + (shell, contents) [@profiler.record_f "serializing"]) in let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in - Baking_profiler.record "waiting for lockfile" ; + let () = (() [@profiler.record "waiting for lockfile"]) in let* result = cctxt#with_lock (fun () -> - Baking_profiler.stop () ; + let () = (() [@profiler.stop ()]) in let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = - Baking_profiler.record_s "check highwatermark" @@ fun () -> - may_sign_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round + (may_sign_block + cctxt + block_location + ~delegate:proposer.public_key_hash + ~level + ~round [@profiler.record_s "check highwatermark"]) in match may_sign with | true -> let* () = - Baking_profiler.record_s "record highwatermark" @@ fun () -> - record_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round + (record_block + cctxt + block_location + ~delegate:proposer.public_key_hash + ~level + ~round [@profiler.record_s "record highwatermark"]) in return_true | false -> @@ -232,12 +233,11 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = - Baking_profiler.record_s "signing block" @@ fun () -> - Client_keys.sign - cctxt - proposer.secret_key_uri - ~watermark:Block_header.(to_watermark (Block_header chain_id)) - unsigned_header + (Client_keys.sign + cctxt + proposer.secret_key_uri + ~watermark:Block_header.(to_watermark (Block_header chain_id)) + unsigned_header [@profiler.record_s "signing block"]) in return {Block_header.shell; protocol_data = {contents; signature}} @@ -264,13 +264,12 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let simulation_mode = global_state.validation_mode in let round_durations = global_state.round_durations in let*? timestamp = - Baking_profiler.record_f "timestamp of round" @@ fun () -> - Environment.wrap_tzresult - (Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round) + (Environment.wrap_tzresult + (Round.timestamp_of_round + round_durations + ~predecessor_timestamp:predecessor.shell.timestamp + ~predecessor_round:predecessor.round + ~round) [@profiler.record_f "timestamp of round"]) in let external_operation_source = global_state.config.extra_operations in let*! extern_ops = Operations_source.retrieve external_operation_source in @@ -301,18 +300,17 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) in let* injection_level = - Baking_profiler.record_s "retrieve injection level" @@ fun () -> - Plugin.RPC.current_level - cctxt - ~offset:1l - (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) + (Plugin.RPC.current_level + cctxt + ~offset:1l + (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) + [@profiler.record_s "retrieve injection level"]) in let* seed_nonce_opt = - Baking_profiler.record_s "generate seed nonce" @@ fun () -> - generate_seed_nonce_hash - global_state.config.Baking_configuration.nonce - consensus_key - injection_level + (generate_seed_nonce_hash + global_state.config.Baking_configuration.nonce + consensus_key + injection_level [@profiler.record_s "generate seed nonce"]) in let seed_nonce_hash = Option.map fst seed_nonce_opt in let user_activated_upgrades = global_state.config.user_activated_upgrades in @@ -344,16 +342,18 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let chain = `Hash global_state.chain_id in let pred_block = `Hash (predecessor.hash, 0) in let* pred_resulting_context_hash = - Baking_profiler.record_s "retrieve resulting context hash" @@ fun () -> - Shell_services.Blocks.resulting_context_hash - cctxt - ~chain - ~block:pred_block - () + (Shell_services.Blocks.resulting_context_hash + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "retrieve resulting context hash"]) in let* pred_live_blocks = - Baking_profiler.record_s "retrieve live blocks" @@ fun () -> - Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () + (Chain_services.Blocks.live_blocks + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "retrieve live blocks"]) in let* {unsigned_block_header; operations} = Block_forge.forge @@ -376,8 +376,10 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = - Baking_profiler.record_s "sign block header" @@ fun () -> - sign_block_header global_state consensus_key unsigned_block_header + (sign_block_header + global_state + consensus_key + unsigned_block_header [@profiler.record_s "sign block header"]) in let* () = match seed_nonce_opt with @@ -386,15 +388,15 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) return_unit | Some (_, nonce) -> let block_hash = Block_header.hash signed_block_header in - Baking_profiler.record_s "register nonce" @@ fun () -> - Baking_nonces.register_nonce - cctxt - ~chain_id - block_hash - nonce - ~cycle:injection_level.cycle - ~level:injection_level.level - ~round + + (Baking_nonces.register_nonce + cctxt + ~chain_id + block_hash + nonce + ~cycle:injection_level.cycle + ~level:injection_level.level + ~round [@profiler.record_s "register nonce"]) in let baking_votes = {Per_block_votes.liquidity_baking_vote; adaptive_issuance_vote} @@ -562,55 +564,54 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = - Baking_profiler.record_s - (Format.sprintf + let () = (() [@profiler.record "wait for lock"]) in + (cctxt#with_lock (fun () -> + let () = (() [@profiler.stop ()]) in + let* highwatermarks = + (Baking_highwatermarks.load + cctxt + block_location [@profiler.record_s "load highwatermarks"]) + in + let authorized_votes, unauthorized_votes = + List.partition + (fun consensus_vote -> + is_authorized global_state highwatermarks consensus_vote) + unsigned_consensus_votes + in + (* Record all consensus votes new highwatermarks as one batch *) + let delegates = + List.map + (fun {delegate = ck, _; _} -> ck.public_key_hash) + authorized_votes + in + let record_all_consensus_vote = + match batch_kind with + | Preattestation -> Baking_highwatermarks.record_all_preattestations + | Attestation -> Baking_highwatermarks.record_all_attestations + in + (* We exit the client's lock as soon as this function returns *) + let* () = + (record_all_consensus_vote + highwatermarks + cctxt + block_location + ~delegates + ~level + ~round + [@profiler.record_s + Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")]) + in + return (authorized_votes, unauthorized_votes)) + [@profiler.record_s + Format.sprintf "filter consensus votes: %s" (match batch_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - Baking_profiler.record "wait for lock" ; - cctxt#with_lock (fun () -> - Baking_profiler.stop () ; - let* highwatermarks = - Baking_profiler.record_s "load highwatermarks" @@ fun () -> - Baking_highwatermarks.load cctxt block_location - in - let authorized_votes, unauthorized_votes = - List.partition - (fun consensus_vote -> - is_authorized global_state highwatermarks consensus_vote) - unsigned_consensus_votes - in - (* Record all consensus votes new highwatermarks as one batch *) - let delegates = - List.map - (fun {delegate = ck, _; _} -> ck.public_key_hash) - authorized_votes - in - let record_all_consensus_vote = - match batch_kind with - | Preattestation -> Baking_highwatermarks.record_all_preattestations - | Attestation -> Baking_highwatermarks.record_all_attestations - in - (* We exit the client's lock as soon as this function returns *) - let* () = - Baking_profiler.record_s - (Format.sprintf - "record consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - in - return (authorized_votes, unauthorized_votes)) + | Attestation -> "attestation")]) in let*! () = List.iter_s @@ -682,17 +683,16 @@ let sign_consensus_votes (global_state : global_state) unsigned_consensus_vote) -> let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in let*! signed_consensus_vote_r = - Baking_profiler.record_s - (Format.sprintf + (forge_and_sign_consensus_vote + global_state + ~branch:batch_branch + unsigned_consensus_vote + [@profiler.record_s + Format.sprintf "forge and sign consensus vote: %s" (match vote_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - forge_and_sign_consensus_vote - global_state - ~branch:batch_branch - unsigned_consensus_vote + | Attestation -> "attestation")]) in match signed_consensus_vote_r with | Error err -> @@ -742,17 +742,16 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = - Baking_profiler.record_s - (Format.sprintf + (Node_rpc.inject_operation + cctxt + ~chain:(`Hash chain_id) + signed_consensus_vote.signed_operation + [@profiler.record_s + Format.sprintf "injecting consensus vote: %s" (match unsigned_consensus_vote.vote_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - Node_rpc.inject_operation - cctxt - ~chain:(`Hash chain_id) - signed_consensus_vote.signed_operation + | Attestation -> "attestation")]) in let*! () = Events.( @@ -799,13 +798,12 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = - Baking_profiler.record_s "inject block to node" @@ fun () -> - Node_rpc.inject_block - state.global_state.cctxt - ~force:state.global_state.config.force - ~chain:(`Hash state.global_state.chain_id) - signed_block_header - operations + (Node_rpc.inject_block + state.global_state.cctxt + ~force:state.global_state.config.force + ~chain:(`Hash state.global_state.chain_id) + signed_block_header + operations [@profiler.record_s "inject block to node"]) in let*! () = Events.( @@ -905,13 +903,13 @@ let compute_round proposal round_durations = let open Baking_state in let timestamp = Time.System.now () |> Time.System.to_protocol in let predecessor_block = proposal.predecessor in - Baking_profiler.record_f "compute round" @@ fun () -> - Environment.wrap_tzresult + (Environment.wrap_tzresult @@ Alpha_context.Round.round_of_timestamp round_durations ~predecessor_timestamp:predecessor_block.shell.timestamp ~predecessor_round:predecessor_block.round - ~timestamp + ~timestamp) + [@profiler.record_f "compute round"] let update_to_level state level_update = let open Lwt_result_syntax in @@ -930,20 +928,18 @@ let update_to_level state level_update = if Int32.(new_level = succ state.level_state.current_level) then return state.level_state.next_level_delegate_slots else - Baking_profiler.record_s "compute predecessor delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates ~level:new_level - ~chain + ~chain [@profiler.record_s "compute predecessor delegate slots"] in let* next_level_delegate_slots = - Baking_profiler.record_s "compute current delegate slots" @@ fun () -> - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ new_level) - ~chain + (Baking_state.compute_delegate_slots + cctxt + delegates + ~level:(Int32.succ new_level) + ~chain [@profiler.record_s "compute current delegate slots"]) in let round_durations = state.global_state.round_durations in let*? current_round = compute_round new_level_proposal round_durations in @@ -1040,8 +1036,11 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> - Baking_profiler.record_s "inject preattestations" @@ fun () -> - let* () = inject_consensus_vote state signed_preattestation in + let* () = + (inject_consensus_vote + state + signed_preattestation [@profiler.record_s "inject preattestations"]) + in (* Here, we do not need to wait for the prequorum, it has already been triggered by the [Prepare_(preattestation|consensus_votes)] action *) @@ -1052,18 +1051,18 @@ let rec perform_action state (action : action) = event *) perform_action state Watch_quorum | Update_to_level level_update -> - Baking_profiler.record_s "update to level" @@ fun () -> - let* new_state, new_action = update_to_level state level_update in - perform_action new_state new_action + (let* new_state, new_action = update_to_level state level_update in + perform_action new_state new_action) + [@profiler.record_s "update to level"] | Synchronize_round round_update -> - Baking_profiler.record_s "synchronize round" @@ fun () -> - let* new_state, new_action = synchronize_round state round_update in - perform_action new_state new_action + (let* new_state, new_action = synchronize_round state round_update in + perform_action new_state new_action) + [@profiler.record_s "synchronize round"] | Watch_prequorum -> - Baking_profiler.record_s "wait for preattestation quorum" @@ fun () -> - let*! () = start_waiting_for_preattestation_quorum state in - return state + (let*! () = start_waiting_for_preattestation_quorum state in + return state) + [@profiler.record_s "wait for preattestation quorum"] | Watch_quorum -> - Baking_profiler.record_s "wait for attestation quorum" @@ fun () -> - let*! () = start_waiting_for_attestation_quorum state in - return state + (let*! () = start_waiting_for_attestation_quorum state in + return state) + [@profiler.record_s "wait for attestation quorum"] diff --git a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml index 3229a761a36d..351e5be1743a 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml @@ -307,9 +307,9 @@ let try_migrate_legacy_nonces state = | Error _ -> return_unit (** [partition_unrevealed_nonces state nonces current_cycle current_level] partitions - nonces into 2 groups: + nonces into 2 groups: - nonces that need to be re/revealed - - nonces that are live + - nonces that are live Nonces that are not relevant can be dropped. *) let partition_unrevealed_nonces {cctxt; chain; _} nonces current_cycle @@ -421,7 +421,7 @@ let register_nonce (cctxt : #Protocol_client_context.full) ~chain_id block_hash in return_unit -(** [inject_seed_nonce_revelation cctxt ~chain ~block ~branch nonces] forges one +(** [inject_seed_nonce_revelation cctxt ~chain ~block ~branch nonces] forges one [Seed_nonce_revelation] operation per each nonce to be revealed, together with a signature and then injects these operations. *) let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain @@ -456,7 +456,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain return_unit) nonces -(** [reveal_potential_nonces state new_proposal] updates the internal [state] +(** [reveal_potential_nonces state new_proposal] updates the internal [state] of the worker each time a proposal with a new predecessor is received; this means revealing the necessary nonces. *) let reveal_potential_nonces state new_proposal = @@ -482,11 +482,10 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) - Profiler.record "waiting lock" ; + let () = (() [@profiler.record "waiting lock"]) in cctxt#with_lock @@ fun () -> let*! nonces = - Profiler.record_s "load nonce file" @@ fun () -> - load cctxt ~stateful_location + (load cctxt ~stateful_location [@profiler.record_s "load nonce file"]) in match nonces with | Error err -> @@ -497,8 +496,11 @@ let reveal_potential_nonces state new_proposal = Plugin.RPC.current_level cctxt (chain, `Head 0) in let*! partitioned_nonces = - Profiler.record_s "get unrevealed nonces" @@ fun () -> - partition_unrevealed_nonces state nonces cycle level + (partition_unrevealed_nonces + state + nonces + cycle + level [@profiler.record_s "get unrevealed nonces"]) in match partitioned_nonces with | Error err -> @@ -589,15 +591,19 @@ let start_revelation_worker cctxt config chain_id constants block_stream = with the node was interrupted: exit *) return_unit | Some new_proposal -> - Option.iter (fun _ -> Profiler.stop ()) !last_proposal ; - Profiler.record - (Block_hash.to_b58check new_proposal.Baking_state.block.hash) ; + Option.iter + (fun _ -> (() [@profiler.stop])) + !last_proposal + [@profiler.record + Block_hash.to_b58check new_proposal.Baking_state.block.hash] ; + last_proposal := Some new_proposal.Baking_state.block.hash ; if !should_shutdown then return_unit else let* _ = - Profiler.record_s "reveal potential nonces" @@ fun () -> - reveal_potential_nonces state new_proposal + (reveal_potential_nonces + state + new_proposal [@profiler.record_s "reveal potential nonces"]) in worker_loop () in diff --git a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml index 64b8b6dda565..09ffc36cb452 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml @@ -26,6 +26,7 @@ open Protocol.Alpha_context module Events = Baking_events.Scheduling open Baking_state +module Profiler = Baking_profiler type loop_state = { heads_stream : Baking_state.proposal Lwt_stream.t; @@ -578,12 +579,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t (* TODO: re-use what has been done in round_synchronizer.ml *) (* Compute the timestamp of the next possible round. *) let next_round = - Baking_profiler.record_f "compute next round time" @@ fun () -> - compute_next_round_time state + (compute_next_round_time + state [@profiler.record_f "compute next round time"]) in let*! next_baking = - Baking_profiler.record_s "compute next potential baking time" @@ fun () -> - compute_next_potential_baking_time_at_next_level state + (compute_next_potential_baking_time_at_next_level + state [@profiler.record_s "compute next potential baking time"]) in match (next_round, next_baking) with | None, None -> @@ -825,8 +826,7 @@ let compute_bootstrap_event state = let may_reset_profiler = let prev_head = ref None in let () = - at_exit (fun () -> - Option.iter (fun _ -> Baking_profiler.stop ()) !prev_head) + at_exit (fun () -> Option.iter (fun _ -> (() [@profiler.stop])) !prev_head) in function | Baking_state.New_head_proposal proposal @@ -834,11 +834,16 @@ let may_reset_profiler = let curr_head_hash = proposal.block.hash in match !prev_head with | None -> - Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + let () = + (() [@profiler.record Block_hash.to_b58check curr_head_hash]) + in prev_head := Some curr_head_hash | Some prev_head_hash when prev_head_hash <> curr_head_hash -> - Baking_profiler.stop () ; - Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + let () = + (() + [@profiler.stop] + [@profiler.record Block_hash.to_b58check curr_head_hash]) + in prev_head := Some curr_head_hash | _ -> ()) | _ -> () @@ -854,22 +859,20 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error in may_reset_profiler event ; let*! state', action = - Format.kasprintf - Baking_profiler.record_s - "do step with event '%a'" - pp_short_event - event - @@ fun () -> State_transitions.step state event + (State_transitions.step + state + event + [@profiler.record_s + Format.asprintf "do step with event '%a'" pp_short_event event]) in let* state'' = let*! state_res = let* state'' = - Format.kasprintf - Baking_profiler.record_s - "perform action '%a'" - Baking_actions.pp_action - action - @@ fun () -> Baking_actions.perform_action state' action + (Baking_actions.perform_action + state' + action + [@profiler.record_s + Format.asprintf "perform action '%a'" Baking_actions.pp_action action]) in let* () = may_record_new_state ~previous_state:state ~new_state:state'' in return state'' @@ -884,8 +887,7 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error return state' in let* next_timeout = - Baking_profiler.record_s "compute next timeout" @@ fun () -> - compute_next_timeout state'' + (compute_next_timeout state'' [@profiler.record_s "compute next timeout"]) in let* event_opt = wait_next_event @@ -1065,7 +1067,7 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in - Baking_profiler.stop () ; + let () = (() [@profiler.stop]) in may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> diff --git a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml b/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml index f65aac61eab4..2dc89ac93b53 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Baking_errors +module Profiler = Baking_profiler type incremental = { predecessor : Baking_state.block_info; @@ -60,67 +61,69 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) pred_block chain_id = let open Lwt_result_syntax in - Baking_profiler.record_s "begin construction" @@ fun () -> - protect (fun () -> - let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in - let*! context_opt = - abstract_index.checkout_fun pred_resulting_context_hash - in - match context_opt with - | None -> tzfail Failed_to_checkout_context - | Some context -> - let header : Tezos_base.Block_header.shell_header = - Tezos_base.Block_header. - { - predecessor = pred_hash; - proto_level = pred_shell.proto_level; - validation_passes = 0; - fitness = pred_shell.fitness; - timestamp; - level = pred_shell.level; - context = Context_hash.zero (* fake context hash *); - operations_hash = - Operation_list_list_hash.zero (* fake op hash *); - } - in - let mode = - Lifted_protocol.Construction - { - predecessor_hash = pred_hash; - timestamp; - block_header_data = protocol_data; - } - in - let* validation_state = - Lifted_protocol.begin_validation - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - let* application_state = - if force_apply then - let* application_state = - Lifted_protocol.begin_application - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - return_some application_state - else return_none - in - let state = (validation_state, application_state) in - return - { - predecessor = pred_block; - context; - state; - rev_operations = []; - header; - }) + (protect (fun () -> + let {Baking_state.shell = pred_shell; hash = pred_hash; _} = + pred_block + in + let*! context_opt = + abstract_index.checkout_fun pred_resulting_context_hash + in + match context_opt with + | None -> tzfail Failed_to_checkout_context + | Some context -> + let header : Tezos_base.Block_header.shell_header = + Tezos_base.Block_header. + { + predecessor = pred_hash; + proto_level = pred_shell.proto_level; + validation_passes = 0; + fitness = pred_shell.fitness; + timestamp; + level = pred_shell.level; + context = Context_hash.zero (* fake context hash *); + operations_hash = + Operation_list_list_hash.zero (* fake op hash *); + } + in + let mode = + Lifted_protocol.Construction + { + predecessor_hash = pred_hash; + timestamp; + block_header_data = protocol_data; + } + in + let* validation_state = + Lifted_protocol.begin_validation + context + chain_id + mode + ~predecessor:pred_shell + ~cache:`Lazy + in + let* application_state = + if force_apply then + let* application_state = + Lifted_protocol.begin_application + context + chain_id + mode + ~predecessor:pred_shell + ~cache:`Lazy + in + return_some application_state + else return_none + in + let state = (validation_state, application_state) in + return + { + predecessor = pred_block; + context; + state; + rev_operations = []; + header; + }) + [@profiler.record_s "begin construction"]) let ( let** ) x k = let open Lwt_result_syntax in @@ -134,23 +137,24 @@ let add_operation st (op : Operation.packed) = let validation_state, application_state = st.state in let oph = Operation.hash_packed op in let** validation_state = - Baking_profiler.aggregate_s "validating operation" @@ fun () -> - Protocol.validate_operation - ~check_signature:false - (* We assume that the operation has already been validated in the - node, therefore the signature has already been checked, but we - still need to validate it again because the context may be - different. *) - validation_state - oph - op + (Protocol.validate_operation + ~check_signature:false + (* We assume that the operation has already been validated in the + node, therefore the signature has already been checked, but we + still need to validate it again because the context may be + different. *) + validation_state + oph + op [@profiler.aggregate_s "validating operation"]) in let** application_state, receipt = match application_state with | Some application_state -> let* application_state, receipt = - Baking_profiler.aggregate_s "applying operation" @@ fun () -> - Protocol.apply_operation application_state oph op + (Protocol.apply_operation + application_state + oph + op [@profiler.aggregate_s "applying operation"]) in return (Some application_state, Some receipt) | None -> return (None, None) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.ml b/src/proto_020_PsParisC/lib_delegate/baking_state.ml index 6b45d49d0532..5fa5e8fcaebe 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_state.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Baking_errors +module Profiler = Baking_profiler (** A consensus key (aka, a validator) is identified by its alias name, its public key, its public key hash, and its secret key. *) @@ -795,39 +796,39 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in - Baking_profiler.record_s "record state" @@ fun () -> - let cctxt = state.global_state.cctxt in - let location = - Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State - in - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - protect @@ fun () -> - Baking_profiler.record "waiting lock" ; - cctxt#with_lock @@ fun () -> - Baking_profiler.stop () ; - let level_data = state.level_state.current_level in - let locked_round_data = state.level_state.locked_round in - let attestable_payload_data = state.level_state.attestable_payload in - let bytes = - Baking_profiler.record_f "serializing baking state" @@ fun () -> - Data_encoding.Binary.to_bytes_exn - state_data_encoding - {level_data; locked_round_data; attestable_payload_data} - in - let filename_tmp = filename ^ "_tmp" in - let*! () = - Baking_profiler.record_s "writing baking state" @@ fun () -> - Lwt_io.with_file - ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] - ~mode:Output - filename_tmp - (fun channel -> - Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) - in - let*! () = Lwt_unix.rename filename_tmp filename in - return_unit + (let cctxt = state.global_state.cctxt in + let location = + Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State + in + let filename = + Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) + in + protect @@ fun () -> + let () = (() [@profiler.record "waiting lock"]) in + cctxt#with_lock @@ fun () -> + let () = (() [@profiler.stop]) in + let level_data = state.level_state.current_level in + let locked_round_data = state.level_state.locked_round in + let attestable_payload_data = state.level_state.attestable_payload in + let bytes = + (Data_encoding.Binary.to_bytes_exn + state_data_encoding + {level_data; locked_round_data; attestable_payload_data} + [@profiler.record_f "serializing baking state"]) + in + let filename_tmp = filename ^ "_tmp" in + let*! () = + (Lwt_io.with_file + ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] + ~mode:Output + filename_tmp + (fun channel -> + Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) + [@profiler.record_s "writing baking state"]) + in + let*! () = Lwt_unix.rename filename_tmp filename in + return_unit) + [@profiler.record_s "record state"] let may_record_new_state ~previous_state ~new_state = let open Lwt_result_syntax in diff --git a/src/proto_020_PsParisC/lib_delegate/block_forge.ml b/src/proto_020_PsParisC/lib_delegate/block_forge.ml index 49b0e5ae88c0..f3219af9b1f0 100644 --- a/src/proto_020_PsParisC/lib_delegate/block_forge.ml +++ b/src/proto_020_PsParisC/lib_delegate/block_forge.ml @@ -25,6 +25,7 @@ open Protocol open Alpha_context +module Profiler = Baking_profiler type unsigned_block = { unsigned_block_header : Block_header.t; @@ -249,27 +250,26 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = - Baking_profiler.record_s "finalize block header" @@ fun () -> - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:None + (finalize_block_header + ~shell_header:incremental.header + ~validation_result + ~operations_hash + ~pred_info + ~pred_resulting_context_hash + ~round + ~locked_round:None [@profiler.record_s "finalize block header"]) in let operations = List.map (List.map convert_operation) operations in let payload_hash = - Baking_profiler.record_f "compute payload hash" @@ fun () -> - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes + (let operation_hashes = + Stdlib.List.tl operations |> List.flatten + |> List.map Tezos_base.Operation.hash + in + Block_payload.hash + ~predecessor_hash:shell_header.predecessor + ~payload_round + operation_hashes) + [@profiler.record_f "compute payload hash"] in return (shell_header, operations, payload_hash) @@ -302,32 +302,29 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades ~context_index ~payload_hash cctxt = let open Lwt_result_syntax in let* incremental = - Baking_profiler.record_s "begin construction" @@ fun () -> - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id + (Baking_simulator.begin_construction + ~timestamp + ~protocol_data:faked_protocol_data + ~force_apply + ~pred_resulting_context_hash + context_index + pred_info + chain_id [@profiler.record_s "begin construction"]) in (* We still need to filter attestations. Two attestations could be referring to the same slot. *) let* incremental, ordered_pool = - Baking_profiler.record_s "filter consensus operations" @@ fun () -> - Operation_selection.filter_consensus_operations_only - incremental - ordered_pool + (Operation_selection.filter_consensus_operations_only + incremental + ordered_pool [@profiler.record_s "filter consensus operations"]) in let operations = Operation_pool.ordered_to_list_list ordered_pool in let operations_hash = - Baking_profiler.record_f "compute operations merkle root" @@ fun () -> - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) + (Operation_list_list_hash.compute + (List.map + (fun sl -> + Operation_list_hash.compute (List.map Operation.hash_packed sl)) + operations) [@profiler.record_f "compute operations merkle root"]) in (* We need to compute the final [operations_hash] before finalizing the block because it will be used in the cache's nonce. *) @@ -335,8 +332,8 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades {incremental with header = {incremental.header with operations_hash}} in let* validation_result = - Baking_profiler.record_s "finalize construction" @@ fun () -> - Baking_simulator.finalize_construction incremental + (Baking_simulator.finalize_construction + incremental [@profiler.record_s "finalize construction"]) in let validation_result = Option.map fst validation_result in let* changed = @@ -370,15 +367,15 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = - Baking_profiler.record_s "finalize block header" @@ fun () -> - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:locked_round_when_no_validation_result + (finalize_block_header + ~shell_header:incremental.header + ~validation_result + ~operations_hash + ~pred_info + ~pred_resulting_context_hash + ~round + ~locked_round:locked_round_when_no_validation_result + [@profiler.record_s "finalize block header"]) in let operations = List.map (List.map convert_operation) operations in return (shell_header, operations, payload_hash) @@ -400,10 +397,9 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id (* We cannot include operations that are not live with respect to our predecessor otherwise the node would reject the block. *) let filtered_pool = - Baking_profiler.record_f "filter non live operations" @@ fun () -> - retain_live_operations_only - ~live_blocks:pred_live_blocks - operation_pool + (retain_live_operations_only + ~live_blocks:pred_live_blocks + operation_pool [@profiler.record_f "filter non live operations"]) in Filter filtered_pool | Apply _ as x -> x @@ -419,17 +415,16 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "filter via node" @@ fun () -> - filter_via_node - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt + (filter_via_node + ~chain_id + ~faked_protocol_data + ~fees_config + ~hard_gas_limit_per_block + ~timestamp + ~pred_info + ~payload_round + ~operation_pool + cctxt [@profiler.record_s "filter via node"]) | Node, Apply {ordered_pool; payload_hash} -> let faked_protocol_data = forge_faked_protocol_data @@ -440,15 +435,14 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "apply via node" @@ fun () -> - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt + (apply_via_node + ~chain_id + ~faked_protocol_data + ~timestamp + ~pred_info + ~ordered_pool + ~payload_hash + cctxt [@profiler.record_s "apply via node"]) | Local context_index, Filter operation_pool -> let faked_protocol_data = forge_faked_protocol_data @@ -458,22 +452,22 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "filter with context" @@ fun () -> - filter_with_context - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~context_index - ~payload_round - ~operation_pool - cctxt + + (filter_with_context + ~chain_id + ~faked_protocol_data + ~fees_config + ~hard_gas_limit_per_block + ~user_activated_upgrades + ~timestamp + ~pred_info + ~pred_resulting_context_hash + ~force_apply + ~round + ~context_index + ~payload_round + ~operation_pool + cctxt [@profiler.record_s "filter with context"]) | Local context_index, Apply {ordered_pool; payload_hash} -> let faked_protocol_data = forge_faked_protocol_data @@ -484,38 +478,37 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "apply with context" @@ fun () -> - apply_with_context - ~chain_id - ~faked_protocol_data - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~ordered_pool - ~context_index - ~payload_hash - cctxt + (apply_with_context + ~chain_id + ~faked_protocol_data + ~user_activated_upgrades + ~timestamp + ~pred_info + ~pred_resulting_context_hash + ~force_apply + ~round + ~ordered_pool + ~context_index + ~payload_hash + cctxt [@profiler.record_s "apply with context"]) in let* contents = - Baking_profiler.record_s "compute proof of work" @@ fun () -> - Baking_pow.mine - ~proof_of_work_threshold:constants.proof_of_work_threshold - shell_header - (fun proof_of_work_nonce -> - { - Block_header.payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce; - per_block_votes = - { - liquidity_baking_vote = liquidity_baking_toggle_vote; - adaptive_issuance_vote; - }; - }) + (Baking_pow.mine + ~proof_of_work_threshold:constants.proof_of_work_threshold + shell_header + (fun proof_of_work_nonce -> + { + Block_header.payload_hash; + payload_round; + seed_nonce_hash; + proof_of_work_nonce; + per_block_votes = + { + liquidity_baking_vote = liquidity_baking_toggle_vote; + adaptive_issuance_vote; + }; + }) + [@profiler.record_s "compute proof of work"]) in let unsigned_block_header = { diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml index 5231886132f0..8081f8b1dced 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -74,6 +74,8 @@ let may_start_profiler baking_dir = | _ -> () module Baker = struct + module Profiler = Baking_profiler + let run (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes ?extra_operations ?dal_node_endpoint ?dal_node_timeout_percentage @@ -152,7 +154,7 @@ module Baker = struct Lwt.return_unit) in let () = may_start_profiler cctxt#get_base_dir in - Baking_profiler.record "initialization" ; + let () = (() [@profiler.record "initialization"]) in let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml index c2bb081db7e0..00060e00ef78 100644 --- a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml +++ b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml @@ -33,7 +33,7 @@ module Events = Baking_events.Node_rpc module Profiler = struct include (val Profiler.wrap Baking_profiler.node_rpc_profiler) - let reset_block_section = + let[@warning "-32"] reset_block_section = Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler end @@ -106,10 +106,10 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = - Profiler.record_f "operations classification" @@ fun () -> - WithExceptions.Option.get - ~loc:__LOC__ - (Operation_pool.extract_operations_of_list_list operations) + (WithExceptions.Option.get + ~loc:__LOC__ + (Operation_pool.extract_operations_of_list_list operations) + [@profiler.record_f "operations classification"]) in let prequorum = Option.bind preattestations extract_prequorum in (payload_hash, payload_round, prequorum, quorum, payload) @@ -129,61 +129,60 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash block_header = let open Lwt_result_syntax in - Profiler.record_s - ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info") - @@ fun () -> - let* operations = - match operations with - | None when not in_protocol -> return_nil - | None -> - let open Protocol_client_context in - Profiler.record_s - ("retrieve block " - ^ Block_hash.to_short_b58check block_hash - ^ " operations") - @@ fun () -> - let* operations = - Alpha_block_services.Operations.operations - cctxt - ~chain - ~block:(`Hash (block_hash, 0)) - () - in - let packed_operations = - List.map - (fun l -> - List.map - (fun {Alpha_block_services.shell; protocol_data; _} -> - {Alpha_context.shell; protocol_data}) - l) - operations - in - return packed_operations - | Some operations -> - let parse_op (raw_op : Tezos_base.Operation.t) = - let protocol_data = - Profiler.aggregate_f "parse operation" @@ fun () -> - Data_encoding.Binary.of_bytes_exn - Operation.protocol_data_encoding - raw_op.proto + (let* operations = + match operations with + | None when not in_protocol -> return_nil + | None -> + let open Protocol_client_context in + (let* operations = + Alpha_block_services.Operations.operations + cctxt + ~chain + ~block:(`Hash (block_hash, 0)) + () in - {shell = raw_op.shell; protocol_data} - in - protect @@ fun () -> - return - (List.mapi - (fun i -> function - | [] -> [] - | l -> - Profiler.record_f - (Printf.sprintf "parse operations (pass:%d)" i) - @@ fun () -> List.map parse_op l) - operations) - in - let*? block_info = - info_of_header_and_ops ~in_protocol block_hash block_header operations - in - return block_info + let packed_operations = + List.map + (fun l -> + List.map + (fun {Alpha_block_services.shell; protocol_data; _} -> + {Alpha_context.shell; protocol_data}) + l) + operations + in + return packed_operations) + [@profiler.record_s + "retrieve block " + ^ Block_hash.to_short_b58check block_hash + ^ " operations"] + | Some operations -> + let parse_op (raw_op : Tezos_base.Operation.t) = + let protocol_data = + (Data_encoding.Binary.of_bytes_exn + Operation.protocol_data_encoding + raw_op.proto [@profiler.aggregate_f "parse operation"]) + in + {shell = raw_op.shell; protocol_data} + in + protect @@ fun () -> + return + (List.mapi + (fun [@warning "-27"] i -> function + | [] -> [] + | l -> + List.map + parse_op + l + [@profiler.record_f + Printf.sprintf "parse operations (pass:%d)" i]) + operations) + in + let*? block_info = + info_of_header_and_ops ~in_protocol block_hash block_header operations + in + return block_info) + [@profiler.record_s + "compute block " ^ Block_hash.to_short_b58check block_hash ^ " info"] let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain block_hash (block_header : Tezos_base.Block_header.t) = @@ -196,28 +195,37 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* is_proposal_in_protocol, predecessor = match predecessor_opt with | Some predecessor -> - Profiler.mark - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ "):cache_hit"; - ] ; + let () = + (() + [@profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_hit"; + ]]) + in return ( predecessor.shell.proto_level = block_header.shell.proto_level, predecessor ) | None -> - Profiler.mark - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ "):cache_miss"; - ] ; + let () = + (() + [@profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_miss"; + ]]) + in let* { current_protocol = pred_current_protocol; next_protocol = pred_next_protocol; } = - Profiler.record_s "pred block protocol RPC" @@ fun () -> - Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () + (Shell_services.Blocks.protocols + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "pred block protocol RPC"]) in let is_proposal_in_protocol = Protocol_hash.(pred_next_protocol = Protocol.hash) @@ -230,10 +238,9 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () in let predecessor_header = - Profiler.record_f "parse pred block header" @@ fun () -> - Data_encoding.Binary.of_bytes_exn - Tezos_base.Block_header.encoding - raw_header_b + (Data_encoding.Binary.of_bytes_exn + Tezos_base.Block_header.encoding + raw_header_b [@profiler.record_f "parse pred block header"]) in compute_block_info cctxt @@ -253,16 +260,24 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* block = match block_opt with | Some pi -> - Profiler.mark - ["new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"] ; + let () = + (() + [@profiler.mark + [ + "new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"; + ]]) + in return pi | None -> - Profiler.mark - [ - "new_block(" - ^ Block_hash.to_short_b58check block_hash - ^ "):cache_miss"; - ] ; + let () = + (() + [@profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ]]) + in let* pi = compute_block_info cctxt @@ -278,9 +293,9 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain return {block; predecessor} let proposal cctxt ?cache ?operations ~chain block_hash block_header = - Profiler.record_s "proposal_computation" @@ fun () -> - protect @@ fun () -> - proposal cctxt ?cache ?operations ~chain block_hash block_header + ( (protect @@ fun () -> + proposal cctxt ?cache ?operations ~chain block_hash block_header) + [@profiler.record_s "proposal_computation"] ) let monitor_valid_proposals cctxt ~chain ?cache () = let open Lwt_result_syntax in @@ -290,16 +305,18 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - Profiler.reset_block_section block_hash ; - Profiler.record_s "received valid proposal" @@ fun () -> - let*! map_result = - proposal cctxt ?cache ~operations ~chain block_hash block_header - in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_valid_proposals err) in - Lwt.return_none + let () = (() [@profiler.reset_block_section block_hash]) in + (let*! map_result = + proposal cctxt ?cache ~operations ~chain block_hash block_header + in + match map_result with + | Ok proposal -> Lwt.return_some proposal + | Error err -> + let*! () = + Events.(emit error_while_monitoring_valid_proposals err) + in + Lwt.return_none) + [@profiler.record_s "received valid proposal"] in Lwt_stream.filter_map_s map block_stream in @@ -313,14 +330,16 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - Profiler.reset_block_section block_hash ; - Profiler.record_s "received new head" @@ fun () -> - let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_heads err) in - Lwt.return_none + let () = (() [@profiler.reset_block_section block_hash]) in + (let*! map_result = + proposal cctxt ?cache ~chain block_hash block_header + in + match map_result with + | Ok proposal -> Lwt.return_some proposal + | Error err -> + let*! () = Events.(emit error_while_monitoring_heads err) in + Lwt.return_none) + [@profiler.record_s "received new head"] in Lwt_stream.filter_map_s map block_stream in diff --git a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml index c9ce27b90f79..63ed8239b288 100644 --- a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml +++ b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Operation_pool module Events = Baking_events.Selection +module Profiler = Baking_profiler let quota = Main.validation_passes @@ -181,23 +182,22 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( - Baking_profiler.record_f "checking operation receipt roundtrip" - @@ fun () -> - (* Check that the metadata are serializable/deserializable *) - let encoding_result = - let enc = Protocol.operation_receipt_encoding in - Option.bind - (Data_encoding.Binary.to_bytes_opt enc receipt) - (Data_encoding.Binary.of_bytes_opt enc) - in - match encoding_result with - | None -> - let* () = - Events.(emit cannot_serialize_operation_metadata) - (Operation.hash_packed op) - in - return_none - | Some _b -> return_some resulting_state) + ((* Check that the metadata are serializable/deserializable *) + let encoding_result = + let enc = Protocol.operation_receipt_encoding in + Option.bind + (Data_encoding.Binary.to_bytes_opt enc receipt) + (Data_encoding.Binary.of_bytes_opt enc) + in + match encoding_result with + | None -> + let* () = + Events.(emit cannot_serialize_operation_metadata) + (Operation.hash_packed op) + in + return_none + | Some _b -> return_some resulting_state) + [@profiler.record_f "checking operation receipt roundtrip"]) let filter_valid_operations_up_to_quota inc (ops, quota) = let open Lwt_syntax in @@ -221,7 +221,7 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = let* inc'_opt = validate_operation inc op in match inc'_opt with | None -> - Baking_profiler.mark ["invalid operation filtered"] ; + let () = (() [@profiler.mark ["invalid operation filtered"]]) in return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) @@ -281,53 +281,51 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = - Baking_profiler.record_s "simulate and filter consensus" @@ fun () -> - filter_valid_operations_up_to_quota - initial_inc - (Prioritized_operation_set.operations consensus, consensus_quota) + (filter_valid_operations_up_to_quota + initial_inc + (Prioritized_operation_set.operations consensus, consensus_quota) + [@profiler.record_s "simulate and filter consensus"]) in let*! inc, votes = - Baking_profiler.record_s "simulate and filter votes" @@ fun () -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations votes, votes_quota) + (filter_valid_operations_up_to_quota + inc + (Prioritized_operation_set.operations votes, votes_quota) + [@profiler.record_s "simulate and filter votes"]) in let*! inc, anonymous = - Baking_profiler.record_s "simulate and filter anonymous" @@ fun () -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations anonymous, anonymous_quota) + (filter_valid_operations_up_to_quota + inc + (Prioritized_operation_set.operations anonymous, anonymous_quota) + [@profiler.record_s "simulate and filter anonymous"]) in (* Sort the managers *) let prioritized_managers = - Baking_profiler.record_f "prioritize managers" @@ fun () -> - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers + (prioritize_managers + ~hard_gas_limit_per_block + ~minimal_fees + ~minimal_nanotez_per_gas_unit + ~minimal_nanotez_per_byte + managers [@profiler.record_f "prioritize managers"]) in let*! inc, managers = - Baking_profiler.record_s "simulate and filter managers" @@ fun () -> - filter_valid_managers_up_to_quota - inc - ~hard_gas_limit_per_block - (PrioritizedManagerSet.elements prioritized_managers, managers_quota) + (filter_valid_managers_up_to_quota + inc + ~hard_gas_limit_per_block + (PrioritizedManagerSet.elements prioritized_managers, managers_quota) + [@profiler.record_s "simulate and filter managers"]) in let operations = [consensus; votes; anonymous; managers] in let operations_hash = - Baking_profiler.record_f "compute operations merkle root" @@ fun () -> - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) + (Operation_list_list_hash.compute + (List.map + (fun sl -> + Operation_list_hash.compute (List.map Operation.hash_packed sl)) + operations) [@profiler.record_f "compute operations merkle root"]) in let inc = {inc with header = {inc.header with operations_hash}} in let* result = - Baking_profiler.record_s "finalize construction" @@ fun () -> - Baking_simulator.finalize_construction inc + (Baking_simulator.finalize_construction + inc [@profiler.record_s "finalize construction"]) in match result with | Some (validation_result, block_header_metadata) -> diff --git a/src/proto_beta/lib_delegate/baking_actions.ml b/src/proto_beta/lib_delegate/baking_actions.ml index 80a0e6ab686d..c73c929fecda 100644 --- a/src/proto_beta/lib_delegate/baking_actions.ml +++ b/src/proto_beta/lib_delegate/baking_actions.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Baking_state module Events = Baking_events.Actions +module Profiler = Baking_profiler module Operations_source = struct type error += @@ -44,79 +45,82 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( - Baking_profiler.record_s "retrieve external operations" @@ fun () -> - let fail reason details = - let path = - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - filename - | Baking_configuration.Operations_source.Remote {uri; _} -> - Uri.to_string uri - in - tzfail (Failed_operations_fetch {path; reason; details}) - in - let decode_operations json = - protect - ~on_error:(fun _ -> - fail "cannot decode the received JSON into operations" (Some json)) - (fun () -> - return (Data_encoding.Json.destruct operations_encoding json)) - in - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - if Sys.file_exists filename then - let*! result = - Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename - in - match result with - | Error _ -> - let*! () = Events.(emit invalid_json_file filename) in - Lwt.return_none - | Ok json -> ( - let*! operations = decode_operations json in - match operations with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none) - else - let*! () = Events.(emit no_operations_found_in_file filename) in - Lwt.return_none - | Baking_configuration.Operations_source.Remote {uri; http_headers} -> ( - let*! operations_opt = - let* result = - with_timeout - (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) - (fun _ -> - Tezos_rpc_http_client_unix.RPC_client_unix - .generic_media_type_call - ~accept:[Media_type.json] - ?headers:http_headers - `GET - uri) - in - let* rest = - match result with - | `Json json -> return json - | _ -> fail "json not returned" None - in - let* json = - match rest with - | `Ok json -> return json - | `Unauthorized json -> fail "unauthorized request" json - | `Gone json -> fail "gone" json - | `Error json -> fail "error" json - | `Not_found json -> fail "not found" json - | `Forbidden json -> fail "forbidden" json - | `Conflict json -> fail "conflict" json - in - decode_operations json - in - match operations_opt with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none)) + (let fail reason details = + let path = + match operations with + | Baking_configuration.Operations_source.Local {filename} -> + filename + | Baking_configuration.Operations_source.Remote {uri; _} -> + Uri.to_string uri + in + tzfail (Failed_operations_fetch {path; reason; details}) + in + let decode_operations json = + protect + ~on_error:(fun _ -> + fail + "cannot decode the received JSON into operations" + (Some json)) + (fun () -> + return (Data_encoding.Json.destruct operations_encoding json)) + in + match operations with + | Baking_configuration.Operations_source.Local {filename} -> + if Sys.file_exists filename then + let*! result = + Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename + in + match result with + | Error _ -> + let*! () = Events.(emit invalid_json_file filename) in + Lwt.return_none + | Ok json -> ( + let*! operations = decode_operations json in + match operations with + | Ok operations -> Lwt.return_some operations + | Error errs -> + let*! () = Events.(emit cannot_fetch_operations errs) in + Lwt.return_none) + else + let*! () = Events.(emit no_operations_found_in_file filename) in + Lwt.return_none + | Baking_configuration.Operations_source.Remote {uri; http_headers} + -> ( + let*! operations_opt = + let* result = + with_timeout + (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) + (fun _ -> + Tezos_rpc_http_client_unix.RPC_client_unix + .generic_media_type_call + ~accept:[Media_type.json] + ?headers:http_headers + `GET + uri) + in + let* rest = + match result with + | `Json json -> return json + | _ -> fail "json not returned" None + in + let* json = + match rest with + | `Ok json -> return json + | `Unauthorized json -> fail "unauthorized request" json + | `Gone json -> fail "gone" json + | `Error json -> fail "error" json + | `Not_found json -> fail "not found" json + | `Forbidden json -> fail "forbidden" json + | `Conflict json -> fail "conflict" json + in + decode_operations json + in + match operations_opt with + | Ok operations -> Lwt.return_some operations + | Error errs -> + let*! () = Events.(emit cannot_fetch_operations errs) in + Lwt.return_none)) + [@profiler.record_s "retrieve external operations"]) end type action = @@ -188,40 +192,37 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = - Baking_profiler.record_f "serializing" @@ fun () -> - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.unsigned_encoding - (shell, contents) + (Data_encoding.Binary.to_bytes_exn + Alpha_context.Block_header.unsigned_encoding + (shell, contents) [@profiler.record_f "serializing"]) in let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in - Baking_profiler.record "waiting for lockfile" ; + let () = (() [@profiler.record "waiting for lockfile"]) in let* result = cctxt#with_lock (fun () -> - Baking_profiler.stop () ; + let () = (() [@profiler.stop ()]) in let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = - Baking_profiler.record_s "check highwatermark" @@ fun () -> - may_sign_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round + (may_sign_block + cctxt + block_location + ~delegate:proposer.public_key_hash + ~level + ~round [@profiler.record_s "check highwatermark"]) in match may_sign with | true -> let* () = - Baking_profiler.record_s "record highwatermark" @@ fun () -> - record_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round + (record_block + cctxt + block_location + ~delegate:proposer.public_key_hash + ~level + ~round [@profiler.record_s "record highwatermark"]) in return_true | false -> @@ -232,12 +233,11 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = - Baking_profiler.record_s "signing block" @@ fun () -> - Client_keys.sign - cctxt - proposer.secret_key_uri - ~watermark:Block_header.(to_watermark (Block_header chain_id)) - unsigned_header + (Client_keys.sign + cctxt + proposer.secret_key_uri + ~watermark:Block_header.(to_watermark (Block_header chain_id)) + unsigned_header [@profiler.record_s "signing block"]) in return {Block_header.shell; protocol_data = {contents; signature}} @@ -264,13 +264,12 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let simulation_mode = global_state.validation_mode in let round_durations = global_state.round_durations in let*? timestamp = - Baking_profiler.record_f "timestamp of round" @@ fun () -> - Environment.wrap_tzresult - (Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round) + (Environment.wrap_tzresult + (Round.timestamp_of_round + round_durations + ~predecessor_timestamp:predecessor.shell.timestamp + ~predecessor_round:predecessor.round + ~round) [@profiler.record_f "timestamp of round"]) in let external_operation_source = global_state.config.extra_operations in let*! extern_ops = Operations_source.retrieve external_operation_source in @@ -301,18 +300,17 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) in let* injection_level = - Baking_profiler.record_s "retrieve injection level" @@ fun () -> - Plugin.RPC.current_level - cctxt - ~offset:1l - (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) + (Plugin.RPC.current_level + cctxt + ~offset:1l + (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) + [@profiler.record_s "retrieve injection level"]) in let* seed_nonce_opt = - Baking_profiler.record_s "generate seed nonce" @@ fun () -> - generate_seed_nonce_hash - global_state.config.Baking_configuration.nonce - consensus_key - injection_level + (generate_seed_nonce_hash + global_state.config.Baking_configuration.nonce + consensus_key + injection_level [@profiler.record_s "generate seed nonce"]) in let seed_nonce_hash = Option.map fst seed_nonce_opt in let user_activated_upgrades = global_state.config.user_activated_upgrades in @@ -344,16 +342,18 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) let chain = `Hash global_state.chain_id in let pred_block = `Hash (predecessor.hash, 0) in let* pred_resulting_context_hash = - Baking_profiler.record_s "retrieve resulting context hash" @@ fun () -> - Shell_services.Blocks.resulting_context_hash - cctxt - ~chain - ~block:pred_block - () + (Shell_services.Blocks.resulting_context_hash + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "retrieve resulting context hash"]) in let* pred_live_blocks = - Baking_profiler.record_s "retrieve live blocks" @@ fun () -> - Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () + (Chain_services.Blocks.live_blocks + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "retrieve live blocks"]) in let* {unsigned_block_header; operations} = Block_forge.forge @@ -376,8 +376,10 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = - Baking_profiler.record_s "sign block header" @@ fun () -> - sign_block_header global_state consensus_key unsigned_block_header + (sign_block_header + global_state + consensus_key + unsigned_block_header [@profiler.record_s "sign block header"]) in let* () = match seed_nonce_opt with @@ -386,15 +388,15 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) return_unit | Some (_, nonce) -> let block_hash = Block_header.hash signed_block_header in - Baking_profiler.record_s "register nonce" @@ fun () -> - Baking_nonces.register_nonce - cctxt - ~chain_id - block_hash - nonce - ~cycle:injection_level.cycle - ~level:injection_level.level - ~round + + (Baking_nonces.register_nonce + cctxt + ~chain_id + block_hash + nonce + ~cycle:injection_level.cycle + ~level:injection_level.level + ~round [@profiler.record_s "register nonce"]) in let baking_votes = {Per_block_votes.liquidity_baking_vote; adaptive_issuance_vote} @@ -562,55 +564,54 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = - Baking_profiler.record_s - (Format.sprintf - "filter consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - Baking_profiler.record "wait for lock" ; - cctxt#with_lock (fun () -> - Baking_profiler.stop () ; - let* highwatermarks = - Baking_profiler.record_s "load highwatermarks" @@ fun () -> - Baking_highwatermarks.load cctxt block_location - in - let authorized_votes, unauthorized_votes = - List.partition - (fun consensus_vote -> - is_authorized global_state highwatermarks consensus_vote) - unsigned_consensus_votes - in - (* Record all consensus votes new highwatermarks as one batch *) - let delegates = - List.map - (fun {delegate = ck, _; _} -> ck.public_key_hash) - authorized_votes - in - let record_all_consensus_vote = - match batch_kind with - | Preattestation -> Baking_highwatermarks.record_all_preattestations - | Attestation -> Baking_highwatermarks.record_all_attestations - in - (* We exit the client's lock as soon as this function returns *) - let* () = - Baking_profiler.record_s - (Format.sprintf - "record consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - in - return (authorized_votes, unauthorized_votes)) + let () = (() [@profiler.record "wait for lock"]) in + (cctxt#with_lock (fun () -> + let () = (() [@profiler.stop]) in + let* highwatermarks = + (Baking_highwatermarks.load + cctxt + block_location [@profiler.record_s "load highwatermarks"]) + in + let authorized_votes, unauthorized_votes = + List.partition + (fun consensus_vote -> + is_authorized global_state highwatermarks consensus_vote) + unsigned_consensus_votes + in + (* Record all consensus votes new highwatermarks as one batch *) + let delegates = + List.map + (fun {delegate = ck, _; _} -> ck.public_key_hash) + authorized_votes + in + let record_all_consensus_vote = + match batch_kind with + | Preattestation -> Baking_highwatermarks.record_all_preattestations + | Attestation -> Baking_highwatermarks.record_all_attestations + in + (* We exit the client's lock as soon as this function returns *) + let* () = + (record_all_consensus_vote + highwatermarks + cctxt + block_location + ~delegates + ~level + ~round + [@profiler.record_s + Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")]) + in + return (authorized_votes, unauthorized_votes)) + [@profiler.record_s + Format.sprintf + "filter consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")]) in let*! () = List.iter_s @@ -682,17 +683,16 @@ let sign_consensus_votes (global_state : global_state) unsigned_consensus_vote) -> let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in let*! signed_consensus_vote_r = - Baking_profiler.record_s - (Format.sprintf + (forge_and_sign_consensus_vote + global_state + ~branch:batch_branch + unsigned_consensus_vote + [@profiler.record_s + Format.sprintf "forge and sign consensus vote: %s" (match vote_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - forge_and_sign_consensus_vote - global_state - ~branch:batch_branch - unsigned_consensus_vote + | Attestation -> "attestation")]) in match signed_consensus_vote_r with | Error err -> @@ -742,17 +742,16 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = - Baking_profiler.record_s - (Format.sprintf + (Node_rpc.inject_operation + cctxt + ~chain:(`Hash chain_id) + signed_consensus_vote.signed_operation + [@profiler.record_s + Format.sprintf "injecting consensus vote: %s" (match unsigned_consensus_vote.vote_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")) - @@ fun () -> - Node_rpc.inject_operation - cctxt - ~chain:(`Hash chain_id) - signed_consensus_vote.signed_operation + | Attestation -> "attestation")]) in let*! () = Events.( @@ -799,13 +798,12 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = - Baking_profiler.record_s "inject block to node" @@ fun () -> - Node_rpc.inject_block - state.global_state.cctxt - ~force:state.global_state.config.force - ~chain:(`Hash state.global_state.chain_id) - signed_block_header - operations + (Node_rpc.inject_block + state.global_state.cctxt + ~force:state.global_state.config.force + ~chain:(`Hash state.global_state.chain_id) + signed_block_header + operations [@profiler.record_s "inject block to node"]) in let*! () = Events.( @@ -905,13 +903,13 @@ let compute_round proposal round_durations = let open Baking_state in let timestamp = Time.System.now () |> Time.System.to_protocol in let predecessor_block = proposal.predecessor in - Baking_profiler.record_f "compute round" @@ fun () -> - Environment.wrap_tzresult + (Environment.wrap_tzresult @@ Alpha_context.Round.round_of_timestamp round_durations ~predecessor_timestamp:predecessor_block.shell.timestamp ~predecessor_round:predecessor_block.round - ~timestamp + ~timestamp) + [@profiler.record_f "compute round"] let update_to_level state level_update = let open Lwt_result_syntax in @@ -930,20 +928,18 @@ let update_to_level state level_update = if Int32.(new_level = succ state.level_state.current_level) then return state.level_state.next_level_delegate_slots else - Baking_profiler.record_s "compute predecessor delegate slots" @@ fun () -> Baking_state.compute_delegate_slots cctxt delegates ~level:new_level - ~chain + ~chain [@profiler.record_s "compute predecessor delegate slots"] in let* next_level_delegate_slots = - Baking_profiler.record_s "compute current delegate slots" @@ fun () -> - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ new_level) - ~chain + (Baking_state.compute_delegate_slots + cctxt + delegates + ~level:(Int32.succ new_level) + ~chain [@profiler.record_s "compute current delegate slots"]) in let round_durations = state.global_state.round_durations in let*? current_round = compute_round new_level_proposal round_durations in @@ -1040,31 +1036,33 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> - Baking_profiler.record_s "inject preattestations" @@ fun () -> - let* () = inject_consensus_vote state signed_preattestation in + let* () = + (inject_consensus_vote + state + signed_preattestation [@profiler.record_s "inject preattestations"]) + in (* Here, we do not need to wait for the prequorum, it has already been triggered by the [Prepare_(preattestation|consensus_votes)] action *) return state | Inject_attestations {signed_attestations} -> - Baking_profiler.record_s "inject attestations" @@ fun () -> let* () = inject_consensus_votes state signed_attestations in (* We wait for attestations to trigger the [Quorum_reached] event *) perform_action state Watch_quorum | Update_to_level level_update -> - Baking_profiler.record_s "update to level" @@ fun () -> - let* new_state, new_action = update_to_level state level_update in - perform_action new_state new_action + (let* new_state, new_action = update_to_level state level_update in + perform_action new_state new_action) + [@profiler.record_s "update to level"] | Synchronize_round round_update -> - Baking_profiler.record_s "synchronize round" @@ fun () -> - let* new_state, new_action = synchronize_round state round_update in - perform_action new_state new_action + (let* new_state, new_action = synchronize_round state round_update in + perform_action new_state new_action) + [@profiler.record_s "synchronize round"] | Watch_prequorum -> - Baking_profiler.record_s "wait for preattestation quorum" @@ fun () -> - let*! () = start_waiting_for_preattestation_quorum state in - return state + (let*! () = start_waiting_for_preattestation_quorum state in + return state) + [@profiler.record_s "wait for preattestation quorum"] | Watch_quorum -> - Baking_profiler.record_s "wait for attestation quorum" @@ fun () -> - let*! () = start_waiting_for_attestation_quorum state in - return state + (let*! () = start_waiting_for_attestation_quorum state in + return state) + [@profiler.record_s "wait for attestation quorum"] diff --git a/src/proto_beta/lib_delegate/baking_nonces.ml b/src/proto_beta/lib_delegate/baking_nonces.ml index 7d38c52f8db9..d605900bb5bc 100644 --- a/src/proto_beta/lib_delegate/baking_nonces.ml +++ b/src/proto_beta/lib_delegate/baking_nonces.ml @@ -28,6 +28,8 @@ open Protocol open Alpha_context module Events = Baking_events.Nonces +module Profiler = (val Profiler.wrap Baking_profiler.nonce_profiler) + type state = { cctxt : Protocol_client_context.full; chain : Chain_services.chain; @@ -305,9 +307,9 @@ let try_migrate_legacy_nonces state = | Error _ -> return_unit (** [partition_unrevealed_nonces state nonces current_cycle current_level] partitions - nonces into 2 groups: + nonces into 2 groups: - nonces that need to be re/revealed - - nonces that are live + - nonces that are live Nonces that are not relevant can be dropped. *) let partition_unrevealed_nonces {cctxt; chain; _} nonces current_cycle @@ -419,7 +421,7 @@ let register_nonce (cctxt : #Protocol_client_context.full) ~chain_id block_hash in return_unit -(** [inject_seed_nonce_revelation cctxt ~chain ~block ~branch nonces] forges one +(** [inject_seed_nonce_revelation cctxt ~chain ~block ~branch nonces] forges one [Seed_nonce_revelation] operation per each nonce to be revealed, together with a signature and then injects these operations. *) let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain @@ -454,7 +456,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain return_unit) nonces -(** [reveal_potential_nonces state new_proposal] updates the internal [state] +(** [reveal_potential_nonces state new_proposal] updates the internal [state] of the worker each time a proposal with a new predecessor is received; this means revealing the necessary nonces. *) let reveal_potential_nonces state new_proposal = @@ -480,8 +482,11 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) + let () = (() [@profiler.record "waiting lock"]) in cctxt#with_lock @@ fun () -> - let*! nonces = load cctxt ~stateful_location in + let*! nonces = + (load cctxt ~stateful_location [@profiler.record_s "load nonce file"]) + in match nonces with | Error err -> let*! () = Events.(emit cannot_read_nonces err) in @@ -491,7 +496,11 @@ let reveal_potential_nonces state new_proposal = Plugin.RPC.current_level cctxt (chain, `Head 0) in let*! partitioned_nonces = - partition_unrevealed_nonces state nonces cycle level + (partition_unrevealed_nonces + state + nonces + cycle + level [@profiler.record_s "get unrevealed nonces"]) in match partitioned_nonces with | Error err -> diff --git a/src/proto_beta/lib_delegate/baking_scheduling.ml b/src/proto_beta/lib_delegate/baking_scheduling.ml index 64b8b6dda565..09ffc36cb452 100644 --- a/src/proto_beta/lib_delegate/baking_scheduling.ml +++ b/src/proto_beta/lib_delegate/baking_scheduling.ml @@ -26,6 +26,7 @@ open Protocol.Alpha_context module Events = Baking_events.Scheduling open Baking_state +module Profiler = Baking_profiler type loop_state = { heads_stream : Baking_state.proposal Lwt_stream.t; @@ -578,12 +579,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t (* TODO: re-use what has been done in round_synchronizer.ml *) (* Compute the timestamp of the next possible round. *) let next_round = - Baking_profiler.record_f "compute next round time" @@ fun () -> - compute_next_round_time state + (compute_next_round_time + state [@profiler.record_f "compute next round time"]) in let*! next_baking = - Baking_profiler.record_s "compute next potential baking time" @@ fun () -> - compute_next_potential_baking_time_at_next_level state + (compute_next_potential_baking_time_at_next_level + state [@profiler.record_s "compute next potential baking time"]) in match (next_round, next_baking) with | None, None -> @@ -825,8 +826,7 @@ let compute_bootstrap_event state = let may_reset_profiler = let prev_head = ref None in let () = - at_exit (fun () -> - Option.iter (fun _ -> Baking_profiler.stop ()) !prev_head) + at_exit (fun () -> Option.iter (fun _ -> (() [@profiler.stop])) !prev_head) in function | Baking_state.New_head_proposal proposal @@ -834,11 +834,16 @@ let may_reset_profiler = let curr_head_hash = proposal.block.hash in match !prev_head with | None -> - Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + let () = + (() [@profiler.record Block_hash.to_b58check curr_head_hash]) + in prev_head := Some curr_head_hash | Some prev_head_hash when prev_head_hash <> curr_head_hash -> - Baking_profiler.stop () ; - Baking_profiler.record (Block_hash.to_b58check curr_head_hash) ; + let () = + (() + [@profiler.stop] + [@profiler.record Block_hash.to_b58check curr_head_hash]) + in prev_head := Some curr_head_hash | _ -> ()) | _ -> () @@ -854,22 +859,20 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error in may_reset_profiler event ; let*! state', action = - Format.kasprintf - Baking_profiler.record_s - "do step with event '%a'" - pp_short_event - event - @@ fun () -> State_transitions.step state event + (State_transitions.step + state + event + [@profiler.record_s + Format.asprintf "do step with event '%a'" pp_short_event event]) in let* state'' = let*! state_res = let* state'' = - Format.kasprintf - Baking_profiler.record_s - "perform action '%a'" - Baking_actions.pp_action - action - @@ fun () -> Baking_actions.perform_action state' action + (Baking_actions.perform_action + state' + action + [@profiler.record_s + Format.asprintf "perform action '%a'" Baking_actions.pp_action action]) in let* () = may_record_new_state ~previous_state:state ~new_state:state'' in return state'' @@ -884,8 +887,7 @@ let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error return state' in let* next_timeout = - Baking_profiler.record_s "compute next timeout" @@ fun () -> - compute_next_timeout state'' + (compute_next_timeout state'' [@profiler.record_s "compute next timeout"]) in let* event_opt = wait_next_event @@ -1065,7 +1067,7 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in - Baking_profiler.stop () ; + let () = (() [@profiler.stop]) in may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> diff --git a/src/proto_beta/lib_delegate/baking_simulator.ml b/src/proto_beta/lib_delegate/baking_simulator.ml index 0c2d4b173d19..ffae1bc7eae1 100644 --- a/src/proto_beta/lib_delegate/baking_simulator.ml +++ b/src/proto_beta/lib_delegate/baking_simulator.ml @@ -9,6 +9,7 @@ open Protocol open Alpha_context open Baking_errors +module Profiler = Baking_profiler type incremental = { predecessor : Baking_state.block_info; @@ -43,67 +44,69 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) pred_block chain_id = let open Lwt_result_syntax in - Baking_profiler.record_s "begin construction" @@ fun () -> - protect (fun () -> - let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in - let*! context_opt = - abstract_index.checkout_fun pred_resulting_context_hash - in - match context_opt with - | None -> tzfail Failed_to_checkout_context - | Some context -> - let header : Tezos_base.Block_header.shell_header = - Tezos_base.Block_header. - { - predecessor = pred_hash; - proto_level = pred_shell.proto_level; - validation_passes = 0; - fitness = pred_shell.fitness; - timestamp; - level = pred_shell.level; - context = Context_hash.zero (* fake context hash *); - operations_hash = - Operation_list_list_hash.zero (* fake op hash *); - } - in - let mode = - Lifted_protocol.Construction - { - predecessor_hash = pred_hash; - timestamp; - block_header_data = protocol_data; - } - in - let* validation_state = - Lifted_protocol.begin_validation - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - let* application_state = - if force_apply then - let* application_state = - Lifted_protocol.begin_application - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - return_some application_state - else return_none - in - let state = (validation_state, application_state) in - return - { - predecessor = pred_block; - context; - state; - rev_operations = []; - header; - }) + (protect (fun () -> + let {Baking_state.shell = pred_shell; hash = pred_hash; _} = + pred_block + in + let*! context_opt = + abstract_index.checkout_fun pred_resulting_context_hash + in + match context_opt with + | None -> tzfail Failed_to_checkout_context + | Some context -> + let header : Tezos_base.Block_header.shell_header = + Tezos_base.Block_header. + { + predecessor = pred_hash; + proto_level = pred_shell.proto_level; + validation_passes = 0; + fitness = pred_shell.fitness; + timestamp; + level = pred_shell.level; + context = Context_hash.zero (* fake context hash *); + operations_hash = + Operation_list_list_hash.zero (* fake op hash *); + } + in + let mode = + Lifted_protocol.Construction + { + predecessor_hash = pred_hash; + timestamp; + block_header_data = protocol_data; + } + in + let* validation_state = + Lifted_protocol.begin_validation + context + chain_id + mode + ~predecessor:pred_shell + ~cache:`Lazy + in + let* application_state = + if force_apply then + let* application_state = + Lifted_protocol.begin_application + context + chain_id + mode + ~predecessor:pred_shell + ~cache:`Lazy + in + return_some application_state + else return_none + in + let state = (validation_state, application_state) in + return + { + predecessor = pred_block; + context; + state; + rev_operations = []; + header; + }) + [@profiler.record_s "begin construction"]) let ( let** ) x k = let open Lwt_result_syntax in @@ -117,23 +120,24 @@ let add_operation st (op : Operation.packed) = let validation_state, application_state = st.state in let oph = Operation.hash_packed op in let** validation_state = - Baking_profiler.aggregate_s "validating operation" @@ fun () -> - Protocol.validate_operation - ~check_signature:false - (* We assume that the operation has already been validated in the - node, therefore the signature has already been checked, but we - still need to validate it again because the context may be - different. *) - validation_state - oph - op + (Protocol.validate_operation + ~check_signature:false + (* We assume that the operation has already been validated in the + node, therefore the signature has already been checked, but we + still need to validate it again because the context may be + different. *) + validation_state + oph + op [@profiler.aggregate_s "validating operation"]) in let** application_state, receipt = match application_state with | Some application_state -> let* application_state, receipt = - Baking_profiler.aggregate_s "applying operation" @@ fun () -> - Protocol.apply_operation application_state oph op + (Protocol.apply_operation + application_state + oph + op [@profiler.aggregate_s "applying operation"]) in return (Some application_state, Some receipt) | None -> return (None, None) diff --git a/src/proto_beta/lib_delegate/baking_state.ml b/src/proto_beta/lib_delegate/baking_state.ml index 6b45d49d0532..5fa5e8fcaebe 100644 --- a/src/proto_beta/lib_delegate/baking_state.ml +++ b/src/proto_beta/lib_delegate/baking_state.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Baking_errors +module Profiler = Baking_profiler (** A consensus key (aka, a validator) is identified by its alias name, its public key, its public key hash, and its secret key. *) @@ -795,39 +796,39 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in - Baking_profiler.record_s "record state" @@ fun () -> - let cctxt = state.global_state.cctxt in - let location = - Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State - in - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - protect @@ fun () -> - Baking_profiler.record "waiting lock" ; - cctxt#with_lock @@ fun () -> - Baking_profiler.stop () ; - let level_data = state.level_state.current_level in - let locked_round_data = state.level_state.locked_round in - let attestable_payload_data = state.level_state.attestable_payload in - let bytes = - Baking_profiler.record_f "serializing baking state" @@ fun () -> - Data_encoding.Binary.to_bytes_exn - state_data_encoding - {level_data; locked_round_data; attestable_payload_data} - in - let filename_tmp = filename ^ "_tmp" in - let*! () = - Baking_profiler.record_s "writing baking state" @@ fun () -> - Lwt_io.with_file - ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] - ~mode:Output - filename_tmp - (fun channel -> - Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) - in - let*! () = Lwt_unix.rename filename_tmp filename in - return_unit + (let cctxt = state.global_state.cctxt in + let location = + Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State + in + let filename = + Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) + in + protect @@ fun () -> + let () = (() [@profiler.record "waiting lock"]) in + cctxt#with_lock @@ fun () -> + let () = (() [@profiler.stop]) in + let level_data = state.level_state.current_level in + let locked_round_data = state.level_state.locked_round in + let attestable_payload_data = state.level_state.attestable_payload in + let bytes = + (Data_encoding.Binary.to_bytes_exn + state_data_encoding + {level_data; locked_round_data; attestable_payload_data} + [@profiler.record_f "serializing baking state"]) + in + let filename_tmp = filename ^ "_tmp" in + let*! () = + (Lwt_io.with_file + ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] + ~mode:Output + filename_tmp + (fun channel -> + Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) + [@profiler.record_s "writing baking state"]) + in + let*! () = Lwt_unix.rename filename_tmp filename in + return_unit) + [@profiler.record_s "record state"] let may_record_new_state ~previous_state ~new_state = let open Lwt_result_syntax in diff --git a/src/proto_beta/lib_delegate/block_forge.ml b/src/proto_beta/lib_delegate/block_forge.ml index 49b0e5ae88c0..f3219af9b1f0 100644 --- a/src/proto_beta/lib_delegate/block_forge.ml +++ b/src/proto_beta/lib_delegate/block_forge.ml @@ -25,6 +25,7 @@ open Protocol open Alpha_context +module Profiler = Baking_profiler type unsigned_block = { unsigned_block_header : Block_header.t; @@ -249,27 +250,26 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = - Baking_profiler.record_s "finalize block header" @@ fun () -> - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:None + (finalize_block_header + ~shell_header:incremental.header + ~validation_result + ~operations_hash + ~pred_info + ~pred_resulting_context_hash + ~round + ~locked_round:None [@profiler.record_s "finalize block header"]) in let operations = List.map (List.map convert_operation) operations in let payload_hash = - Baking_profiler.record_f "compute payload hash" @@ fun () -> - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes + (let operation_hashes = + Stdlib.List.tl operations |> List.flatten + |> List.map Tezos_base.Operation.hash + in + Block_payload.hash + ~predecessor_hash:shell_header.predecessor + ~payload_round + operation_hashes) + [@profiler.record_f "compute payload hash"] in return (shell_header, operations, payload_hash) @@ -302,32 +302,29 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades ~context_index ~payload_hash cctxt = let open Lwt_result_syntax in let* incremental = - Baking_profiler.record_s "begin construction" @@ fun () -> - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id + (Baking_simulator.begin_construction + ~timestamp + ~protocol_data:faked_protocol_data + ~force_apply + ~pred_resulting_context_hash + context_index + pred_info + chain_id [@profiler.record_s "begin construction"]) in (* We still need to filter attestations. Two attestations could be referring to the same slot. *) let* incremental, ordered_pool = - Baking_profiler.record_s "filter consensus operations" @@ fun () -> - Operation_selection.filter_consensus_operations_only - incremental - ordered_pool + (Operation_selection.filter_consensus_operations_only + incremental + ordered_pool [@profiler.record_s "filter consensus operations"]) in let operations = Operation_pool.ordered_to_list_list ordered_pool in let operations_hash = - Baking_profiler.record_f "compute operations merkle root" @@ fun () -> - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) + (Operation_list_list_hash.compute + (List.map + (fun sl -> + Operation_list_hash.compute (List.map Operation.hash_packed sl)) + operations) [@profiler.record_f "compute operations merkle root"]) in (* We need to compute the final [operations_hash] before finalizing the block because it will be used in the cache's nonce. *) @@ -335,8 +332,8 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades {incremental with header = {incremental.header with operations_hash}} in let* validation_result = - Baking_profiler.record_s "finalize construction" @@ fun () -> - Baking_simulator.finalize_construction incremental + (Baking_simulator.finalize_construction + incremental [@profiler.record_s "finalize construction"]) in let validation_result = Option.map fst validation_result in let* changed = @@ -370,15 +367,15 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = - Baking_profiler.record_s "finalize block header" @@ fun () -> - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:locked_round_when_no_validation_result + (finalize_block_header + ~shell_header:incremental.header + ~validation_result + ~operations_hash + ~pred_info + ~pred_resulting_context_hash + ~round + ~locked_round:locked_round_when_no_validation_result + [@profiler.record_s "finalize block header"]) in let operations = List.map (List.map convert_operation) operations in return (shell_header, operations, payload_hash) @@ -400,10 +397,9 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id (* We cannot include operations that are not live with respect to our predecessor otherwise the node would reject the block. *) let filtered_pool = - Baking_profiler.record_f "filter non live operations" @@ fun () -> - retain_live_operations_only - ~live_blocks:pred_live_blocks - operation_pool + (retain_live_operations_only + ~live_blocks:pred_live_blocks + operation_pool [@profiler.record_f "filter non live operations"]) in Filter filtered_pool | Apply _ as x -> x @@ -419,17 +415,16 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "filter via node" @@ fun () -> - filter_via_node - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt + (filter_via_node + ~chain_id + ~faked_protocol_data + ~fees_config + ~hard_gas_limit_per_block + ~timestamp + ~pred_info + ~payload_round + ~operation_pool + cctxt [@profiler.record_s "filter via node"]) | Node, Apply {ordered_pool; payload_hash} -> let faked_protocol_data = forge_faked_protocol_data @@ -440,15 +435,14 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "apply via node" @@ fun () -> - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt + (apply_via_node + ~chain_id + ~faked_protocol_data + ~timestamp + ~pred_info + ~ordered_pool + ~payload_hash + cctxt [@profiler.record_s "apply via node"]) | Local context_index, Filter operation_pool -> let faked_protocol_data = forge_faked_protocol_data @@ -458,22 +452,22 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "filter with context" @@ fun () -> - filter_with_context - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~context_index - ~payload_round - ~operation_pool - cctxt + + (filter_with_context + ~chain_id + ~faked_protocol_data + ~fees_config + ~hard_gas_limit_per_block + ~user_activated_upgrades + ~timestamp + ~pred_info + ~pred_resulting_context_hash + ~force_apply + ~round + ~context_index + ~payload_round + ~operation_pool + cctxt [@profiler.record_s "filter with context"]) | Local context_index, Apply {ordered_pool; payload_hash} -> let faked_protocol_data = forge_faked_protocol_data @@ -484,38 +478,37 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - Baking_profiler.record_s "apply with context" @@ fun () -> - apply_with_context - ~chain_id - ~faked_protocol_data - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~ordered_pool - ~context_index - ~payload_hash - cctxt + (apply_with_context + ~chain_id + ~faked_protocol_data + ~user_activated_upgrades + ~timestamp + ~pred_info + ~pred_resulting_context_hash + ~force_apply + ~round + ~ordered_pool + ~context_index + ~payload_hash + cctxt [@profiler.record_s "apply with context"]) in let* contents = - Baking_profiler.record_s "compute proof of work" @@ fun () -> - Baking_pow.mine - ~proof_of_work_threshold:constants.proof_of_work_threshold - shell_header - (fun proof_of_work_nonce -> - { - Block_header.payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce; - per_block_votes = - { - liquidity_baking_vote = liquidity_baking_toggle_vote; - adaptive_issuance_vote; - }; - }) + (Baking_pow.mine + ~proof_of_work_threshold:constants.proof_of_work_threshold + shell_header + (fun proof_of_work_nonce -> + { + Block_header.payload_hash; + payload_round; + seed_nonce_hash; + proof_of_work_nonce; + per_block_votes = + { + liquidity_baking_vote = liquidity_baking_toggle_vote; + adaptive_issuance_vote; + }; + }) + [@profiler.record_s "compute proof of work"]) in let unsigned_block_header = { diff --git a/src/proto_beta/lib_delegate/client_daemon.ml b/src/proto_beta/lib_delegate/client_daemon.ml index 5231886132f0..8081f8b1dced 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -74,6 +74,8 @@ let may_start_profiler baking_dir = | _ -> () module Baker = struct + module Profiler = Baking_profiler + let run (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes ?extra_operations ?dal_node_endpoint ?dal_node_timeout_percentage @@ -152,7 +154,7 @@ module Baker = struct Lwt.return_unit) in let () = may_start_profiler cctxt#get_base_dir in - Baking_profiler.record "initialization" ; + let () = (() [@profiler.record "initialization"]) in let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_beta/lib_delegate/node_rpc.ml b/src/proto_beta/lib_delegate/node_rpc.ml index 019289f5ae62..357b02b8ff17 100644 --- a/src/proto_beta/lib_delegate/node_rpc.ml +++ b/src/proto_beta/lib_delegate/node_rpc.ml @@ -34,7 +34,7 @@ module Events = Baking_events.Node_rpc module Profiler = struct include (val Profiler.wrap Baking_profiler.node_rpc_profiler) - let reset_block_section = + let[@warning "-32"] reset_block_section = Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler end @@ -107,10 +107,10 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = - Profiler.record_f "operations classification" @@ fun () -> - WithExceptions.Option.get - ~loc:__LOC__ - (Operation_pool.extract_operations_of_list_list operations) + (WithExceptions.Option.get + ~loc:__LOC__ + (Operation_pool.extract_operations_of_list_list operations) + [@profiler.record_f "operations classification"]) in let prequorum = Option.bind preattestations extract_prequorum in (payload_hash, payload_round, prequorum, quorum, payload) @@ -130,61 +130,60 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash block_header = let open Lwt_result_syntax in - Profiler.record_s - ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info") - @@ fun () -> - let* operations = - match operations with - | None when not in_protocol -> return_nil - | None -> - let open Protocol_client_context in - Profiler.record_s - ("retrieve block " - ^ Block_hash.to_short_b58check block_hash - ^ " operations") - @@ fun () -> - let* operations = - Alpha_block_services.Operations.operations - cctxt - ~chain - ~block:(`Hash (block_hash, 0)) - () - in - let packed_operations = - List.map - (fun l -> - List.map - (fun {Alpha_block_services.shell; protocol_data; _} -> - {Alpha_context.shell; protocol_data}) - l) - operations - in - return packed_operations - | Some operations -> - let parse_op (raw_op : Tezos_base.Operation.t) = - let protocol_data = - Profiler.aggregate_f "parse operation" @@ fun () -> - Data_encoding.Binary.of_bytes_exn - Operation.protocol_data_encoding - raw_op.proto + (let* operations = + match operations with + | None when not in_protocol -> return_nil + | None -> + let open Protocol_client_context in + (let* operations = + Alpha_block_services.Operations.operations + cctxt + ~chain + ~block:(`Hash (block_hash, 0)) + () in - {shell = raw_op.shell; protocol_data} - in - protect @@ fun () -> - return - (List.mapi - (fun i -> function - | [] -> [] - | l -> - Profiler.record_f - (Printf.sprintf "parse operations (pass:%d)" i) - @@ fun () -> List.map parse_op l) - operations) - in - let*? block_info = - info_of_header_and_ops ~in_protocol block_hash block_header operations - in - return block_info + let packed_operations = + List.map + (fun l -> + List.map + (fun {Alpha_block_services.shell; protocol_data; _} -> + {Alpha_context.shell; protocol_data}) + l) + operations + in + return packed_operations) + [@profiler.record_s + "retrieve block " + ^ Block_hash.to_short_b58check block_hash + ^ " operations"] + | Some operations -> + let parse_op (raw_op : Tezos_base.Operation.t) = + let protocol_data = + (Data_encoding.Binary.of_bytes_exn + Operation.protocol_data_encoding + raw_op.proto [@profiler.aggregate_f "parse operation"]) + in + {shell = raw_op.shell; protocol_data} + in + protect @@ fun () -> + return + (List.mapi + (fun [@warning "-27"] i -> function + | [] -> [] + | l -> + List.map + parse_op + l + [@profiler.record_f + Printf.sprintf "parse operations (pass:%d)" i]) + operations) + in + let*? block_info = + info_of_header_and_ops ~in_protocol block_hash block_header operations + in + return block_info) + [@profiler.record_s + "compute block " ^ Block_hash.to_short_b58check block_hash ^ " info"] let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain block_hash (block_header : Tezos_base.Block_header.t) = @@ -197,28 +196,37 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* is_proposal_in_protocol, predecessor = match predecessor_opt with | Some predecessor -> - Profiler.mark - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ "):cache_hit"; - ] ; + let () = + (() + [@profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_hit"; + ]]) + in return ( predecessor.shell.proto_level = block_header.shell.proto_level, predecessor ) | None -> - Profiler.mark - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ "):cache_miss"; - ] ; + let () = + (() + [@profiler.mark + [ + "pred_block(" + ^ Block_hash.to_short_b58check predecessor_hash + ^ "):cache_miss"; + ]]) + in let* { current_protocol = pred_current_protocol; next_protocol = pred_next_protocol; } = - Profiler.record_s "pred block protocol RPC" @@ fun () -> - Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () + (Shell_services.Blocks.protocols + cctxt + ~chain + ~block:pred_block + () [@profiler.record_s "pred block protocol RPC"]) in let is_proposal_in_protocol = Protocol_hash.(pred_next_protocol = Protocol.hash) @@ -231,10 +239,9 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () in let predecessor_header = - Profiler.record_f "parse pred block header" @@ fun () -> - Data_encoding.Binary.of_bytes_exn - Tezos_base.Block_header.encoding - raw_header_b + (Data_encoding.Binary.of_bytes_exn + Tezos_base.Block_header.encoding + raw_header_b [@profiler.record_f "parse pred block header"]) in compute_block_info cctxt @@ -254,16 +261,24 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain let* block = match block_opt with | Some pi -> - Profiler.mark - ["new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"] ; + let () = + (() + [@profiler.mark + [ + "new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"; + ]]) + in return pi | None -> - Profiler.mark - [ - "new_block(" - ^ Block_hash.to_short_b58check block_hash - ^ "):cache_miss"; - ] ; + let () = + (() + [@profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ]]) + in let* pi = compute_block_info cctxt @@ -279,9 +294,9 @@ let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain return {block; predecessor} let proposal cctxt ?cache ?operations ~chain block_hash block_header = - Profiler.record_s "proposal_computation" @@ fun () -> - protect @@ fun () -> - proposal cctxt ?cache ?operations ~chain block_hash block_header + ( (protect @@ fun () -> + proposal cctxt ?cache ?operations ~chain block_hash block_header) + [@profiler.record_s "proposal_computation"] ) let monitor_valid_proposals cctxt ~chain ?cache () = let open Lwt_result_syntax in @@ -291,16 +306,18 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - Profiler.reset_block_section block_hash ; - Profiler.record_s "received valid proposal" @@ fun () -> - let*! map_result = - proposal cctxt ?cache ~operations ~chain block_hash block_header - in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_valid_proposals err) in - Lwt.return_none + let () = (() [@profiler.reset_block_section block_hash]) in + (let*! map_result = + proposal cctxt ?cache ~operations ~chain block_hash block_header + in + match map_result with + | Ok proposal -> Lwt.return_some proposal + | Error err -> + let*! () = + Events.(emit error_while_monitoring_valid_proposals err) + in + Lwt.return_none) + [@profiler.record_s "received valid proposal"] in Lwt_stream.filter_map_s map block_stream in @@ -314,14 +331,16 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - Profiler.reset_block_section block_hash ; - Profiler.record_s "received new head" @@ fun () -> - let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_heads err) in - Lwt.return_none + let () = (() [@profiler.reset_block_section block_hash]) in + (let*! map_result = + proposal cctxt ?cache ~chain block_hash block_header + in + match map_result with + | Ok proposal -> Lwt.return_some proposal + | Error err -> + let*! () = Events.(emit error_while_monitoring_heads err) in + Lwt.return_none) + [@profiler.record_s "received new head"] in Lwt_stream.filter_map_s map block_stream in diff --git a/src/proto_beta/lib_delegate/operation_selection.ml b/src/proto_beta/lib_delegate/operation_selection.ml index c9ce27b90f79..63ed8239b288 100644 --- a/src/proto_beta/lib_delegate/operation_selection.ml +++ b/src/proto_beta/lib_delegate/operation_selection.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Operation_pool module Events = Baking_events.Selection +module Profiler = Baking_profiler let quota = Main.validation_passes @@ -181,23 +182,22 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( - Baking_profiler.record_f "checking operation receipt roundtrip" - @@ fun () -> - (* Check that the metadata are serializable/deserializable *) - let encoding_result = - let enc = Protocol.operation_receipt_encoding in - Option.bind - (Data_encoding.Binary.to_bytes_opt enc receipt) - (Data_encoding.Binary.of_bytes_opt enc) - in - match encoding_result with - | None -> - let* () = - Events.(emit cannot_serialize_operation_metadata) - (Operation.hash_packed op) - in - return_none - | Some _b -> return_some resulting_state) + ((* Check that the metadata are serializable/deserializable *) + let encoding_result = + let enc = Protocol.operation_receipt_encoding in + Option.bind + (Data_encoding.Binary.to_bytes_opt enc receipt) + (Data_encoding.Binary.of_bytes_opt enc) + in + match encoding_result with + | None -> + let* () = + Events.(emit cannot_serialize_operation_metadata) + (Operation.hash_packed op) + in + return_none + | Some _b -> return_some resulting_state) + [@profiler.record_f "checking operation receipt roundtrip"]) let filter_valid_operations_up_to_quota inc (ops, quota) = let open Lwt_syntax in @@ -221,7 +221,7 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = let* inc'_opt = validate_operation inc op in match inc'_opt with | None -> - Baking_profiler.mark ["invalid operation filtered"] ; + let () = (() [@profiler.mark ["invalid operation filtered"]]) in return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) @@ -281,53 +281,51 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = - Baking_profiler.record_s "simulate and filter consensus" @@ fun () -> - filter_valid_operations_up_to_quota - initial_inc - (Prioritized_operation_set.operations consensus, consensus_quota) + (filter_valid_operations_up_to_quota + initial_inc + (Prioritized_operation_set.operations consensus, consensus_quota) + [@profiler.record_s "simulate and filter consensus"]) in let*! inc, votes = - Baking_profiler.record_s "simulate and filter votes" @@ fun () -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations votes, votes_quota) + (filter_valid_operations_up_to_quota + inc + (Prioritized_operation_set.operations votes, votes_quota) + [@profiler.record_s "simulate and filter votes"]) in let*! inc, anonymous = - Baking_profiler.record_s "simulate and filter anonymous" @@ fun () -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations anonymous, anonymous_quota) + (filter_valid_operations_up_to_quota + inc + (Prioritized_operation_set.operations anonymous, anonymous_quota) + [@profiler.record_s "simulate and filter anonymous"]) in (* Sort the managers *) let prioritized_managers = - Baking_profiler.record_f "prioritize managers" @@ fun () -> - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers + (prioritize_managers + ~hard_gas_limit_per_block + ~minimal_fees + ~minimal_nanotez_per_gas_unit + ~minimal_nanotez_per_byte + managers [@profiler.record_f "prioritize managers"]) in let*! inc, managers = - Baking_profiler.record_s "simulate and filter managers" @@ fun () -> - filter_valid_managers_up_to_quota - inc - ~hard_gas_limit_per_block - (PrioritizedManagerSet.elements prioritized_managers, managers_quota) + (filter_valid_managers_up_to_quota + inc + ~hard_gas_limit_per_block + (PrioritizedManagerSet.elements prioritized_managers, managers_quota) + [@profiler.record_s "simulate and filter managers"]) in let operations = [consensus; votes; anonymous; managers] in let operations_hash = - Baking_profiler.record_f "compute operations merkle root" @@ fun () -> - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) + (Operation_list_list_hash.compute + (List.map + (fun sl -> + Operation_list_hash.compute (List.map Operation.hash_packed sl)) + operations) [@profiler.record_f "compute operations merkle root"]) in let inc = {inc with header = {inc.header with operations_hash}} in let* result = - Baking_profiler.record_s "finalize construction" @@ fun () -> - Baking_simulator.finalize_construction inc + (Baking_simulator.finalize_construction + inc [@profiler.record_s "finalize construction"]) in match result with | Some (validation_result, block_header_metadata) -> -- GitLab From b7a7a737a39a8d1dd81efa4d7c1237b1402d1bfd Mon Sep 17 00:00:00 2001 From: Gauthier SEBILLE Date: Thu, 17 Aug 2023 21:26:08 +0200 Subject: [PATCH 15/19] Profiler: plug RPC profiler --- manifest/product_octez.ml | 3 +- src/bin_node/node_run_command.ml | 9 ++++- src/lib_rpc_http/RPC_client.ml | 20 +++++++++++ src/lib_rpc_http/RPC_profiler.ml | 33 +++++++++++++++++++ src/lib_rpc_http/RPC_profiler.mli | 30 +++++++++++++++++ src/lib_rpc_http/dune | 2 +- src/lib_shell_services/shell_profiling.ml | 1 + .../lib_delegate/client_daemon.ml | 3 +- src/proto_020_PsParisC/lib_delegate/dune | 2 ++ src/proto_alpha/lib_delegate/client_daemon.ml | 3 +- src/proto_alpha/lib_delegate/dune | 2 ++ src/proto_beta/lib_delegate/client_daemon.ml | 3 +- src/proto_beta/lib_delegate/dune | 2 ++ 13 files changed, 107 insertions(+), 6 deletions(-) create mode 100644 src/lib_rpc_http/RPC_profiler.ml create mode 100644 src/lib_rpc_http/RPC_profiler.mli diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 8b02d2065ba3..e6a3935f35f6 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -3692,7 +3692,7 @@ let octez_rpc_http_client = octez_rpc; octez_rpc_http |> open_; ] - ~modules:["RPC_client"] + ~modules:["RPC_client"; "RPC_profiler"] let octez_rpc_http_client_unix = octez_lib @@ -6328,6 +6328,7 @@ let hash = Protocol.hash octez_context |> open_; octez_context_memory |> if_ (N.(number >= 012) && N.(number <= 019)); octez_rpc_http_client_unix |> if_ N.(number >= 011); + octez_rpc_http_client |> if_ N.(number >= 011) |> open_; octez_context_ops |> if_ N.(number >= 011) |> open_; octez_rpc; octez_rpc_http |> open_; diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 3656fe8471ec..572373f76433 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -13,6 +13,9 @@ type error += RPC_Port_already_in_use of P2p_point.Id.t list type error += Invalid_sandbox_file of string +(** Profiler for RPC server. *) +module Profiler = (val Profiler.wrap Shell_profiling.rpc_server_profiler) + let () = register_error_kind `Permanent @@ -452,7 +455,11 @@ let launch_rpc_server ?middleware (config : Config_file.t) dir rpc_server_kind if path = "/metrics" then let*! response = Metrics_server.callback conn req body in Lwt.return (`Response response) - else Tezos_rpc_http_server.RPC_server.resto_callback server conn req body + else + (* Every call on endpoints which is not in [/metrics] + path will be logged inside the RPC report. *) + Profiler.span_s [path] @@ fun () -> + Tezos_rpc_http_server.RPC_server.resto_callback server conn req body in let update_metrics uri meth = Prometheus.Summary.(time (labels rpc_metrics [uri; meth]) Sys.time) diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index 52c042521140..890421596803 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -23,6 +23,11 @@ (* *) (*****************************************************************************) +(** Profiler for RPC client. + Here, we want every [call_service] to be profiled. *) +module Profiler = + (val Tezos_base.Profiler.wrap RPC_profiler.rpc_client_profiler) + module type S = sig module type LOGGER = sig type request @@ -436,6 +441,14 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (service : (_, _, p, q, i, o) Tezos_rpc.Service.t) ~on_chunk ~on_close (params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t = let open Lwt_syntax in + let service_path = + let open Client.Service.Internal in + let {path; _} = to_service service in + from_path path |> Resto.Path.to_string + in + Profiler.span_s + ["Call_streamed_service: " ^ Uri.to_string base ^ service_path] + @@ fun () -> let* ans = Client.call_streamed_service accept @@ -455,6 +468,13 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (service : (_, _, p, q, i, o) Tezos_rpc.Service.t) (params : p) (query : q) (body : i) : o tzresult Lwt.t = let open Lwt_syntax in + let service_path = + let open Client.Service.Internal in + let {path; _} = to_service service in + from_path path |> Resto.Path.to_string + in + Profiler.span_s ["Call_service: " ^ Uri.to_string base ^ service_path] + @@ fun () -> let* ans = Client.call_service ?logger diff --git a/src/lib_rpc_http/RPC_profiler.ml b/src/lib_rpc_http/RPC_profiler.ml new file mode 100644 index 000000000000..5c9b8997618b --- /dev/null +++ b/src/lib_rpc_http/RPC_profiler.ml @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 Marigold, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Profiler + +let rpc_client_profiler = unplugged () + +let init profiler_maker = + plug rpc_client_profiler (profiler_maker ~name:"rpc_client") + +include (val wrap rpc_client_profiler) diff --git a/src/lib_rpc_http/RPC_profiler.mli b/src/lib_rpc_http/RPC_profiler.mli new file mode 100644 index 000000000000..5ab6b291678c --- /dev/null +++ b/src/lib_rpc_http/RPC_profiler.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 Marigold, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Unplug RPC client profiler. *) +val rpc_client_profiler : Profiler.profiler + +(** Plug the RPC client profiler given its name and Profiler instance. *) +val init : (name:string -> Profiler.instance) -> unit diff --git a/src/lib_rpc_http/dune b/src/lib_rpc_http/dune index e95e149f2939..fb2c901b3616 100644 --- a/src/lib_rpc_http/dune +++ b/src/lib_rpc_http/dune @@ -28,7 +28,7 @@ (:standard) -open Tezos_base.TzPervasives -open Tezos_rpc_http) - (modules RPC_client)) + (modules RPC_client RPC_profiler)) (library (name tezos_rpc_http_client_unix) diff --git a/src/lib_shell_services/shell_profiling.ml b/src/lib_shell_services/shell_profiling.ml index 143fe71ca95f..6ec04f435982 100644 --- a/src/lib_shell_services/shell_profiling.ml +++ b/src/lib_shell_services/shell_profiling.ml @@ -45,6 +45,7 @@ let all_profilers = ("merge", merge_profiler); ("p2p_reader", p2p_reader_profiler); ("requester", requester_profiler); + ("rpc_server", rpc_server_profiler); ] let activate_all ~profiler_maker = diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml index 8081f8b1dced..d7940156b5d1 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -70,7 +70,8 @@ let may_start_profiler baking_dir = Tezos_base_unix.Simple_profiler.auto_write_to_txt_file Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) in - Baking_profiler.init profiler_maker + Baking_profiler.init profiler_maker ; + RPC_profiler.init profiler_maker | _ -> () module Baker = struct diff --git a/src/proto_020_PsParisC/lib_delegate/dune b/src/proto_020_PsParisC/lib_delegate/dune index 955aba951667..eb5e6d1aeb25 100644 --- a/src/proto_020_PsParisC/lib_delegate/dune +++ b/src/proto_020_PsParisC/lib_delegate/dune @@ -22,6 +22,7 @@ octez-shell-libs.shell-context octez-libs.tezos-context octez-libs.rpc-http-client-unix + octez-libs.rpc-http-client octez-shell-libs.context-ops octez-libs.rpc octez-libs.rpc-http @@ -45,6 +46,7 @@ -open Tezos_stdlib_unix -open Tezos_shell_context -open Tezos_context + -open Tezos_rpc_http_client -open Tezos_context_ops -open Tezos_rpc_http -open Tezos_crypto_dal) diff --git a/src/proto_alpha/lib_delegate/client_daemon.ml b/src/proto_alpha/lib_delegate/client_daemon.ml index 5231886132f0..16d92a3ba60a 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.ml +++ b/src/proto_alpha/lib_delegate/client_daemon.ml @@ -70,7 +70,8 @@ let may_start_profiler baking_dir = Tezos_base_unix.Simple_profiler.auto_write_to_txt_file Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) in - Baking_profiler.init profiler_maker + Baking_profiler.init profiler_maker ; + RPC_profiler.init profiler_maker | _ -> () module Baker = struct diff --git a/src/proto_alpha/lib_delegate/dune b/src/proto_alpha/lib_delegate/dune index eee391da2a43..2d68bcb9f9c7 100644 --- a/src/proto_alpha/lib_delegate/dune +++ b/src/proto_alpha/lib_delegate/dune @@ -21,6 +21,7 @@ octez-libs.stdlib-unix octez-libs.tezos-context octez-libs.rpc-http-client-unix + octez-libs.rpc-http-client octez-shell-libs.context-ops octez-libs.rpc octez-libs.rpc-http @@ -43,6 +44,7 @@ -open Tezos_stdlib -open Tezos_stdlib_unix -open Tezos_context + -open Tezos_rpc_http_client -open Tezos_context_ops -open Tezos_rpc_http -open Tezos_crypto_dal) diff --git a/src/proto_beta/lib_delegate/client_daemon.ml b/src/proto_beta/lib_delegate/client_daemon.ml index 8081f8b1dced..d7940156b5d1 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -70,7 +70,8 @@ let may_start_profiler baking_dir = Tezos_base_unix.Simple_profiler.auto_write_to_txt_file Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) in - Baking_profiler.init profiler_maker + Baking_profiler.init profiler_maker ; + RPC_profiler.init profiler_maker | _ -> () module Baker = struct diff --git a/src/proto_beta/lib_delegate/dune b/src/proto_beta/lib_delegate/dune index 4921c9e3f5fb..4084f678ce4d 100644 --- a/src/proto_beta/lib_delegate/dune +++ b/src/proto_beta/lib_delegate/dune @@ -21,6 +21,7 @@ octez-libs.stdlib-unix octez-libs.tezos-context octez-libs.rpc-http-client-unix + octez-libs.rpc-http-client octez-shell-libs.context-ops octez-libs.rpc octez-libs.rpc-http @@ -43,6 +44,7 @@ -open Tezos_stdlib -open Tezos_stdlib_unix -open Tezos_context + -open Tezos_rpc_http_client -open Tezos_context_ops -open Tezos_rpc_http -open Tezos_crypto_dal) -- GitLab From 6af3ae1588c46d3008b3284d466a731221a59a11 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Tue, 20 Aug 2024 11:30:35 +0200 Subject: [PATCH 16/19] RPC: use ppx profiler --- src/bin_node/dune | 1 + src/bin_node/node_run_command.ml | 7 +++- src/lib_rpc_http/RPC_client.ml | 66 ++++++++++++++++---------------- src/lib_rpc_http/dune | 1 + 4 files changed, 40 insertions(+), 35 deletions(-) diff --git a/src/bin_node/dune b/src/bin_node/dune index 8633a2136aa4..2fd739cc190b 100644 --- a/src/bin_node/dune +++ b/src/bin_node/dune @@ -159,6 +159,7 @@ (select void_for_linking-octez-protocol-alpha-libs-plugin-registerer from (octez-protocol-alpha-libs.plugin-registerer -> void_for_linking-octez-protocol-alpha-libs-plugin-registerer.empty) (-> void_for_linking-octez-protocol-alpha-libs-plugin-registerer.empty))) + (preprocess (pps octez-libs.ppx_profiler)) (link_flags (:standard) (:include %{workspace_root}/static-link-flags.sexp) diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 572373f76433..ea0f32a9f7ea 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -458,8 +458,11 @@ let launch_rpc_server ?middleware (config : Config_file.t) dir rpc_server_kind else (* Every call on endpoints which is not in [/metrics] path will be logged inside the RPC report. *) - Profiler.span_s [path] @@ fun () -> - Tezos_rpc_http_server.RPC_server.resto_callback server conn req body + Tezos_rpc_http_server.RPC_server.resto_callback + server + conn + req + body [@profiler.span_s [path]] in let update_metrics uri meth = Prometheus.Summary.(time (labels rpc_metrics [uri; meth]) Sys.time) diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index 890421596803..e02e3479dea3 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -441,52 +441,52 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (service : (_, _, p, q, i, o) Tezos_rpc.Service.t) ~on_chunk ~on_close (params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t = let open Lwt_syntax in - let service_path = + let[@warning "-26"] service_path = let open Client.Service.Internal in let {path; _} = to_service service in from_path path |> Resto.Path.to_string in - Profiler.span_s - ["Call_streamed_service: " ^ Uri.to_string base ^ service_path] - @@ fun () -> - let* ans = - Client.call_streamed_service - accept - ?logger - ?headers - ~base - ~on_chunk - ~on_close - service - params - query - body - in - handle accept ans + + (let* ans = + Client.call_streamed_service + accept + ?logger + ?headers + ~base + ~on_chunk + ~on_close + service + params + query + body + in + handle accept ans) + [@profiler.span_s + ["Call_streamed_service: " ^ Uri.to_string base ^ service_path]] let call_service (type p q i o) accept ?logger ?headers ~base (service : (_, _, p, q, i, o) Tezos_rpc.Service.t) (params : p) (query : q) (body : i) : o tzresult Lwt.t = let open Lwt_syntax in - let service_path = + let[@warning "-26"] service_path = let open Client.Service.Internal in let {path; _} = to_service service in from_path path |> Resto.Path.to_string in - Profiler.span_s ["Call_service: " ^ Uri.to_string base ^ service_path] - @@ fun () -> - let* ans = - Client.call_service - ?logger - ?headers - ~base - accept - service - params - query - body - in - handle accept ans + + (let* ans = + Client.call_service + ?logger + ?headers + ~base + accept + service + params + query + body + in + handle accept ans) + [@profiler.span_s ["Call_service: " ^ Uri.to_string base ^ service_path]] type config = { media_type : Media_type.Command_line.t; diff --git a/src/lib_rpc_http/dune b/src/lib_rpc_http/dune index fb2c901b3616..ac60c0a39593 100644 --- a/src/lib_rpc_http/dune +++ b/src/lib_rpc_http/dune @@ -24,6 +24,7 @@ octez-libs.resto-cohttp-client octez-libs.rpc octez-libs.rpc-http) + (preprocess (pps octez-libs.ppx_profiler)) (flags (:standard) -open Tezos_base.TzPervasives -- GitLab From 20773e1f45dc7d3a1e215594c99879cc07cd35e2 Mon Sep 17 00:00:00 2001 From: vbot Date: Thu, 3 Aug 2023 16:59:13 +0200 Subject: [PATCH 17/19] Profiler: augment environment variable with output directory option --- src/bin_node/node_replay_command.ml | 54 +++++++++++++------ src/bin_node/node_run_command.ml | 29 ++++++++-- .../lib_delegate/client_daemon.ml | 28 ++++++++-- src/proto_alpha/lib_delegate/client_daemon.ml | 28 ++++++++-- src/proto_beta/lib_delegate/client_daemon.ml | 28 ++++++++-- 5 files changed, 138 insertions(+), 29 deletions(-) diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index eadfeb2a990f..765344cbe1d1 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -495,22 +495,44 @@ let run ?verbosity ~singleprocess ~strict ~operation_metadata_size_limit let*! () = Tezos_base_unix.Internal_event_unix.init ~config:internal_events () in - (match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with - | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> - let max_lod = - match mode with - | "detailed" -> Profiler.Detailed - | "verbose" -> Profiler.Verbose - | _ -> Profiler.Terse - in - let instance = - Profiler.instance - Tezos_base_unix.Simple_profiler.auto_write_to_txt_file - Filename.Infix.(config.data_dir // "/node_profiling.txt", max_lod) - in - Tezos_base.Profiler.(plug main) instance ; - Tezos_protocol_environment.Environment_profiler.plug instance - | _ -> ()) ; + (let parse_profiling_env_var () = + match Sys.getenv_opt "PROFILING" with + | None -> (None, None) + | Some var -> ( + match String.split_on_char ':' var with + | [] -> (None, None) + | [x] -> (Some (String.lowercase_ascii x), None) + | x :: l -> + let output_dir = String.concat "" l in + if not (Sys.file_exists output_dir && Sys.is_directory output_dir) + then + Stdlib.failwith + "Profiling output is not a directory or does not exist." + else (Some (String.lowercase_ascii x), Some output_dir)) + in + match parse_profiling_env_var () with + | None, _ -> () + | ( Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode), + output_dir ) -> + let max_lod = + match mode with + | "detailed" -> Profiler.Detailed + | "verbose" -> Profiler.Verbose + | _ -> Profiler.Terse + in + let output_dir = + match output_dir with + | None -> config.data_dir + | Some output_dir -> output_dir + in + let instance = + Profiler.instance + Tezos_base_unix.Simple_profiler.auto_write_to_txt_file + Filename.Infix.(output_dir // "node_profiling.txt", max_lod) + in + Tezos_base.Profiler.(plug main) instance ; + Tezos_protocol_environment.Environment_profiler.plug instance + | _ -> ()) ; Updater.init (Data_version.protocol_dir config.data_dir) ; Lwt_exit.( wrap_and_exit diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index ea0f32a9f7ea..e7da143a91ed 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -733,18 +733,39 @@ let run ?verbosity ?sandbox ?target ?(cli_warnings = []) let*! () = Tezos_base_unix.Internal_event_unix.init ~config:internal_events () in + let parse_profiling_env_var () = + match Sys.getenv_opt "PROFILING" with + | None -> (None, None) + | Some var -> ( + match String.split_on_char ':' var with + | [] -> (None, None) + | [x] -> (Some (String.lowercase_ascii x), None) + | x :: l -> + let output_dir = String.concat "" l in + if not (Sys.file_exists output_dir && Sys.is_directory output_dir) + then + Stdlib.failwith + "Profiling output is not a directory or does not exist." + else (Some (String.lowercase_ascii x), Some output_dir)) + in let () = - match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with - | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) - -> + match parse_profiling_env_var () with + | None, _ -> () + | ( Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode), + output_dir ) -> let max_lod = match mode with | "detailed" -> Profiler.Detailed | "verbose" -> Profiler.Verbose | _ -> Profiler.Terse in + let output_dir = + match output_dir with + | None -> config.data_dir + | Some output_dir -> output_dir + in let profiler_maker = - Tezos_shell.Profiler_directory.profiler_maker config.data_dir max_lod + Tezos_shell.Profiler_directory.profiler_maker output_dir max_lod in Shell_profiling.activate_all ~profiler_maker | _ -> () diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml index d7940156b5d1..517a0510064f 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -57,18 +57,40 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = Node_rpc.await_protocol_activation cctxt ~chain () let may_start_profiler baking_dir = - match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with - | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let parse_profiling_env_var () = + match Sys.getenv_opt "PROFILING" with + | None -> (None, None) + | Some var -> ( + match String.split_on_char ':' var with + | [] -> (None, None) + | [x] -> (Some (String.lowercase_ascii x), None) + | x :: l -> + let output_dir = String.concat "" l in + if not (Sys.file_exists output_dir && Sys.is_directory output_dir) + then + Stdlib.failwith + "Profiling output is not a directory or does not exist." + else (Some (String.lowercase_ascii x), Some output_dir)) + in + match parse_profiling_env_var () with + | None, _ -> () + | ( Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode), + output_dir ) -> let max_lod = match mode with | "detailed" -> Profiler.Detailed | "verbose" -> Profiler.Verbose | _ -> Profiler.Terse in + let output_dir = + match output_dir with + | None -> baking_dir + | Some output_dir -> output_dir + in let profiler_maker ~name = Profiler.instance Tezos_base_unix.Simple_profiler.auto_write_to_txt_file - Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + Filename.Infix.((output_dir // name) ^ "_profiling.txt", max_lod) in Baking_profiler.init profiler_maker ; RPC_profiler.init profiler_maker diff --git a/src/proto_alpha/lib_delegate/client_daemon.ml b/src/proto_alpha/lib_delegate/client_daemon.ml index 16d92a3ba60a..a05402b307bd 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.ml +++ b/src/proto_alpha/lib_delegate/client_daemon.ml @@ -57,18 +57,40 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = Node_rpc.await_protocol_activation cctxt ~chain () let may_start_profiler baking_dir = - match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with - | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let parse_profiling_env_var () = + match Sys.getenv_opt "PROFILING" with + | None -> (None, None) + | Some var -> ( + match String.split_on_char ':' var with + | [] -> (None, None) + | [x] -> (Some (String.lowercase_ascii x), None) + | x :: l -> + let output_dir = String.concat "" l in + if not (Sys.file_exists output_dir && Sys.is_directory output_dir) + then + Stdlib.failwith + "Profiling output is not a directory or does not exist." + else (Some (String.lowercase_ascii x), Some output_dir)) + in + match parse_profiling_env_var () with + | None, _ -> () + | ( Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode), + output_dir ) -> let max_lod = match mode with | "detailed" -> Profiler.Detailed | "verbose" -> Profiler.Verbose | _ -> Profiler.Terse in + let output_dir = + match output_dir with + | None -> baking_dir + | Some output_dir -> output_dir + in let profiler_maker ~name = Profiler.instance Tezos_base_unix.Simple_profiler.auto_write_to_txt_file - Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + Filename.Infix.((output_dir // name) ^ "_profiling.txt", max_lod) in Baking_profiler.init profiler_maker ; RPC_profiler.init profiler_maker diff --git a/src/proto_beta/lib_delegate/client_daemon.ml b/src/proto_beta/lib_delegate/client_daemon.ml index d7940156b5d1..517a0510064f 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -57,18 +57,40 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = Node_rpc.await_protocol_activation cctxt ~chain () let may_start_profiler baking_dir = - match Option.map String.lowercase_ascii @@ Sys.getenv_opt "PROFILING" with - | Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode) -> + let parse_profiling_env_var () = + match Sys.getenv_opt "PROFILING" with + | None -> (None, None) + | Some var -> ( + match String.split_on_char ':' var with + | [] -> (None, None) + | [x] -> (Some (String.lowercase_ascii x), None) + | x :: l -> + let output_dir = String.concat "" l in + if not (Sys.file_exists output_dir && Sys.is_directory output_dir) + then + Stdlib.failwith + "Profiling output is not a directory or does not exist." + else (Some (String.lowercase_ascii x), Some output_dir)) + in + match parse_profiling_env_var () with + | None, _ -> () + | ( Some (("true" | "on" | "yes" | "terse" | "detailed" | "verbose") as mode), + output_dir ) -> let max_lod = match mode with | "detailed" -> Profiler.Detailed | "verbose" -> Profiler.Verbose | _ -> Profiler.Terse in + let output_dir = + match output_dir with + | None -> baking_dir + | Some output_dir -> output_dir + in let profiler_maker ~name = Profiler.instance Tezos_base_unix.Simple_profiler.auto_write_to_txt_file - Filename.Infix.((baking_dir // name) ^ "_profiling.txt", max_lod) + Filename.Infix.((output_dir // name) ^ "_profiling.txt", max_lod) in Baking_profiler.init profiler_maker ; RPC_profiler.init profiler_maker -- GitLab From 98a6b2cfe96801a652480ae3921f726eca6fa857 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Wed, 21 Aug 2024 15:36:52 +0200 Subject: [PATCH 18/19] Manifest: Add preprocess with ppx-profiler to libraries --- manifest/product_octez.ml | 6 ++++++ opam/tezos-protocol-000-Ps9mPmXa.opam | 1 + opam/tezos-protocol-001-PtCJ7pwo.opam | 1 + opam/tezos-protocol-002-PsYLVpVv.opam | 1 + opam/tezos-protocol-003-PsddFKi3.opam | 1 + opam/tezos-protocol-004-Pt24m4xi.opam | 1 + opam/tezos-protocol-005-PsBABY5H.opam | 1 + opam/tezos-protocol-005-PsBabyM1.opam | 1 + opam/tezos-protocol-006-PsCARTHA.opam | 1 + opam/tezos-protocol-007-PsDELPH1.opam | 1 + opam/tezos-protocol-008-PtEdo2Zk.opam | 1 + opam/tezos-protocol-008-PtEdoTez.opam | 1 + opam/tezos-protocol-009-PsFLoren.opam | 1 + opam/tezos-protocol-010-PtGRANAD.opam | 1 + opam/tezos-protocol-011-PtHangz2.opam | 2 +- opam/tezos-protocol-012-Psithaca.opam | 2 +- opam/tezos-protocol-013-PtJakart.opam | 2 +- opam/tezos-protocol-014-PtKathma.opam | 2 +- opam/tezos-protocol-015-PtLimaPt.opam | 2 +- opam/tezos-protocol-016-PtMumbai.opam | 2 +- opam/tezos-protocol-017-PtNairob.opam | 2 +- opam/tezos-protocol-018-Proxford.opam | 2 +- opam/tezos-protocol-019-PtParisB.opam | 2 +- opam/tezos-protocol-020-PsParisC.opam | 2 +- opam/tezos-protocol-alpha.opam | 2 +- opam/tezos-protocol-beta.opam | 2 +- opam/tezos-protocol-demo-counter.opam | 1 + opam/tezos-protocol-demo-noops.opam | 1 + opam/tezos-protocol-genesis.opam | 1 + src/proto_000_Ps9mPmXa/lib_protocol/dune | 1 + src/proto_001_PtCJ7pwo/lib_protocol/dune | 1 + src/proto_002_PsYLVpVv/lib_protocol/dune | 1 + src/proto_003_PsddFKi3/lib_protocol/dune | 1 + src/proto_004_Pt24m4xi/lib_protocol/dune | 1 + src/proto_005_PsBABY5H/lib_protocol/dune | 1 + src/proto_005_PsBabyM1/lib_protocol/dune | 1 + src/proto_006_PsCARTHA/lib_protocol/dune | 1 + src/proto_007_PsDELPH1/lib_protocol/dune | 1 + src/proto_008_PtEdo2Zk/lib_protocol/dune | 1 + src/proto_008_PtEdoTez/lib_protocol/dune | 1 + src/proto_009_PsFLoren/lib_protocol/dune | 1 + src/proto_010_PtGRANAD/lib_protocol/dune | 1 + src/proto_011_PtHangz2/lib_protocol/dune | 1 + src/proto_012_Psithaca/lib_protocol/dune | 1 + src/proto_013_PtJakart/lib_protocol/dune | 1 + src/proto_014_PtKathma/lib_protocol/dune | 1 + src/proto_015_PtLimaPt/lib_protocol/dune | 1 + src/proto_016_PtMumbai/lib_protocol/dune | 1 + src/proto_017_PtNairob/lib_protocol/dune | 1 + src/proto_018_Proxford/lib_protocol/dune | 1 + src/proto_019_PtParisB/lib_protocol/dune | 1 + src/proto_020_PsParisC/lib_delegate/dune | 1 + src/proto_020_PsParisC/lib_protocol/dune | 1 + src/proto_alpha/lib_delegate/dune | 1 + src/proto_alpha/lib_protocol/dune | 1 + src/proto_beta/lib_delegate/dune | 1 + src/proto_beta/lib_protocol/dune | 1 + src/proto_demo_counter/lib_protocol/dune | 1 + src/proto_demo_noops/lib_protocol/dune | 1 + src/proto_genesis/lib_protocol/dune | 1 + 60 files changed, 65 insertions(+), 12 deletions(-) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index e6a3935f35f6..c120c7057f60 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -3156,6 +3156,7 @@ let octez_protocol_environment = ~internal_name:"tezos_protocol_environment" ~path:"src/lib_protocol_environment" ~documentation:[Dune.[S "package"; S "octez-proto-libs"]] + ~preprocess:(pps ppx_profiler) ~deps: [ zarith; @@ -3443,6 +3444,7 @@ let octez_validation = ~path:"src/lib_validation" ~synopsis:"Library for block validation" ~time_measurement_ppx:true + ~preprocess:(pps ppx_profiler) ~deps: [ octez_base |> open_ ~m:"TzPervasives"; @@ -3685,6 +3687,7 @@ let octez_rpc_http_client = ~internal_name:"tezos-rpc-http-client" ~path:"src/lib_rpc_http" ~synopsis:"Library of auto-documented RPCs (http client)" + ~preprocess:(pps ppx_profiler) ~deps: [ octez_base |> open_ ~m:"TzPervasives"; @@ -5605,6 +5608,7 @@ end = struct ~path:(path // "lib_protocol") ~modules:[sf "Tezos_protocol_environment_%s" name_underscore] ~linkall:true + ~preprocess:(pps ppx_profiler) ~deps:[octez_protocol_environment] ~dune: Dune. @@ -6443,6 +6447,7 @@ let hash = Protocol.hash ~internal_name:(sf "tezos_baking_%s_commands" name_dash) ~path:(path // "lib_delegate") ~synopsis:"Protocol-specific commands for baking" + ~preprocess:(pps ppx_profiler) ~deps: [ octez_base |> open_ ~m:"TzPervasives" @@ -7596,6 +7601,7 @@ let _octez_node = ~internal_name:"main" ~synopsis:"Tezos: `octez-node` binary" ~release_status:Released + ~preprocess:(pps ppx_profiler) ~with_macos_security_framework:true ~deps: ([ diff --git a/opam/tezos-protocol-000-Ps9mPmXa.opam b/opam/tezos-protocol-000-Ps9mPmXa.opam index 53556cdc43a8..97e4c948c406 100644 --- a/opam/tezos-protocol-000-Ps9mPmXa.opam +++ b/opam/tezos-protocol-000-Ps9mPmXa.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-001-PtCJ7pwo.opam b/opam/tezos-protocol-001-PtCJ7pwo.opam index c82a04bcc651..7e17dbb1e15b 100644 --- a/opam/tezos-protocol-001-PtCJ7pwo.opam +++ b/opam/tezos-protocol-001-PtCJ7pwo.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-002-PsYLVpVv.opam b/opam/tezos-protocol-002-PsYLVpVv.opam index ee54a8bc51da..9f686a13398f 100644 --- a/opam/tezos-protocol-002-PsYLVpVv.opam +++ b/opam/tezos-protocol-002-PsYLVpVv.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-003-PsddFKi3.opam b/opam/tezos-protocol-003-PsddFKi3.opam index f3fceea3c823..a9713486f246 100644 --- a/opam/tezos-protocol-003-PsddFKi3.opam +++ b/opam/tezos-protocol-003-PsddFKi3.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-004-Pt24m4xi.opam b/opam/tezos-protocol-004-Pt24m4xi.opam index 0986eb6f2059..dbef6d83aaac 100644 --- a/opam/tezos-protocol-004-Pt24m4xi.opam +++ b/opam/tezos-protocol-004-Pt24m4xi.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-005-PsBABY5H.opam b/opam/tezos-protocol-005-PsBABY5H.opam index 41621340c390..75439cdaa385 100644 --- a/opam/tezos-protocol-005-PsBABY5H.opam +++ b/opam/tezos-protocol-005-PsBABY5H.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-005-PsBabyM1.opam b/opam/tezos-protocol-005-PsBabyM1.opam index 5baa9c862ff5..d865d4786bd2 100644 --- a/opam/tezos-protocol-005-PsBabyM1.opam +++ b/opam/tezos-protocol-005-PsBabyM1.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-006-PsCARTHA.opam b/opam/tezos-protocol-006-PsCARTHA.opam index f167a51486a2..811dc81c71cd 100644 --- a/opam/tezos-protocol-006-PsCARTHA.opam +++ b/opam/tezos-protocol-006-PsCARTHA.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-007-PsDELPH1.opam b/opam/tezos-protocol-007-PsDELPH1.opam index 57bee1aa95db..b7b6f7f87837 100644 --- a/opam/tezos-protocol-007-PsDELPH1.opam +++ b/opam/tezos-protocol-007-PsDELPH1.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-008-PtEdo2Zk.opam b/opam/tezos-protocol-008-PtEdo2Zk.opam index 0538eb04fb19..81a9fac3dcad 100644 --- a/opam/tezos-protocol-008-PtEdo2Zk.opam +++ b/opam/tezos-protocol-008-PtEdo2Zk.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-008-PtEdoTez.opam b/opam/tezos-protocol-008-PtEdoTez.opam index b246459e93a0..1770440eae07 100644 --- a/opam/tezos-protocol-008-PtEdoTez.opam +++ b/opam/tezos-protocol-008-PtEdoTez.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-009-PsFLoren.opam b/opam/tezos-protocol-009-PsFLoren.opam index 15bb2006eb51..b5f271fa83e9 100644 --- a/opam/tezos-protocol-009-PsFLoren.opam +++ b/opam/tezos-protocol-009-PsFLoren.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-010-PtGRANAD.opam b/opam/tezos-protocol-010-PtGRANAD.opam index 85629ab27e81..dea86f7a4f84 100644 --- a/opam/tezos-protocol-010-PtGRANAD.opam +++ b/opam/tezos-protocol-010-PtGRANAD.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-011-PtHangz2.opam b/opam/tezos-protocol-011-PtHangz2.opam index ec85b0705f74..a6071ce81ee9 100644 --- a/opam/tezos-protocol-011-PtHangz2.opam +++ b/opam/tezos-protocol-011-PtHangz2.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-012-Psithaca.opam b/opam/tezos-protocol-012-Psithaca.opam index 06bd47fa76c6..e53e239a3bc5 100644 --- a/opam/tezos-protocol-012-Psithaca.opam +++ b/opam/tezos-protocol-012-Psithaca.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-013-PtJakart.opam b/opam/tezos-protocol-013-PtJakart.opam index 6504474a62d7..39ef609485ca 100644 --- a/opam/tezos-protocol-013-PtJakart.opam +++ b/opam/tezos-protocol-013-PtJakart.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-014-PtKathma.opam b/opam/tezos-protocol-014-PtKathma.opam index 07d1d330d86e..61c7f72c595e 100644 --- a/opam/tezos-protocol-014-PtKathma.opam +++ b/opam/tezos-protocol-014-PtKathma.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-015-PtLimaPt.opam b/opam/tezos-protocol-015-PtLimaPt.opam index 82ac8796fd2a..08384dcb8685 100644 --- a/opam/tezos-protocol-015-PtLimaPt.opam +++ b/opam/tezos-protocol-015-PtLimaPt.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-016-PtMumbai.opam b/opam/tezos-protocol-016-PtMumbai.opam index ad4406683950..7e427242b6fe 100644 --- a/opam/tezos-protocol-016-PtMumbai.opam +++ b/opam/tezos-protocol-016-PtMumbai.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-017-PtNairob.opam b/opam/tezos-protocol-017-PtNairob.opam index 394a736910cf..69679329c7fb 100644 --- a/opam/tezos-protocol-017-PtNairob.opam +++ b/opam/tezos-protocol-017-PtNairob.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-018-Proxford.opam b/opam/tezos-protocol-018-Proxford.opam index 6da2a37418c6..b4d24e2f9c6d 100644 --- a/opam/tezos-protocol-018-Proxford.opam +++ b/opam/tezos-protocol-018-Proxford.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-019-PtParisB.opam b/opam/tezos-protocol-019-PtParisB.opam index 438b468a610b..19377cb6ce34 100644 --- a/opam/tezos-protocol-019-PtParisB.opam +++ b/opam/tezos-protocol-019-PtParisB.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-020-PsParisC.opam b/opam/tezos-protocol-020-PsParisC.opam index aae6464e4274..8a08c7e3a29b 100644 --- a/opam/tezos-protocol-020-PsParisC.opam +++ b/opam/tezos-protocol-020-PsParisC.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-alpha.opam b/opam/tezos-protocol-alpha.opam index 161e5b66bfea..85db38713386 100644 --- a/opam/tezos-protocol-alpha.opam +++ b/opam/tezos-protocol-alpha.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-beta.opam b/opam/tezos-protocol-beta.opam index 00137eb3093e..7016db56f356 100644 --- a/opam/tezos-protocol-beta.opam +++ b/opam/tezos-protocol-beta.opam @@ -10,9 +10,9 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } - "octez-libs" { = version } ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/tezos-protocol-demo-counter.opam b/opam/tezos-protocol-demo-counter.opam index 5d41cb6e84bf..643c7292dcf8 100644 --- a/opam/tezos-protocol-demo-counter.opam +++ b/opam/tezos-protocol-demo-counter.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-demo-noops.opam b/opam/tezos-protocol-demo-noops.opam index 6d1c44d09325..6c4f8b9dba9c 100644 --- a/opam/tezos-protocol-demo-noops.opam +++ b/opam/tezos-protocol-demo-noops.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/opam/tezos-protocol-genesis.opam b/opam/tezos-protocol-genesis.opam index 0ff349096cd6..d0f546cb21cd 100644 --- a/opam/tezos-protocol-genesis.opam +++ b/opam/tezos-protocol-genesis.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.11.1" } "ocaml" { >= "4.14" } + "octez-libs" { = version } "octez-proto-libs" { = version } "octez-shell-libs" { = version } ] diff --git a/src/proto_000_Ps9mPmXa/lib_protocol/dune b/src/proto_000_Ps9mPmXa/lib_protocol/dune index 2585a70d44da..bf11800decca 100644 --- a/src/proto_000_Ps9mPmXa/lib_protocol/dune +++ b/src/proto_000_Ps9mPmXa/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_000_Ps9mPmXa)) diff --git a/src/proto_001_PtCJ7pwo/lib_protocol/dune b/src/proto_001_PtCJ7pwo/lib_protocol/dune index 15a05cc1b5e1..b95e04570a42 100644 --- a/src/proto_001_PtCJ7pwo/lib_protocol/dune +++ b/src/proto_001_PtCJ7pwo/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_001_PtCJ7pwo)) diff --git a/src/proto_002_PsYLVpVv/lib_protocol/dune b/src/proto_002_PsYLVpVv/lib_protocol/dune index c072e82f12a6..f1164c19cce1 100644 --- a/src/proto_002_PsYLVpVv/lib_protocol/dune +++ b/src/proto_002_PsYLVpVv/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_002_PsYLVpVv)) diff --git a/src/proto_003_PsddFKi3/lib_protocol/dune b/src/proto_003_PsddFKi3/lib_protocol/dune index 4edd4aafaa3f..885356080ac1 100644 --- a/src/proto_003_PsddFKi3/lib_protocol/dune +++ b/src/proto_003_PsddFKi3/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_003_PsddFKi3)) diff --git a/src/proto_004_Pt24m4xi/lib_protocol/dune b/src/proto_004_Pt24m4xi/lib_protocol/dune index 883e1e685e3e..21d82dc4cdb1 100644 --- a/src/proto_004_Pt24m4xi/lib_protocol/dune +++ b/src/proto_004_Pt24m4xi/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_004_Pt24m4xi)) diff --git a/src/proto_005_PsBABY5H/lib_protocol/dune b/src/proto_005_PsBABY5H/lib_protocol/dune index 9c46e754921a..062ef4c49292 100644 --- a/src/proto_005_PsBABY5H/lib_protocol/dune +++ b/src/proto_005_PsBABY5H/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_005_PsBABY5H)) diff --git a/src/proto_005_PsBabyM1/lib_protocol/dune b/src/proto_005_PsBabyM1/lib_protocol/dune index 2493d8e80d67..45953b184b2a 100644 --- a/src/proto_005_PsBabyM1/lib_protocol/dune +++ b/src/proto_005_PsBabyM1/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_005_PsBabyM1)) diff --git a/src/proto_006_PsCARTHA/lib_protocol/dune b/src/proto_006_PsCARTHA/lib_protocol/dune index 3f27d4d77600..4af6bce27f7c 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/dune +++ b/src/proto_006_PsCARTHA/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_006_PsCARTHA)) diff --git a/src/proto_007_PsDELPH1/lib_protocol/dune b/src/proto_007_PsDELPH1/lib_protocol/dune index c559700ff5d7..b0eaacd98bd6 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/dune +++ b/src/proto_007_PsDELPH1/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_007_PsDELPH1)) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/dune b/src/proto_008_PtEdo2Zk/lib_protocol/dune index 25260a07d9b2..8f1709bc231b 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/dune +++ b/src/proto_008_PtEdo2Zk/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_008_PtEdo2Zk)) diff --git a/src/proto_008_PtEdoTez/lib_protocol/dune b/src/proto_008_PtEdoTez/lib_protocol/dune index 92a18337c346..9804129dd33c 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/dune +++ b/src/proto_008_PtEdoTez/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_008_PtEdoTez)) diff --git a/src/proto_009_PsFLoren/lib_protocol/dune b/src/proto_009_PsFLoren/lib_protocol/dune index 2c03bae347cd..67a9fc1d7bb0 100644 --- a/src/proto_009_PsFLoren/lib_protocol/dune +++ b/src/proto_009_PsFLoren/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_009_PsFLoren)) diff --git a/src/proto_010_PtGRANAD/lib_protocol/dune b/src/proto_010_PtGRANAD/lib_protocol/dune index 8b7ff3b9d67a..32a7b086464a 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/dune +++ b/src/proto_010_PtGRANAD/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_010_PtGRANAD)) diff --git a/src/proto_011_PtHangz2/lib_protocol/dune b/src/proto_011_PtHangz2/lib_protocol/dune index b5ebd7cfe948..c6a75c9467c6 100644 --- a/src/proto_011_PtHangz2/lib_protocol/dune +++ b/src/proto_011_PtHangz2/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_011_PtHangz2)) diff --git a/src/proto_012_Psithaca/lib_protocol/dune b/src/proto_012_Psithaca/lib_protocol/dune index 3ceb2d2512b4..59a01e23681c 100644 --- a/src/proto_012_Psithaca/lib_protocol/dune +++ b/src/proto_012_Psithaca/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_012_Psithaca)) diff --git a/src/proto_013_PtJakart/lib_protocol/dune b/src/proto_013_PtJakart/lib_protocol/dune index e72642a28942..905446c9fe94 100644 --- a/src/proto_013_PtJakart/lib_protocol/dune +++ b/src/proto_013_PtJakart/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_013_PtJakart)) diff --git a/src/proto_014_PtKathma/lib_protocol/dune b/src/proto_014_PtKathma/lib_protocol/dune index f238243f19e4..95cfb510fdd4 100644 --- a/src/proto_014_PtKathma/lib_protocol/dune +++ b/src/proto_014_PtKathma/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_014_PtKathma)) diff --git a/src/proto_015_PtLimaPt/lib_protocol/dune b/src/proto_015_PtLimaPt/lib_protocol/dune index 862a10df6a9c..06c9556f7deb 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/dune +++ b/src/proto_015_PtLimaPt/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_015_PtLimaPt)) diff --git a/src/proto_016_PtMumbai/lib_protocol/dune b/src/proto_016_PtMumbai/lib_protocol/dune index 5c38e8edfc68..af21fa3b4bd5 100644 --- a/src/proto_016_PtMumbai/lib_protocol/dune +++ b/src/proto_016_PtMumbai/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_016_PtMumbai)) diff --git a/src/proto_017_PtNairob/lib_protocol/dune b/src/proto_017_PtNairob/lib_protocol/dune index f4b2c6c280e0..228dbfbbfac3 100644 --- a/src/proto_017_PtNairob/lib_protocol/dune +++ b/src/proto_017_PtNairob/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_017_PtNairob)) diff --git a/src/proto_018_Proxford/lib_protocol/dune b/src/proto_018_Proxford/lib_protocol/dune index 22daefede491..894dd95525d9 100644 --- a/src/proto_018_Proxford/lib_protocol/dune +++ b/src/proto_018_Proxford/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_018_Proxford)) diff --git a/src/proto_019_PtParisB/lib_protocol/dune b/src/proto_019_PtParisB/lib_protocol/dune index 97bb137338e8..5b97b57da3a9 100644 --- a/src/proto_019_PtParisB/lib_protocol/dune +++ b/src/proto_019_PtParisB/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_019_PtParisB)) diff --git a/src/proto_020_PsParisC/lib_delegate/dune b/src/proto_020_PsParisC/lib_delegate/dune index eb5e6d1aeb25..2b7610cb5e31 100644 --- a/src/proto_020_PsParisC/lib_delegate/dune +++ b/src/proto_020_PsParisC/lib_delegate/dune @@ -69,6 +69,7 @@ octez-protocol-020-PsParisC-libs.baking octez-libs.rpc uri) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (flags (:standard) diff --git a/src/proto_020_PsParisC/lib_protocol/dune b/src/proto_020_PsParisC/lib_protocol/dune index 609abf83b24c..f470e02ec3f6 100644 --- a/src/proto_020_PsParisC/lib_protocol/dune +++ b/src/proto_020_PsParisC/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_020_PsParisC)) diff --git a/src/proto_alpha/lib_delegate/dune b/src/proto_alpha/lib_delegate/dune index 2d68bcb9f9c7..2291864b262e 100644 --- a/src/proto_alpha/lib_delegate/dune +++ b/src/proto_alpha/lib_delegate/dune @@ -67,6 +67,7 @@ octez-protocol-alpha-libs.baking octez-libs.rpc uri) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (flags (:standard) diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 24f8b2a0e103..af3d59e91217 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_alpha)) diff --git a/src/proto_beta/lib_delegate/dune b/src/proto_beta/lib_delegate/dune index 4084f678ce4d..5caed1657df0 100644 --- a/src/proto_beta/lib_delegate/dune +++ b/src/proto_beta/lib_delegate/dune @@ -67,6 +67,7 @@ octez-protocol-beta-libs.baking octez-libs.rpc uri) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (flags (:standard) diff --git a/src/proto_beta/lib_protocol/dune b/src/proto_beta/lib_protocol/dune index e54efe245145..8caa75a1a7c2 100644 --- a/src/proto_beta/lib_protocol/dune +++ b/src/proto_beta/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_beta)) diff --git a/src/proto_demo_counter/lib_protocol/dune b/src/proto_demo_counter/lib_protocol/dune index ca9ee40abc94..d2a7c73ea2d2 100644 --- a/src/proto_demo_counter/lib_protocol/dune +++ b/src/proto_demo_counter/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_demo_counter)) diff --git a/src/proto_demo_noops/lib_protocol/dune b/src/proto_demo_noops/lib_protocol/dune index 3bc85619b9e5..6c4568031a11 100644 --- a/src/proto_demo_noops/lib_protocol/dune +++ b/src/proto_demo_noops/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_demo_noops)) diff --git a/src/proto_genesis/lib_protocol/dune b/src/proto_genesis/lib_protocol/dune index e40f732124d3..461072677322 100644 --- a/src/proto_genesis/lib_protocol/dune +++ b/src/proto_genesis/lib_protocol/dune @@ -7,6 +7,7 @@ (instrumentation (backend bisect_ppx)) (libraries octez-proto-libs.protocol-environment) + (preprocess (pps octez-libs.ppx_profiler)) (library_flags (:standard -linkall)) (modules Tezos_protocol_environment_genesis)) -- GitLab From 42e71cb9ae577c32ab6b1f86f79204ed668b5df6 Mon Sep 17 00:00:00 2001 From: mattiasdrp Date: Wed, 21 Aug 2024 15:37:20 +0200 Subject: [PATCH 19/19] Lib_protocol_environment: Add ppx-profiler to environments --- src/lib_protocol_environment/dune | 1 + .../environment_V10.ml | 75 +++++++------ .../environment_V11.ml | 22 ++-- .../environment_V12.ml | 22 ++-- .../environment_V13.ml | 22 ++-- .../environment_V9.ml | 31 +++--- .../lib_delegate/baking_actions.ml | 100 +++++++++--------- .../lib_delegate/baking_nonces.ml | 2 +- .../lib_delegate/baking_scheduling.ml | 2 +- .../lib_delegate/baking_state.ml | 4 +- .../lib_delegate/client_daemon.ml | 2 +- .../lib_delegate/node_rpc.ml | 4 +- .../lib_delegate/operation_selection.ml | 2 +- src/proto_beta/lib_delegate/baking_actions.ml | 90 ++++++++-------- src/proto_beta/lib_delegate/baking_nonces.ml | 2 +- .../lib_delegate/baking_scheduling.ml | 2 +- src/proto_beta/lib_delegate/baking_state.ml | 4 +- src/proto_beta/lib_delegate/client_daemon.ml | 2 +- src/proto_beta/lib_delegate/node_rpc.ml | 4 +- .../lib_delegate/operation_selection.ml | 2 +- 20 files changed, 209 insertions(+), 186 deletions(-) diff --git a/src/lib_protocol_environment/dune b/src/lib_protocol_environment/dune index d6e316010939..84dbd1471bc1 100644 --- a/src/lib_protocol_environment/dune +++ b/src/lib_protocol_environment/dune @@ -22,6 +22,7 @@ octez-libs.tezos-context-brassaia.memory octez-l2-libs.scoru-wasm octez-libs.event-logging) + (preprocess (pps octez-libs.ppx_profiler)) (flags (:standard) -open Plonk diff --git a/src/lib_protocol_environment/environment_V10.ml b/src/lib_protocol_environment/environment_V10.ml index 970959a1ff3d..8d74d510715f 100644 --- a/src/lib_protocol_environment/environment_V10.ml +++ b/src/lib_protocol_environment/environment_V10.ml @@ -325,15 +325,19 @@ struct include Tezos_crypto.Signature.V1 let check ?watermark pk s bytes = - Profiler.span_f - [ - (match (pk : public_key) with - | Ed25519 _ -> "check_signature_ed25519" - | Secp256k1 _ -> "check_signature_secp256k1" - | P256 _ -> "check_signature_p256" - | Bls _ -> "check_signature_bls"); - ] - (fun () -> check ?watermark pk s bytes) + (check + ?watermark + pk + s + bytes + [@profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ]]) end module Timelock = Tezos_crypto.Timelock @@ -1250,37 +1254,40 @@ struct in let*? f = wrap_tzresult r in return (fun x -> - Environment_profiler.record_s - (Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)) - @@ fun () -> - let*! r = f x in - Lwt.return (wrap_tzresult r)) + (let*! r = f x in + Lwt.return (wrap_tzresult r)) + [@profiler.record_s + Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)]) (** Ensure that the cache is correctly loaded in memory before running any operations. *) let load_predecessor_cache predecessor_context chain_id mode (predecessor_header : Block_header.shell_header) cache = - Environment_profiler.record_s "load_predecessor_cache" @@ fun () -> let open Lwt_result_syntax in - let predecessor_hash, timestamp = - match mode with - | Application block_header | Partial_validation block_header -> - (block_header.shell.predecessor, block_header.shell.timestamp) - | Construction {predecessor_hash; timestamp; _} - | Partial_construction {predecessor_hash; timestamp} -> - (predecessor_hash, timestamp) - in - let* value_of_key = - value_of_key - ~chain_id - ~predecessor_context - ~predecessor_timestamp:predecessor_header.timestamp - ~predecessor_level:predecessor_header.level - ~predecessor_fitness:predecessor_header.fitness - ~predecessor:predecessor_hash - ~timestamp - in - Context.load_cache predecessor_hash predecessor_context cache value_of_key + (let predecessor_hash, timestamp = + match mode with + | Application block_header | Partial_validation block_header -> + (block_header.shell.predecessor, block_header.shell.timestamp) + | Construction {predecessor_hash; timestamp; _} + | Partial_construction {predecessor_hash; timestamp} -> + (predecessor_hash, timestamp) + in + let* value_of_key = + value_of_key + ~chain_id + ~predecessor_context + ~predecessor_timestamp:predecessor_header.timestamp + ~predecessor_level:predecessor_header.level + ~predecessor_fitness:predecessor_header.fitness + ~predecessor:predecessor_hash + ~timestamp + in + Context.load_cache + predecessor_hash + predecessor_context + cache + value_of_key) + [@profiler.record_s "load_predecessor_cache"] let begin_validation ctxt chain_id mode ~predecessor ~cache = let open Lwt_result_syntax in diff --git a/src/lib_protocol_environment/environment_V11.ml b/src/lib_protocol_environment/environment_V11.ml index ddc4336cfb15..0269e020e6e3 100644 --- a/src/lib_protocol_environment/environment_V11.ml +++ b/src/lib_protocol_environment/environment_V11.ml @@ -336,15 +336,19 @@ struct include Tezos_crypto.Signature.V1 let check ?watermark pk s bytes = - Profiler.span_f - [ - (match (pk : public_key) with - | Ed25519 _ -> "check_signature_ed25519" - | Secp256k1 _ -> "check_signature_secp256k1" - | P256 _ -> "check_signature_p256" - | Bls _ -> "check_signature_bls"); - ] - (fun () -> check ?watermark pk s bytes) + (check + ?watermark + pk + s + bytes + [@profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ]]) end module Timelock = Tezos_crypto.Timelock diff --git a/src/lib_protocol_environment/environment_V12.ml b/src/lib_protocol_environment/environment_V12.ml index db8a2c605315..ee21c21dea91 100644 --- a/src/lib_protocol_environment/environment_V12.ml +++ b/src/lib_protocol_environment/environment_V12.ml @@ -336,15 +336,19 @@ struct include Tezos_crypto.Signature.V1 let check ?watermark pk s bytes = - Profiler.span_f - [ - (match (pk : public_key) with - | Ed25519 _ -> "check_signature_ed25519" - | Secp256k1 _ -> "check_signature_secp256k1" - | P256 _ -> "check_signature_p256" - | Bls _ -> "check_signature_bls"); - ] - (fun () -> check ?watermark pk s bytes) + (check + ?watermark + pk + s + bytes + [@profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ]]) end module Timelock = Tezos_crypto.Timelock diff --git a/src/lib_protocol_environment/environment_V13.ml b/src/lib_protocol_environment/environment_V13.ml index ef7598fa9025..5457bad9af9e 100644 --- a/src/lib_protocol_environment/environment_V13.ml +++ b/src/lib_protocol_environment/environment_V13.ml @@ -336,15 +336,19 @@ struct include Tezos_crypto.Signature.V1 let check ?watermark pk s bytes = - Profiler.span_f - [ - (match (pk : public_key) with - | Ed25519 _ -> "check_signature_ed25519" - | Secp256k1 _ -> "check_signature_secp256k1" - | P256 _ -> "check_signature_p256" - | Bls _ -> "check_signature_bls"); - ] - (fun () -> check ?watermark pk s bytes) + (check + ?watermark + pk + s + bytes + [@profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ]]) end module Timelock = Tezos_crypto.Timelock diff --git a/src/lib_protocol_environment/environment_V9.ml b/src/lib_protocol_environment/environment_V9.ml index 5681b7be1021..1bde7d251953 100644 --- a/src/lib_protocol_environment/environment_V9.ml +++ b/src/lib_protocol_environment/environment_V9.ml @@ -313,15 +313,19 @@ struct include Tezos_crypto.Signature.V1 let check ?watermark pk s bytes = - Profiler.span_f - [ - (match (pk : public_key) with - | Ed25519 _ -> "check_signature_ed25519" - | Secp256k1 _ -> "check_signature_secp256k1" - | P256 _ -> "check_signature_p256" - | Bls _ -> "check_signature_bls"); - ] - (fun () -> check ?watermark pk s bytes) + (check + ?watermark + pk + s + bytes + [@profiler.span_f + [ + (match (pk : public_key) with + | Ed25519 _ -> "check_signature_ed25519" + | Secp256k1 _ -> "check_signature_secp256k1" + | P256 _ -> "check_signature_p256" + | Bls _ -> "check_signature_bls"); + ]]) end module Timelock = Tezos_crypto.Timelock_legacy @@ -1222,11 +1226,10 @@ struct in let*? f = wrap_tzresult r in return (fun x -> - Environment_profiler.record_s - (Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)) - @@ fun () -> - let*! r = f x in - Lwt.return (wrap_tzresult r)) + (let*! r = f x in + Lwt.return (wrap_tzresult r)) + [@profiler.record_s + Format.asprintf "load_key(%s)" (Context.Cache.identifier_of_key x)]) (** Ensure that the cache is correctly loaded in memory before running any operations. *) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml index 5987ae1c4b50..844ff7a1aa94 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml @@ -199,10 +199,10 @@ let sign_block_header global_state proposer unsigned_block_header = let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in - let () = (() [@profiler.record "waiting for lockfile"]) in + () [@profiler.record "waiting for lockfile"] ; let* result = cctxt#with_lock (fun () -> - let () = (() [@profiler.stop ()]) in + () [@profiler.stop ()] ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in @@ -564,54 +564,54 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = - let () = (() [@profiler.record "wait for lock"]) in - (cctxt#with_lock (fun () -> - let () = (() [@profiler.stop ()]) in - let* highwatermarks = - (Baking_highwatermarks.load - cctxt - block_location [@profiler.record_s "load highwatermarks"]) - in - let authorized_votes, unauthorized_votes = - List.partition - (fun consensus_vote -> - is_authorized global_state highwatermarks consensus_vote) - unsigned_consensus_votes - in - (* Record all consensus votes new highwatermarks as one batch *) - let delegates = - List.map - (fun {delegate = ck, _; _} -> ck.public_key_hash) - authorized_votes - in - let record_all_consensus_vote = - match batch_kind with - | Preattestation -> Baking_highwatermarks.record_all_preattestations - | Attestation -> Baking_highwatermarks.record_all_attestations - in - (* We exit the client's lock as soon as this function returns *) - let* () = - (record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - [@profiler.record_s - Format.sprintf - "record consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")]) - in - return (authorized_votes, unauthorized_votes)) - [@profiler.record_s - Format.sprintf - "filter consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")]) + () [@profiler.record "wait for lock"] ; + cctxt#with_lock (fun () -> + () [@profiler.stop ()] ; + let* highwatermarks = + (Baking_highwatermarks.load + cctxt + block_location [@profiler.record_s "load highwatermarks"]) + in + let authorized_votes, unauthorized_votes = + List.partition + (fun consensus_vote -> + is_authorized global_state highwatermarks consensus_vote) + unsigned_consensus_votes + in + (* Record all consensus votes new highwatermarks as one batch *) + let delegates = + List.map + (fun {delegate = ck, _; _} -> ck.public_key_hash) + authorized_votes + in + let record_all_consensus_vote = + match batch_kind with + | Preattestation -> Baking_highwatermarks.record_all_preattestations + | Attestation -> Baking_highwatermarks.record_all_attestations + in + (* We exit the client's lock as soon as this function returns *) + let* () = + (record_all_consensus_vote + highwatermarks + cctxt + block_location + ~delegates + ~level + ~round + [@profiler.record_s + Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")]) + in + return (authorized_votes, unauthorized_votes)) + [@profiler.record_s + Format.sprintf + "filter consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")] in let*! () = List.iter_s diff --git a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml index 351e5be1743a..dfa5000ebed4 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml @@ -482,7 +482,7 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) - let () = (() [@profiler.record "waiting lock"]) in + () [@profiler.record "waiting lock"] ; cctxt#with_lock @@ fun () -> let*! nonces = (load cctxt ~stateful_location [@profiler.record_s "load nonce file"]) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml index 09ffc36cb452..8280ce092163 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml @@ -1067,7 +1067,7 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in - let () = (() [@profiler.stop]) in + () [@profiler.stop] ; may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.ml b/src/proto_020_PsParisC/lib_delegate/baking_state.ml index 5fa5e8fcaebe..f79700d55957 100644 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.ml +++ b/src/proto_020_PsParisC/lib_delegate/baking_state.ml @@ -804,9 +804,9 @@ let record_state (state : state) = Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) in protect @@ fun () -> - let () = (() [@profiler.record "waiting lock"]) in + () [@profiler.record "waiting lock"] ; cctxt#with_lock @@ fun () -> - let () = (() [@profiler.stop]) in + () [@profiler.stop] ; let level_data = state.level_state.current_level in let locked_round_data = state.level_state.locked_round in let attestable_payload_data = state.level_state.attestable_payload in diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml index 517a0510064f..7638ee6e9dca 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -177,7 +177,7 @@ module Baker = struct Lwt.return_unit) in let () = may_start_profiler cctxt#get_base_dir in - let () = (() [@profiler.record "initialization"]) in + () [@profiler.record "initialization"] ; let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml index 00060e00ef78..032b475a1d0d 100644 --- a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml +++ b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml @@ -305,7 +305,7 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - let () = (() [@profiler.reset_block_section block_hash]) in + () [@profiler.reset_block_section block_hash] ; (let*! map_result = proposal cctxt ?cache ~operations ~chain block_hash block_header in @@ -330,7 +330,7 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - let () = (() [@profiler.reset_block_section block_hash]) in + () [@profiler.reset_block_section block_hash] ; (let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in diff --git a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml index 63ed8239b288..0af0643fd37e 100644 --- a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml +++ b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml @@ -221,7 +221,7 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = let* inc'_opt = validate_operation inc op in match inc'_opt with | None -> - let () = (() [@profiler.mark ["invalid operation filtered"]]) in + () [@profiler.mark ["invalid operation filtered"]] ; return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) diff --git a/src/proto_beta/lib_delegate/baking_actions.ml b/src/proto_beta/lib_delegate/baking_actions.ml index c73c929fecda..e1f5e2c1ed3c 100644 --- a/src/proto_beta/lib_delegate/baking_actions.ml +++ b/src/proto_beta/lib_delegate/baking_actions.ml @@ -199,10 +199,10 @@ let sign_block_header global_state proposer unsigned_block_header = let level = shell.level in let*? round = Baking_state.round_of_shell_header shell in let open Baking_highwatermarks in - let () = (() [@profiler.record "waiting for lockfile"]) in + () [@profiler.record "waiting for lockfile"] ; let* result = cctxt#with_lock (fun () -> - let () = (() [@profiler.stop ()]) in + () [@profiler.stop ()] ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in @@ -564,54 +564,54 @@ let authorized_consensus_votes global_state (* Filter all operations that don't satisfy the highwatermark and record the ones that do. *) let* authorized_votes, unauthorized_votes = - let () = (() [@profiler.record "wait for lock"]) in - (cctxt#with_lock (fun () -> - let () = (() [@profiler.stop]) in - let* highwatermarks = - (Baking_highwatermarks.load - cctxt - block_location [@profiler.record_s "load highwatermarks"]) - in - let authorized_votes, unauthorized_votes = - List.partition - (fun consensus_vote -> - is_authorized global_state highwatermarks consensus_vote) - unsigned_consensus_votes - in - (* Record all consensus votes new highwatermarks as one batch *) - let delegates = - List.map - (fun {delegate = ck, _; _} -> ck.public_key_hash) - authorized_votes - in - let record_all_consensus_vote = - match batch_kind with - | Preattestation -> Baking_highwatermarks.record_all_preattestations - | Attestation -> Baking_highwatermarks.record_all_attestations - in - (* We exit the client's lock as soon as this function returns *) - let* () = - (record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - [@profiler.record_s - Format.sprintf - "record consensus votes: %s" - (match batch_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation")]) - in - return (authorized_votes, unauthorized_votes)) + () [@profiler.record "wait for lock"] ; + cctxt#with_lock (fun () -> + () [@profiler.stop] ; + let* highwatermarks = + (Baking_highwatermarks.load + cctxt + block_location [@profiler.record_s "load highwatermarks"]) + in + let authorized_votes, unauthorized_votes = + List.partition + (fun consensus_vote -> + is_authorized global_state highwatermarks consensus_vote) + unsigned_consensus_votes + in + (* Record all consensus votes new highwatermarks as one batch *) + let delegates = + List.map + (fun {delegate = ck, _; _} -> ck.public_key_hash) + authorized_votes + in + let record_all_consensus_vote = + match batch_kind with + | Preattestation -> Baking_highwatermarks.record_all_preattestations + | Attestation -> Baking_highwatermarks.record_all_attestations + in + (* We exit the client's lock as soon as this function returns *) + let* () = + (record_all_consensus_vote + highwatermarks + cctxt + block_location + ~delegates + ~level + ~round + [@profiler.record_s + Format.sprintf + "record consensus votes: %s" + (match batch_kind with + | Preattestation -> "preattestation" + | Attestation -> "attestation")]) + in + return (authorized_votes, unauthorized_votes)) [@profiler.record_s Format.sprintf "filter consensus votes: %s" (match batch_kind with | Preattestation -> "preattestation" - | Attestation -> "attestation")]) + | Attestation -> "attestation")] in let*! () = List.iter_s diff --git a/src/proto_beta/lib_delegate/baking_nonces.ml b/src/proto_beta/lib_delegate/baking_nonces.ml index d605900bb5bc..d80bbeb02324 100644 --- a/src/proto_beta/lib_delegate/baking_nonces.ml +++ b/src/proto_beta/lib_delegate/baking_nonces.ml @@ -482,7 +482,7 @@ let reveal_potential_nonces state new_proposal = let block = `Head 0 in let branch = new_predecessor_hash in (* improve concurrency *) - let () = (() [@profiler.record "waiting lock"]) in + () [@profiler.record "waiting lock"] ; cctxt#with_lock @@ fun () -> let*! nonces = (load cctxt ~stateful_location [@profiler.record_s "load nonce file"]) diff --git a/src/proto_beta/lib_delegate/baking_scheduling.ml b/src/proto_beta/lib_delegate/baking_scheduling.ml index 09ffc36cb452..8280ce092163 100644 --- a/src/proto_beta/lib_delegate/baking_scheduling.ml +++ b/src/proto_beta/lib_delegate/baking_scheduling.ml @@ -1067,7 +1067,7 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in - let () = (() [@profiler.stop]) in + () [@profiler.stop] ; may_reset_profiler (New_valid_proposal current_proposal) ; protect ~on_error:(fun err -> diff --git a/src/proto_beta/lib_delegate/baking_state.ml b/src/proto_beta/lib_delegate/baking_state.ml index 5fa5e8fcaebe..f79700d55957 100644 --- a/src/proto_beta/lib_delegate/baking_state.ml +++ b/src/proto_beta/lib_delegate/baking_state.ml @@ -804,9 +804,9 @@ let record_state (state : state) = Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) in protect @@ fun () -> - let () = (() [@profiler.record "waiting lock"]) in + () [@profiler.record "waiting lock"] ; cctxt#with_lock @@ fun () -> - let () = (() [@profiler.stop]) in + () [@profiler.stop] ; let level_data = state.level_state.current_level in let locked_round_data = state.level_state.locked_round in let attestable_payload_data = state.level_state.attestable_payload in diff --git a/src/proto_beta/lib_delegate/client_daemon.ml b/src/proto_beta/lib_delegate/client_daemon.ml index 517a0510064f..7638ee6e9dca 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -177,7 +177,7 @@ module Baker = struct Lwt.return_unit) in let () = may_start_profiler cctxt#get_base_dir in - let () = (() [@profiler.record "initialization"]) in + () [@profiler.record "initialization"] ; let consumer = Protocol_logging.make_log_message_consumer () in Lifted_protocol.set_log_message_consumer consumer ; Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates diff --git a/src/proto_beta/lib_delegate/node_rpc.ml b/src/proto_beta/lib_delegate/node_rpc.ml index 357b02b8ff17..99ee3d89b010 100644 --- a/src/proto_beta/lib_delegate/node_rpc.ml +++ b/src/proto_beta/lib_delegate/node_rpc.ml @@ -306,7 +306,7 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - let () = (() [@profiler.reset_block_section block_hash]) in + () [@profiler.reset_block_section block_hash] ; (let*! map_result = proposal cctxt ?cache ~operations ~chain block_hash block_header in @@ -331,7 +331,7 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - let () = (() [@profiler.reset_block_section block_hash]) in + () [@profiler.reset_block_section block_hash] ; (let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in diff --git a/src/proto_beta/lib_delegate/operation_selection.ml b/src/proto_beta/lib_delegate/operation_selection.ml index 63ed8239b288..0af0643fd37e 100644 --- a/src/proto_beta/lib_delegate/operation_selection.ml +++ b/src/proto_beta/lib_delegate/operation_selection.ml @@ -221,7 +221,7 @@ let filter_valid_operations_up_to_quota inc (ops, quota) = let* inc'_opt = validate_operation inc op in match inc'_opt with | None -> - let () = (() [@profiler.mark ["invalid operation filtered"]]) in + () [@profiler.mark ["invalid operation filtered"]] ; return (inc, curr_size, nb_ops, acc) | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) (inc, 0, 0, []) -- GitLab