diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index 5773fc0d8baef23a6976f51e51dc1d7275315d37..c120c7057f602d713935834817ceb392f568f831 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" @@ -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"; @@ -3485,6 +3487,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_; @@ -3643,6 +3646,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; @@ -3683,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"; @@ -3690,7 +3695,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 @@ -5603,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. @@ -6326,6 +6332,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_; @@ -6440,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" @@ -7593,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 53556cdc43a8c85469a6004ff06074c80b33d06e..97e4c948c4067cefbf620a4de46bb71b08aff46c 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 c82a04bcc65118c20915700e5b06d3c30c5777a9..7e17dbb1e15b50c57e878db9ba8fdbb1dad3c5fc 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 ee54a8bc51da0310b67a183de2e097c985e6a509..9f686a13398f8c0aa816fb6b228ca220353db610 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 f3fceea3c82368da0da2581bb5c8d97f3a1f651e..a9713486f246106cfa2852b23d582387e5f56d00 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 0986eb6f2059307563173ca12b82aeee83dc6c12..dbef6d83aaac958d3a765670b65dd1975de9d764 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 41621340c390a9b496682386925cb2a748393170..75439cdaa3850db8ea575633d4c259cd56065c02 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 5baa9c862ff579b6e9107deae85305cb56c5cf95..d865d4786bd23189831ee68edc49e1c91b95c5a7 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 f167a51486a27a24176a8138a0f27780c86ade9a..811dc81c71cd8cecf29415db28d0e848adaea015 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 57bee1aa95db3c0ce8b1e853809dbfd3838d1e46..b7b6f7f87837fdcbca9f7c6b94c0a816aea87888 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 0538eb04fb19e602ebffb3111d9d4a89521ce50a..81a9fac3dcadfe1a0bc273547c75d2c1c6eeb001 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 b246459e93a07d09b5ed343964ae81170e885502..1770440eae07c39939a0f632375b9920531aa9ee 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 15bb2006eb51bf8ba2418043f3b58fdc81f51bec..b5f271fa83e9a63d5209b657ddccb0c84b496131 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 85629ab27e814a9ac7a6eb1be62def35cc46043c..dea86f7a4f84207e278240791ae59fac5e178f46 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 ec85b0705f7471d3c2ae7d1487a48fb56bfe53e8..a6071ce81ee9db22abd7734b318fa3b91c24d168 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 06bd47fa76c6aee48849ade68fabab627632cb1e..e53e239a3bc52f19ef576c9cdb45a88eee124d5e 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 6504474a62d70893e23d20c7a8c613dcb833b3fc..39ef609485ca74666638636ca394860dac1f06f5 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 07d1d330d86e8593003580a796876aa7b4073306..61c7f72c595eee21f987d67ec9bfe0feba36a9f7 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 82ac8796fd2a3e78edb069c445cb2bb9b2ddafe4..08384dcb86854e939a55a6d8a38ee391ccdd8f50 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 ad44066839501015511226375160affd649eee9b..7e427242b6fef6a34cb86851dd6594e3dc12ba33 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 394a736910cf720cbe03b0851176543987e1cc6a..69679329c7fb045e3eefdecd5cc1604fe52d7447 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 6da2a37418c6579f1367083fb6fb6efea3dd6bf1..b4d24e2f9c6d58aec153a358417c3cf1c6fcf52c 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 438b468a610b552bb78348b2185c32592245222c..19377cb6ce34eb1e175476b7d69fbe42b2e25c6b 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 aae6464e427459ef17b39dbfe696317ed47e1167..8a08c7e3a29b69ae2edd28445314ecbbd08fd080 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 161e5b66bfea15afec788d2a61e4336931979ce8..85db3871338676b31813d2358d443a855ec1eb96 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 00137eb3093ebca2b3a694f8ff0ad9b4aaca83e0..7016db56f3560893fb9730d958ce03d6a511066f 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 5d41cb6e84bf2e80a2f3c82d0b91bcdc64c7481a..643c7292dcf81bb4a92a0b92567b19a5f1bb3d40 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 6d1c44d09325da1afe3141a569b658fd334d305e..6c4f8b9dba9cf2f6f11b7795bcbfafba16a19b27 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 0ff349096cd62343ad080d30a259f7c50fdfb85a..d0f546cb21cdf3fe9d95d137bbd4312ad8fc9d31 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/bin_node/dune b/src/bin_node/dune index 8633a2136aa427680d180fd616ec0ee00ca5094b..2fd739cc190b3f99a1356d878e4718d95fa4b377 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_replay_command.ml b/src/bin_node/node_replay_command.ml index 1c8b9e66c0d90626761b701d172f9ab56a6ab9a6..765344cbe1d1c08c6d908b9309b9b2a742fdf282 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 @@ -492,6 +495,44 @@ let run ?verbosity ~singleprocess ~strict ~operation_metadata_size_limit 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 + 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 059a131a55b64d63871bbf9329a443f728bef747..e7da143a91eda3e957072cf6b5f7a4de2e6e1e48 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,14 @@ 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. *) + 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) @@ -723,6 +733,43 @@ 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 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 output_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_protocol_environment/dune b/src/lib_protocol_environment/dune index d6e3160109390308c73f615afe5107dddb304d3b..84dbd1471bc13becfb8c4be4ac4d10fae8585a13 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 15378729c7e9c944d347efa0e92f6b05086c46b3..8d74d510715ffed95127dd360686a275dbf4dd86 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,26 @@ 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 = + (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 module Vdf = Class_group_vdf.Vdf_self_contained @@ -1234,33 +1254,40 @@ struct in let*? f = wrap_tzresult r in return (fun x -> - 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 = 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 7ec8dcaa2f42e5e5d17d06da52b58edd9ebf0df2..0269e020e6e3d0f78b6c6d71533d3de5093003c8 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,26 @@ 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 = + (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 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 17c5cec9035839979656eb9dab0a902f17558cef..ee21c21dea912ee3ec7cde8624f4ddb480dd0ffe 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,26 @@ 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 = + (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 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 e16c5f632521ac7151ff035ba92e653b1903e19c..5457bad9af9e1bae3c9f64bb2c01a6a5beed777c 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,26 @@ 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 = + (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 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 819d385438129ca161feb1012cce7e76fae735aa..1bde7d2519530b3aae6c55729f855ca1d6b4b56e 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,26 @@ 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 = + (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 module Vdf = Class_group_vdf.Vdf_self_contained @@ -1206,8 +1226,10 @@ struct in let*? f = wrap_tzresult r in return (fun x -> - 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/lib_protocol_environment/environment_profiler.ml b/src/lib_protocol_environment/environment_profiler.ml new file mode 100644 index 0000000000000000000000000000000000000000..24535d4d3f1086417027c095f1527ee30d9540c4 --- /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 a93820c15a606ad78c0e92788c081eea91e54288..f4a63a332eed999344a1acb131f0e995bb465409 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 70da4339c8fb8e2d172016086b505de3e00bb6ff..369dbff3632ef776e4efd0d48a8c456c0a06fd91 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 0000000000000000000000000000000000000000..95e64104973985193aca685121fdfdb2c5b658fe --- /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 8d6d7f6c0dd716afe8924c5c4733f1cf79832d73..ccda1b6c5ef167557d4421a44104efe4aa68eea7 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 5ff2e686d67ce9e2fd2e4e9b06790016ed8d0303..bb93656c8d0ae30e0284660065d406d952d66259 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 0000000000000000000000000000000000000000..95e64104973985193aca685121fdfdb2c5b658fe --- /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 c85bdccaa6ee778cc286d6ac5b050eaf0a21340e..48889f316e90daf48fb2f6689f75416216e06b59 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 1245c7488f461c00335ff51740e2b626a73f10c6..152a6e7f1e79107ac2f1bfd15eaf304ce78f2b24 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 0000000000000000000000000000000000000000..95e64104973985193aca685121fdfdb2c5b658fe --- /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 af6bf60f3d18613e264070f0ae513e220e9c9eb0..beaa071de36d2b261389e96ef146fb7cb03fafc6 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 88e577578004fcc7670f683ff28c708ef8559021..2b4b528da56774b1d84f10019a47d1a971c2c6a7 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 0000000000000000000000000000000000000000..95e64104973985193aca685121fdfdb2c5b658fe --- /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 c479da485b9021d0d9f1fb683ccd91216e4f776d..68dd5eb2594e7a4a949beb16adaa73ff30faf09c 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 badab5a6546a63dc2f38f92410881b48e3fc0988..fb1cda002785b922c3e04c87b0bae42c7ff27080 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 0000000000000000000000000000000000000000..95e64104973985193aca685121fdfdb2c5b658fe --- /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 1610e8087909877a04ffc57c94a1a9ab2987961f..10fbccafd8b5954051df6f5bc57b4d996ed58ecc 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 diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index 52c042521140b8efac3f0846649e093a499bacef..e02e3479dea332a9f2099b04d1da3d433a3012b0 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,37 +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* ans = - Client.call_streamed_service - accept - ?logger - ?headers - ~base - ~on_chunk - ~on_close - service - params - query - body + 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 - 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* ans = - Client.call_service - ?logger - ?headers - ~base - accept - service - params - query - body + 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 - 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/RPC_profiler.ml b/src/lib_rpc_http/RPC_profiler.ml new file mode 100644 index 0000000000000000000000000000000000000000..5c9b8997618b0997e96e83c8932a6394e3ebc3b2 --- /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 0000000000000000000000000000000000000000..5ab6b291678ca939c13ed8d07a4ee101f4eb1861 --- /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 e95e149f2939f2fea464f5e17df2c39519438936..ac60c0a39593d123c9495acaa87eaac2dd7fe14d 100644 --- a/src/lib_rpc_http/dune +++ b/src/lib_rpc_http/dune @@ -24,11 +24,12 @@ octez-libs.resto-cohttp-client octez-libs.rpc octez-libs.rpc-http) + (preprocess (pps octez-libs.ppx_profiler)) (flags (: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/block_validator.ml b/src/lib_shell/block_validator.ml index 583f449470d0936ee8ece61c20662a48f9500f7f..b40cfa93895aeb5cb441468ade668acb8e4924cc 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[@warning "-32"] 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,22 +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 - 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 @@ -324,11 +333,13 @@ 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 -> + 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, @@ -349,7 +360,10 @@ let on_validation_request w | Some {errors; _} -> return (Already_known_invalid errors) | None -> ( let* pred = - 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 = @@ -426,7 +440,8 @@ let on_validation_request w hash header operations - application_result)))) + application_result [@profiler.record_s "commit_block"])) + )) let on_preapplication_request w { @@ -654,6 +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] ; 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,8 +680,9 @@ let validate_and_apply w ?canceler ?peer ?(notify_new_block = fun _ -> ()) let* r = let open Lwt_result_syntax in let* () = - 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_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index 154c14c165a84abe99a086ca8c34335e8d29f4c5..d6c7eff8eebae202adc942be1c203fdb8e64427c 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_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 2493cecbccbcca2a267f14883c7f9c5124d7480c..1ddedd46116d1b982bf21c4b72b77a886a6ffe76 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,6 +337,10 @@ let instantiate_prevalidator parameters set_prevalidator block chain_db = ~block_hash:(Store.Block.hash block) new_protocol_hash 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 match r with @@ -464,55 +472,77 @@ 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 - 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 - 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 @@ -520,6 +550,9 @@ let on_notify_branch w peer_id locator = let* () = check_and_update_synchronisation_state w (head_hash, head_header) peer_id in + 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) @@ -527,6 +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 ["chain_validator"; "notify head received"]] ; let* () = check_and_update_synchronisation_state w (block_hash, header) peer_id in diff --git a/src/lib_shell/dune b/src/lib_shell/dune index df3b0bfffc7d72a4b04a191a8152205acb649f6e..d407db3b05804a6fc4035c55674edb07d30f42b0 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 ppx_expect octez-libs.ppx_profiler)) (flags (:standard) -open Tezos_base.TzPervasives diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index ec52100d7b1fa944865eb08faa99883d527b66dc..384006d29c79948e189e0efc77d13b84d488a47b 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,22 +179,28 @@ let handle_msg state msg = in match msg with | Get_current_branch chain_id -> - 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 - 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) -> - 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 @@ -217,14 +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 -> - 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 -> - 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 @@ -239,9 +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) -> - 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 @@ -274,56 +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 -> - 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 -> ( - 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 -> - 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 - 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 @@ -338,47 +366,52 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations ; Lwt.return_unit) | Get_protocols 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 + (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 -> - 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 -> - 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) -> ( - 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 @@ -393,69 +426,75 @@ let handle_msg state msg = Peer_metadata.incr meta @@ Received_response Operations_for_block ; Lwt.return_unit) | Get_checkpoint chain_id -> ( - 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 _ -> (* 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) -> ( - 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) -> (* 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) -> ( - 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) -> (* 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 @@ -474,6 +513,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 = { diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index ff88ba53d64817894fbff51013904ac29d065bc6..bcaefcd85848baf167a4c78dc12f93b682a118bd 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,64 +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*! () = Events.(emit fetching_operations_for_head) block_received in - let* operations = - 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)) + let[@warning "-26"] sym_prefix l = + "peer_validator" + :: Block_hash.to_short_b58check hash + :: "validate new head" :: l 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*! () = Events.(emit fetching_operations_for_head) block_received in + (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 = - 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 @@ -230,6 +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 + 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 @@ -267,6 +287,17 @@ 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 -> + 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 diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 8856efa9938c57e07b431429964c08c63b013c7f..eeac1ed8c9ce30504c871c99ee007a6759be5ec7 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,15 @@ 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 + 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 @@ -456,14 +462,23 @@ module Make_s match (status_and_priority.status, status_and_priority.priority) with - | Fresh, _ | Reclassified, High -> true - | Reclassified, Medium | Reclassified, Low _ -> + | Fresh, _ -> true [@profiler.mark ["Freshly validated operation"]] + | Reclassified, High -> + true [@profiler.mark ["reclassified high priority operation"]] + | Reclassified, Medium -> + false + [@profiler.mark ["reclassified medium priority operation"]] + | Reclassified, Low _ -> (* Reclassified operations with medium and low priority are not reclassified *) false + [@profiler.mark ["reclassified low priority operation"]] in Some (op.hash, is_advertisable) - | `Branch_refused _ | `Branch_delayed _ | `Refused _ | `Outdated _ -> 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) @@ -499,33 +514,41 @@ module Make_s (* Using Error as an early-return mechanism *) Lwt.return_error (acc_validation_state, advertisable_mempool, validated_mempool) - else ( - 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 + else + (* 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 - 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, @@ -547,19 +570,28 @@ module Make_s let open Lwt_syntax in if not (Mempool.is_empty advertisable_mempool) then (* We only advertise newly classified operations. *) - advertise pv_shell advertisable_mempool ; + 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 = - 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 = + (Pending_ops.hashes + pv_shell.pending [@profiler.aggregate_f "pending hashes"]) in - {Mempool.known_valid; pending = Pending_ops.hashes pv_shell.pending} + {Mempool.known_valid; pending} in - let* _res = set_mempool pv_shell our_mempool in - Lwt.pause () + let* _res = + (set_mempool pv_shell our_mempool [@profiler.aggregate_s "set mempool"]) + in + (Lwt.pause () [@profiler.aggregate_s "pause"]) let handle_unprocessed pv = let open Lwt_syntax in @@ -568,11 +600,12 @@ module Make_s else let* () = Events.(emit processing_operations) () in let* validation_state, advertisable_mempool, validated_mempool = - 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 @@ -627,16 +660,18 @@ module Make_s match peer with Some peer -> Events.Peer peer | None -> Leftover in let spawn_fetch_operation ~notify_arrival = - 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 (* 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) @@ -807,7 +842,11 @@ 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 = + (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 in @@ -828,10 +867,10 @@ module Make_s pv.shell.timestamp <- timestamp_system ; let timestamp = Time.System.to_protocol timestamp_system in let* validation_state = - 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 = @@ -851,22 +890,25 @@ module Make_s let*! new_pending_operations, nb_pending = Operation_hash.Map.fold_s (fun oph op (pending, nb_pending) -> - 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 @@ -1373,13 +1415,18 @@ 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* () = + (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.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. *) @@ -1392,24 +1439,29 @@ module Make in Lwt_mutex.with_lock pv.lock @@ fun () : (r, error trace) result Lwt.t -> - 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) -> - 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} -> Requests.on_inject pv ~force op - | Request.Arrived (oph, op) -> Requests.on_arrived pv oph op + | Request.Inject {op; force} -> + Requests.on_inject pv ~force op [@profiler.aggregate_s "on_inject"] + | Request.Arrived (oph, op) -> + Requests.on_arrived pv oph op [@profiler.aggregate_s "on_arrived"] | Request.Advertise -> - Requests.on_advertise pv.shell ; - return_unit - | Request.Ban oph -> Requests.on_ban pv oph + (Requests.on_advertise pv.shell ; + return_unit) + [@profiler.aggregate_s "on_advertise"] + | Request.Ban oph -> + Requests.on_ban pv oph [@profiler.aggregate_s "on_ban"] let on_close w = let pv = Worker.state w in @@ -1431,6 +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 () = + (() + [@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 diff --git a/src/lib_shell/profiler_directory.ml b/src/lib_shell/profiler_directory.ml new file mode 100644 index 0000000000000000000000000000000000000000..78f10d969f6d91019d5d461c5d7c4b07076bb636 --- /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 0000000000000000000000000000000000000000..da81f3885291e426b320b303f20f1d040b97e567 --- /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 0000000000000000000000000000000000000000..6ec04f435982c2e0ce00c54b0d5c4e706bb5fba2 --- /dev/null +++ b/src/lib_shell_services/shell_profiling.ml @@ -0,0 +1,65 @@ +(*****************************************************************************) +(* *) +(* 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); + ("rpc_server", rpc_server_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 diff --git a/src/lib_store/unix/block_store.ml b/src/lib_store/unix/block_store.ml index 0b78d985a06d1c63f97e82a54c811984feb864e4..6a880cec2752052d627582d7c2bd2298061f509d 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 Profiler = struct + include (val Profiler.wrap Shell_profiling.merge_profiler) + + let[@warning "-32"] 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,11 +419,11 @@ let cement_blocks ?(check_consistency = true) ~write_metadata block_store in let {cemented_store; _} = block_store in let* () = - 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 @@ -915,7 +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 = - 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 @@ -934,15 +944,18 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store [ro_store; rw_store] in let*! lpbl_predecessors = - 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 = - 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 = @@ -959,10 +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* () = - 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 @@ -977,53 +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* () = - List.iter_es - (fun store -> - 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 = - 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 - 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.( @@ -1050,27 +1081,31 @@ 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 = + (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 = - 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 = - 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) @@ -1129,21 +1164,25 @@ let move_all_floating_stores block_store ~new_ro_store = (fun () -> (* (atomically?) Promote [new_ro] to [ro] *) let* () = - 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* () = - 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 *) - 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 @@ -1217,10 +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 = - 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))) @@ -1246,23 +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 = - 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 = - 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 @@ -1403,6 +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. *) + () + [@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 -> @@ -1420,8 +1465,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let* () = Lwt.finalize (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 = @@ -1438,7 +1484,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store in let merge_start = Time.System.now () in let* () = + () [@profiler.record "waiting for lock (start)"] ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> + () [@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 +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 - 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 @@ -1469,18 +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 = - 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* () = + () [@profiler.record "waiting for lock (end)"] ; Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> @@ -1493,20 +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* () = - 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 - 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 @@ -1517,12 +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* () = - 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 @@ -1537,8 +1593,9 @@ let merge_stores ?(cycle_size_limit = default_cycle_size_limit) block_store let*! () = lock block_store.stored_data_lockfile in - 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)) @@ -1552,6 +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) ; + () [@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 2f207655371f796b5e9eafae0ca3eba048585dd2..6c9ccbcbf78dadd25442ee77ba98407a1136f817 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,29 +715,30 @@ let cement_blocks ?(check_consistency = true) (cemented_store : t) in let metadata_writer (block_bytes, total_block_length, block_level, metadata_offset) = - 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 () = - 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) @@ -755,71 +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*! _ = - 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 - 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 - 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)) - (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 - 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*! () = Lwt_unix.rename tmp_file_path final_path in + let*! () = + (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 *) - 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} @@ -841,6 +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"]] ; if nb_files <= offset then Lwt.return_unit else let cemented_files = Array.to_list cemented_blocks_files in @@ -868,6 +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"]] ; if nb_files <= offset then Lwt.return_unit else let {end_level = last_level_to_purge; _} = @@ -909,7 +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 - 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 @@ -1103,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 36f0dfa8661f1379db67a5dbbd6a1fc8af8dba85..7bfca44946c5a288a250c0f4b17c3af37c44ebfa 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 105b66d5042d9c77e03ad92abea02424c429bdd2..b8179df60a391abca41a3bffc00dcf8c7fa8129b 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[@warning "-32"] 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,196 +505,199 @@ module Block = struct let store_block chain_store ~block_header ~operations validation_result = let open Lwt_result_syntax in - 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 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 - | 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 @@ -1265,43 +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. *) - 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) @@ -1319,33 +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. *) - 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. *) 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 @@ -1374,30 +1391,35 @@ module Chain = struct let pred_cache = WithExceptions.Option.get ~loc:__LOC__ live_data_cache.pred in - 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 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 - 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 @@ -1795,268 +1817,270 @@ module Chain = struct let set_head chain_store new_head = let open Lwt_result_syntax in - 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 + (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* () = - 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* () = - 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* () = - Stored_data.write chain_state.current_head_data new_head_descr - in - 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 = - 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 diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 6e7880c6094c5a5a6ebfcb34912cf8191179fd88..3dc02ef8f7ed486b578982218a6295dc4d5b3ae4 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 @@ -614,30 +618,48 @@ module Make (Proto : Protocol_plugin.T) = struct 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 = - (List.fold_left_es - (fun (state, acc) ops -> - 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 - in - return (state, op_metadata :: acc)) - (state, []) - ops + (List.fold_left_i_es + (fun i (state, acc) 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 = (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)) @@ -725,15 +747,17 @@ module Make (Proto : Protocol_plugin.T) = struct let* operations = (parse_operations block_hash - operations [@time.duration_lwt operations_parsing]) + operations + [@time.duration_lwt operations_parsing] + [@profiler.record_s "parse_operations"]) in let* context = - 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 @@ -745,120 +769,122 @@ module Make (Proto : Protocol_plugin.T) = struct block_hash operations in - 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 - 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 - 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] - 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) @@ -1286,28 +1312,46 @@ 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 = + (parse_operations + block_hash + operations [@profiler.record_s "parse_operations"]) + in let* state = - 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 = - List.fold_left_es - (fun state ops -> - List.fold_left_es - (fun state (oph, op, check_signature) -> - 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* () = + (Proto.finalize_validation + state [@profiler.record_s "finalize_validation"]) in - let* () = Proto.finalize_validation state in return_unit let validate chain_id ~(predecessor_block_header : Block_header.t) diff --git a/src/lib_validation/dune b/src/lib_validation/dune index af4aa84baa3d131e1e595e127f0748084ea6055a..cb7bad9464534f878d805021397c6d099a4e3995 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 cc0d18f68c08780405e3363d4414e28654c46592..99c145bc3a08affb4a056dd2b09d1a0a8edbcfac 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,6 +151,7 @@ module Processing = struct should_validate; simulate; } -> + () [@profiler.record "apply_block"] ; let*! block_application_result = let* predecessor_context = Error_monad.catch_es (fun () -> @@ -207,6 +210,7 @@ module Processing = struct cache; } ) in + Tezos_protocol_environment.Environment_profiler.stop () ; continue block_application_result cache None | Preapply { @@ -283,6 +287,7 @@ module Processing = struct operations; _; } -> + () [@profiler.record "validate_block"] ; let*! block_validate_result = let* predecessor_context = Error_monad.catch_es (fun () -> @@ -300,7 +305,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 +322,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} -> diff --git a/src/proto_000_Ps9mPmXa/lib_protocol/dune b/src/proto_000_Ps9mPmXa/lib_protocol/dune index 2585a70d44da77cba130ebae3cb7ab00712d2710..bf11800decca7362dfe90f2001e5fe8b19395185 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 15a05cc1b5e1eedddd5ab479a1157f1e70182f85..b95e04570a428a5f145258182c3eb313cc07a2fb 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 c072e82f12a6892be7ce41306ef19a259c939996..f1164c19cce13dbac7478a262430769114a6a804 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 4edd4aafaa3f3d6f4e812571ce8a59046e78be2b..885356080ac1de8e9a31035d98bb7095d1d44917 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 883e1e685e3e39e4c8d82786e526ce050742ac9a..21d82dc4cdb16df6aeb8020ecea953f651946219 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 9c46e754921aad0f02d046ea44247fd53aa17b29..062ef4c49292118411e73660ee2246f4e4a1f35d 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 2493d8e80d6737157c672d7a68a7d992ebc9065a..45953b184b2a248206299f62edffc342b6c868a8 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 3f27d4d7760060773a48dfa2f0cf6f41c2313631..4af6bce27f7c577e0694539d833b0800c5036462 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 c559700ff5d746dfad4b9ba6f9332100a5132d99..b0eaacd98bd6f50d1feb328ce5dec9f0a9ede7eb 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 25260a07d9b2bc9ba2c908986089fa438db4881b..8f1709bc231bce93ed3298b2b0592db77b19f67b 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 92a18337c3465ce9b3bbe334d8d9c3e6e35b5ebd..9804129dd33c98ec797d32485550480ad1a9d6f3 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 2c03bae347cd3e0ebf01df92944d4fecf1fd09d2..67a9fc1d7bb0c3e93929f8a06b4eaccd69359c57 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 8b7ff3b9d67a3f7f4337671bd8340168ca37ce2d..32a7b086464a4bbcc4ab32eb320aca7bbd5b3bb1 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 b5ebd7cfe948e601078ed4f82c53ee6142c9c623..c6a75c9467c69784cd274eeee83cdd3c833e73a3 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 3ceb2d2512b4ab555430e51729d4f9e44e690d14..59a01e23681c9d370e3b3774367cac598af878b5 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 e72642a289428b7a48c1b245c1982701b58142c0..905446c9fe940faf224dd42427f5723a2de161a9 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 f238243f19e4c24924e0aa8d08c0305a5de621a5..95cfb510fdd4a1b5fa96daf769d248ee35860b49 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 862a10df6a9c388589e6e39422ed71039eda0c7e..06c9556f7debd405faa4b65efbe8fab27256f976 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 5c38e8edfc680a9ca62f08d76aab4ab60e2219af..af21fa3b4bd5b8897ba85b9fc89aa17671d3a180 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 f4b2c6c280e0c78503bc17665b5b148c633fa41a..228dbfbbfac3fb34a263b975e82d55361c328f29 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 22daefede491e75a4fd14f9a5ad6ea6dfb49b6c4..894dd95525d90681408fe5a23089ac1aea66d58c 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 97bb137338e8dfebc5fda17ecad91dfe38cfd70f..5b97b57da3a9a9b69f4d4eb6d32d9bc642016521 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/baking_actions.ml b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml index 3157d35a39d17195574ecb0e3098491a37bb8af2..844ff7a1aa94c7f4f013a1406b7f1cb622f5ead1 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,78 +45,82 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( - 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 = @@ -187,35 +192,37 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = - 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 + () [@profiler.record "waiting for lockfile"] ; let* result = cctxt#with_lock (fun () -> + () [@profiler.stop ()] ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = - 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* () = - 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 -> @@ -226,11 +233,11 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = - 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}} @@ -257,12 +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 = - 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 @@ -293,16 +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 = - 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 = - 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 @@ -334,14 +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 = - 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 = - 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 @@ -364,7 +376,10 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = - 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 @@ -373,14 +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_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} @@ -548,8 +564,14 @@ 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 = + () [@profiler.record "wait for lock"] ; cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in + () [@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 -> @@ -569,15 +591,27 @@ let authorized_consensus_votes global_state 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 + (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 @@ -649,10 +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 = - forge_and_sign_consensus_vote - global_state - ~branch:batch_branch - unsigned_consensus_vote + (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")]) in match signed_consensus_vote_r with | Error err -> @@ -702,10 +742,16 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = - Node_rpc.inject_operation - cctxt - ~chain:(`Hash chain_id) - signed_consensus_vote.signed_operation + (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")]) in let*! () = Events.( @@ -752,12 +798,12 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = - 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.( @@ -857,12 +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 - 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 @@ -885,14 +932,14 @@ let update_to_level state level_update = cctxt delegates ~level:new_level - ~chain + ~chain [@profiler.record_s "compute predecessor delegate slots"] in let* next_level_delegate_slots = - 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 @@ -989,7 +1036,11 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> - 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 *) @@ -1000,14 +1051,18 @@ let rec perform_action state (action : action) = event *) perform_action state Watch_quorum | Update_to_level level_update -> - 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 -> - 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 -> - 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 -> - 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 7d38c52f8db91ab70ccf0e04b246115398c73bb6..dfa5000ebed44addb88fcdef5f51ce9cbe4cb08c 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; @@ -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 *) + () [@profiler.record "waiting lock"] ; 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 -> @@ -570,6 +579,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 +591,20 @@ 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* _ = + (reveal_potential_nonces + state + new_proposal [@profiler.record_s "reveal potential nonces"]) + 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 0000000000000000000000000000000000000000..f3cf98af724466a6e4d88b290487cb07958cf260 --- /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 208fb1426d0698a8ee2959dd7287b2c728e3e9d9..8280ce09216395e3476f746bae0513846ef6af18 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; @@ -577,8 +578,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 = + (compute_next_round_time + state [@profiler.record_f "compute next round time"]) + in + let*! next_baking = + (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 -> let*! () = Events.(emit waiting_for_new_head ()) in @@ -816,6 +823,31 @@ 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 _ -> (() [@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 -> + 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 -> + let () = + (() + [@profiler.stop] + [@profiler.record Block_hash.to_b58check curr_head_hash]) + in + 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 +857,23 @@ 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 = + (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'' = Baking_actions.perform_action state' action in + let* state'' = + (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'' in @@ -841,7 +886,9 @@ 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 = + (compute_next_timeout state'' [@profiler.record_s "compute next timeout"]) + in let* event_opt = wait_next_event ~timeout: @@ -1020,6 +1067,8 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in + () [@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 4184b4033f0d023832c7c85e2e2c131d333e8aa5..2dc89ac93b5329e354474e96e7c9f012d03dcee6 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,66 +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 - 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 @@ -133,21 +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 = - 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 = - 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 fb1384c1c7271cce32c873ac4c5558f09e037d0c..f79700d559572dee839bf9e46b2282b398081c57 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,34 +796,39 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in - 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 () -> - cctxt#with_lock @@ fun () -> - 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} - 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)) - 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 () -> + () [@profiler.record "waiting lock"] ; + cctxt#with_lock @@ fun () -> + () [@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 = + (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 @@ -1390,3 +1396,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 689b85c0b009b02abd996ed9e02e3b3a9a23aadc..5ecb460fd8e4ed86ad5b5e42ee3c251aa9ddf1eb 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 7338ce67d0dbafd11b6330210b319ac877f650d5..f3219af9b1f0f777dc61193400d22e357ca68bc4 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,25 +250,26 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = - 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 = - 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) @@ -300,36 +302,39 @@ 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_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 = - 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 = - 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. *) let incremental = {incremental with header = {incremental.header with operations_hash}} in - let* validation_result = Baking_simulator.finalize_construction incremental in + let* validation_result = + (Baking_simulator.finalize_construction + incremental [@profiler.record_s "finalize construction"]) + in let validation_result = Option.map fst validation_result in let* changed = check_protocol_changed @@ -362,14 +367,15 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = - 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) @@ -391,9 +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 = - 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 @@ -409,16 +415,16 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -429,14 +435,14 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -446,21 +452,22 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -471,36 +478,37 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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_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 a51235b8547b16baa1e9a44b79e72484cef579a2..7638ee6e9dcad39a5319db1b555a071b8a9f0e56 100644 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml @@ -56,7 +56,49 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + 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.((output_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker ; + RPC_profiler.init profiler_maker + | _ -> () + 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 @@ -134,6 +176,8 @@ module Baker = struct let*! _ = Lwt_canceler.cancel canceler in Lwt.return_unit) in + let () = may_start_profiler cctxt#get_base_dir 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/dune b/src/proto_020_PsParisC/lib_delegate/dune index 955aba951667d9edea4d8ca433c428e30a07bfe0..2b7610cb5e310f28517dc6056c82c41779ec2d93 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) @@ -67,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_delegate/node_rpc.ml b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml index 8538f928049fad188619d723ba15107be9d1ba53..032b475a1d0da443f69bcea723466e09b34b289b 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[@warning "-32"] 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,9 +106,10 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = - 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) @@ -121,43 +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 - 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 - 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 = - 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.map (List.map parse_op) 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) = @@ -170,15 +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 -> + 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 -> + 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; } = - 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) @@ -191,9 +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 = - 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 @@ -212,8 +259,25 @@ 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 -> + let () = + (() + [@profiler.mark + [ + "new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"; + ]]) + in + return pi | None -> + let () = + (() + [@profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ]]) + in let* pi = compute_block_info cctxt @@ -229,8 +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 = - 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 @@ -240,14 +305,18 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - 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.reset_block_section block_hash] ; + (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 @@ -261,12 +330,16 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - 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.reset_block_section block_hash] ; + (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 d83f7c55369a129dc5f18718b7d795bfabfc7de8..0af0643fd37e2e486f5f976887dab023f25ef381 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,21 +182,22 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( - (* 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 @@ -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 -> + () [@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,45 +281,52 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = - 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 = - 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 = - 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 = - 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 = - 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 = - 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_simulator.finalize_construction inc in + let* result = + (Baking_simulator.finalize_construction + inc [@profiler.record_s "finalize construction"]) + in match result with | Some (validation_result, block_header_metadata) -> return diff --git a/src/proto_020_PsParisC/lib_protocol/dune b/src/proto_020_PsParisC/lib_protocol/dune index 609abf83b24c2f83708da51085414190a0cac4a4..f470e02ec3f6db9741446aca311bfc2e89b99e4e 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/baking_actions.ml b/src/proto_alpha/lib_delegate/baking_actions.ml index ecb2dc9a5dbe0511103cb5683835bc45e4bb6c03..74bca0325e305f583ac33f0a07168b5138d42723 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 7d38c52f8db91ab70ccf0e04b246115398c73bb6..3229a761a36dc9223b51978c398bf2199ea72d1f 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 0000000000000000000000000000000000000000..f3cf98af724466a6e4d88b290487cb07958cf260 --- /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 b9d0b5091ca755093f7e5dabd0cd4d60bd2935f9..50ca88a5b4598d6eb24ea3976c43b74a3c9bd5f9 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 a2e47c559bd2bf344a0e19a58086285f28feec6a..0c2d4b173d1955aba9e6ff90735273225dd44057 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 fb1384c1c7271cce32c873ac4c5558f09e037d0c..6b45d49d053209a3439a0ae73acea21e66ff2f91 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 689b85c0b009b02abd996ed9e02e3b3a9a23aadc..5ecb460fd8e4ed86ad5b5e42ee3c251aa9ddf1eb 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 7338ce67d0dbafd11b6330210b319ac877f650d5..49b0e5ae88c073219cb1eb0d8903b1407531c110 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 a51235b8547b16baa1e9a44b79e72484cef579a2..a05402b307bda6ee68395031d2a8505d7b9a9608 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.ml +++ b/src/proto_alpha/lib_delegate/client_daemon.ml @@ -56,6 +56,46 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + 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.((output_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker ; + RPC_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 +174,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/dune b/src/proto_alpha/lib_delegate/dune index eee391da2a432cc8205e690c58f6e1de4a9985b5..2291864b262e55d32f0fed0dbf7ae7bab64d9ee0 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) @@ -65,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_delegate/node_rpc.ml b/src/proto_alpha/lib_delegate/node_rpc.ml index 8538f928049fad188619d723ba15107be9d1ba53..c2bb081db7e00f15c1e9aba226d5e149676d2a54 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 d83f7c55369a129dc5f18718b7d795bfabfc7de8..c9ce27b90f7959730a014aa9d1ac77c7939016b9 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_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 24f8b2a0e10347a2ac712f815a49ae619691d201..af3d59e912175d7155268c3603058226f28425ff 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/baking_actions.ml b/src/proto_beta/lib_delegate/baking_actions.ml index 3157d35a39d17195574ecb0e3098491a37bb8af2..e1f5e2c1ed3c3ee7e6597c7c8ff5d02dd32c4a0a 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,78 +45,82 @@ module Operations_source = struct function | None -> Lwt.return_none | Some operations -> ( - 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 = @@ -187,35 +192,37 @@ let sign_block_header global_state proposer unsigned_block_header = unsigned_block_header in let unsigned_header = - 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 + () [@profiler.record "waiting for lockfile"] ; let* result = cctxt#with_lock (fun () -> + () [@profiler.stop ()] ; let block_location = Baking_files.resolve_location ~chain_id `Highwatermarks in let* may_sign = - 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* () = - 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 -> @@ -226,11 +233,11 @@ let sign_block_header global_state proposer unsigned_block_header = | false -> tzfail (Block_previously_baked {level; round}) | true -> let* signature = - 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}} @@ -257,12 +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 = - 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 @@ -293,16 +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 = - 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 = - 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 @@ -334,14 +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 = - 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 = - 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 @@ -364,7 +376,10 @@ let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) global_state.constants.parametric in let* signed_block_header = - 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 @@ -373,14 +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_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} @@ -548,8 +564,14 @@ 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 = + () [@profiler.record "wait for lock"] ; cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in + () [@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 -> @@ -569,15 +591,27 @@ let authorized_consensus_votes global_state 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 + (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 @@ -649,10 +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 = - forge_and_sign_consensus_vote - global_state - ~branch:batch_branch - unsigned_consensus_vote + (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")]) in match signed_consensus_vote_r with | Error err -> @@ -702,10 +742,16 @@ let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) return_unit) (fun () -> let* oph = - Node_rpc.inject_operation - cctxt - ~chain:(`Hash chain_id) - signed_consensus_vote.signed_operation + (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")]) in let*! () = Events.( @@ -752,12 +798,12 @@ let inject_block ?(force_injection = false) ?(asynchronous = true) state emit injecting_block (signed_block_header.shell.level, round, delegate)) in let* bh = - 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.( @@ -857,12 +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 - 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 @@ -885,14 +932,14 @@ let update_to_level state level_update = cctxt delegates ~level:new_level - ~chain + ~chain [@profiler.record_s "compute predecessor delegate slots"] in let* next_level_delegate_slots = - 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 @@ -989,7 +1036,11 @@ let rec perform_action state (action : action) = in return new_state | Inject_preattestation {signed_preattestation} -> - 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 *) @@ -1000,14 +1051,18 @@ let rec perform_action state (action : action) = event *) perform_action state Watch_quorum | Update_to_level level_update -> - 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 -> - 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 -> - 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 -> - 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 7d38c52f8db91ab70ccf0e04b246115398c73bb6..d80bbeb02324cd61acbad12ca9d367185569296c 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 *) + () [@profiler.record "waiting lock"] ; 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_profiler.ml b/src/proto_beta/lib_delegate/baking_profiler.ml new file mode 100644 index 0000000000000000000000000000000000000000..f3cf98af724466a6e4d88b290487cb07958cf260 --- /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 208fb1426d0698a8ee2959dd7287b2c728e3e9d9..8280ce09216395e3476f746bae0513846ef6af18 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; @@ -577,8 +578,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 = + (compute_next_round_time + state [@profiler.record_f "compute next round time"]) + in + let*! next_baking = + (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 -> let*! () = Events.(emit waiting_for_new_head ()) in @@ -816,6 +823,31 @@ 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 _ -> (() [@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 -> + 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 -> + let () = + (() + [@profiler.stop] + [@profiler.record Block_hash.to_b58check curr_head_hash]) + in + 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 +857,23 @@ 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 = + (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'' = Baking_actions.perform_action state' action in + let* state'' = + (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'' in @@ -841,7 +886,9 @@ 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 = + (compute_next_timeout state'' [@profiler.record_s "compute next timeout"]) + in let* event_opt = wait_next_event ~timeout: @@ -1020,6 +1067,8 @@ let run cctxt ?canceler ?(stop_on_event = fun _ -> false) on_error err in let*? initial_event = compute_bootstrap_event initial_state in + () [@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 a2e47c559bd2bf344a0e19a58086285f28feec6a..ffae1bc7eae110463cf0797abfa85a4a7b74fceb 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,66 +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 - 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 @@ -116,21 +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 = - 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 = - 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 fb1384c1c7271cce32c873ac4c5558f09e037d0c..f79700d559572dee839bf9e46b2282b398081c57 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,34 +796,39 @@ let state_data_encoding = let record_state (state : state) = let open Lwt_result_syntax in - 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 () -> - cctxt#with_lock @@ fun () -> - 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} - 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)) - 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 () -> + () [@profiler.record "waiting lock"] ; + cctxt#with_lock @@ fun () -> + () [@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 = + (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 @@ -1390,3 +1396,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 689b85c0b009b02abd996ed9e02e3b3a9a23aadc..5ecb460fd8e4ed86ad5b5e42ee3c251aa9ddf1eb 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 7338ce67d0dbafd11b6330210b319ac877f650d5..f3219af9b1f0f777dc61193400d22e357ca68bc4 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,25 +250,26 @@ let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block cctxt else let* shell_header = - 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 = - 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) @@ -300,36 +302,39 @@ 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_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 = - 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 = - 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. *) let incremental = {incremental with header = {incremental.header with operations_hash}} in - let* validation_result = Baking_simulator.finalize_construction incremental in + let* validation_result = + (Baking_simulator.finalize_construction + incremental [@profiler.record_s "finalize construction"]) + in let validation_result = Option.map fst validation_result in let* changed = check_protocol_changed @@ -362,14 +367,15 @@ let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades (Option.value (List.hd operations) ~default:[]) in let* shell_header = - 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) @@ -391,9 +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 = - 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 @@ -409,16 +415,16 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -429,14 +435,14 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -446,21 +452,22 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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 @@ -471,36 +478,37 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~adaptive_issuance_vote () in - 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_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 a51235b8547b16baa1e9a44b79e72484cef579a2..7638ee6e9dcad39a5319db1b555a071b8a9f0e56 100644 --- a/src/proto_beta/lib_delegate/client_daemon.ml +++ b/src/proto_beta/lib_delegate/client_daemon.ml @@ -56,7 +56,49 @@ let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = in Node_rpc.await_protocol_activation cctxt ~chain () +let may_start_profiler baking_dir = + 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.((output_dir // name) ^ "_profiling.txt", max_lod) + in + Baking_profiler.init profiler_maker ; + RPC_profiler.init profiler_maker + | _ -> () + 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 @@ -134,6 +176,8 @@ module Baker = struct let*! _ = Lwt_canceler.cancel canceler in Lwt.return_unit) in + let () = may_start_profiler cctxt#get_base_dir 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/dune b/src/proto_beta/lib_delegate/dune index 4921c9e3f5fbc0b8689cc73553843220e2f96ad9..5caed1657df0d47895c8474dc838815d783ccf22 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) @@ -65,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_delegate/node_rpc.ml b/src/proto_beta/lib_delegate/node_rpc.ml index 8538f928049fad188619d723ba15107be9d1ba53..99ee3d89b010dfbf5d58f1fa43e0460f76fb0245 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[@warning "-32"] 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,9 +107,10 @@ let info_of_header_and_ops ~in_protocol block_hash block_header operations = | None -> assert false in let preattestations, quorum, payload = - 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) @@ -121,43 +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 - 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 - 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 = - 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.map (List.map parse_op) 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) = @@ -170,15 +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 -> + 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 -> + 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; } = - 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) @@ -191,9 +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 = - 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 @@ -212,8 +260,25 @@ 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 -> + let () = + (() + [@profiler.mark + [ + "new_block(" ^ Block_hash.to_short_b58check pi.hash ^ "):cache_hit"; + ]]) + in + return pi | None -> + let () = + (() + [@profiler.mark + [ + "new_block(" + ^ Block_hash.to_short_b58check block_hash + ^ "):cache_miss"; + ]]) + in let* pi = compute_block_info cctxt @@ -229,8 +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 = - 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 @@ -240,14 +306,18 @@ let monitor_valid_proposals cctxt ~chain ?cache () = in let stream = let map (_chain_id, block_hash, block_header, operations) = - 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.reset_block_section block_hash] ; + (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 @@ -261,12 +331,16 @@ let monitor_heads cctxt ~chain ?cache () = in let stream = let map (block_hash, block_header) = - 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.reset_block_section block_hash] ; + (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 d83f7c55369a129dc5f18718b7d795bfabfc7de8..0af0643fd37e2e486f5f976887dab023f25ef381 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,21 +182,22 @@ let validate_operation inc op = (* No receipt if force_apply is not set *) return_some resulting_state | Ok (resulting_state, Some receipt) -> ( - (* 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 @@ -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 -> + () [@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,45 +281,52 @@ let filter_operations_with_simulation initial_inc fees_config fees_config in let*! inc, consensus = - 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 = - 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 = - 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 = - 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 = - 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 = - 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_simulator.finalize_construction inc in + let* result = + (Baking_simulator.finalize_construction + inc [@profiler.record_s "finalize construction"]) + in match result with | Some (validation_result, block_header_metadata) -> return diff --git a/src/proto_beta/lib_protocol/dune b/src/proto_beta/lib_protocol/dune index e54efe245145e33540617b6727bbd48242d50d0e..8caa75a1a7c2cf89020f63cc9bfb126c2c1a7043 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 ca9ee40abc94c06e1bcfc2e8f930ad7adf38ba8a..d2a7c73ea2d2ca4181adfb348dce1b19889b69d5 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 3bc85619b9e569ce72f13d035c670058f68f74f4..6c4568031a11f17f414cc248680d16638ebc0fc6 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 e40f732124d3d081fbc1d1b1d3e1d454e3c001e1..4610726773223cd1a6e2c4673443cff5b7c85ecc 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))