├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── core_profiler.opam ├── disabled_lib ├── core_profiler_disabled.ml ├── disabled.ml ├── disabled.mli ├── dune ├── intf.ml ├── profiler_units.ml ├── profiler_units.mli └── std.ml ├── dune-project ├── offline_tool ├── bin │ ├── dump_metrics.ml │ ├── dune │ ├── profiler_tool.ml │ └── profiler_tool.mli └── lib │ ├── core_profiler_offline_tool.ml │ ├── dune │ ├── event_generator.ml │ ├── event_generator.mli │ ├── filter.ml │ ├── filter.mli │ ├── id_table.ml │ ├── id_table.mli │ ├── interest.ml │ ├── interest.mli │ ├── path.ml │ ├── path.mli │ ├── reader.ml │ ├── reader.mli │ ├── reservoir_sampling.ml │ ├── reservoir_sampling.mli │ ├── std.ml │ ├── util.ml │ └── util.mli └── src ├── check_environment.ml ├── check_environment.mli ├── common.ml ├── common.mli ├── core_profiler.ml ├── dune ├── fstats.ml ├── fstats.mli ├── header_protocol.ml ├── header_protocol.mli ├── index.mld ├── offline.ml ├── offline.mli ├── online.ml ├── online.mli ├── probe_id.ml ├── probe_id.mli ├── probe_type.ml ├── probe_type.mli ├── profiler_epoch.ml ├── profiler_epoch.mli ├── protocol.ml ├── protocol.mli ├── std_offline.ml └── std_online.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | 3 | * Automated style changes. 4 | 5 | * Additional support for reading locally-allocated values in `Header_protocol`. 6 | 7 | 8 | ## Release v0.16.0 9 | 10 | * Updated internal binary protocol functions to support local allocation. Local allocation 11 | is an experimental compiler extension found at: 12 | https://github.com/ocaml-flambda/ocaml-jst 13 | 14 | ## Old pre-v0.15 changelogs (very likely stale and incomplete) 15 | 16 | ## 113.24.00 17 | 18 | - Switched to ppx. 19 | 20 | - Minor adjustments to the command line of profiler_tool.exe: 21 | - Make '-%' an alias for '-percentile' 22 | - Make '-percentile' accept a comma-separated list of numbers 23 | - Add '-median' argument that is equivalent to '-percentile 50' 24 | 25 | ## 113.00.00 26 | 27 | - Changed delta timers and probes so they record the total amount of time/value 28 | change between each start and pause. 29 | 30 | ## 112.19.00 31 | 32 | Initial release 33 | 34 | ## 112.17.00 35 | 36 | Initial release 37 | 38 | ## 112.06.00 39 | 40 | - Solved a problem in which OCaml 4.02 was optimizing away benchmarks, 41 | making them meaningless. 42 | 43 | ## 112.01.00 44 | 45 | - fixed legacy format string 46 | 47 | ## 109.58.00 48 | 49 | - Added support for saving inline benchmark measurements to tabular 50 | files for easy loading into Octave. 51 | 52 | ## 109.55.00 53 | 54 | - Improved `bench.mli`'s generated docs and added some usage examples. 55 | 56 | This also partly satisfies issue #3. 57 | - Added the ability to create groups of benchmarks with a common prefix. 58 | 59 | For example, the prefix "Perf" below is created in created using 60 | `create_group`: 61 | 62 | ```ocaml 63 | let command = Bench.make_command [ 64 | Bench.Test.create ~name:"Time.now" (fun () -> 65 | ignore (Time.now ())); 66 | 67 | ... 68 | 69 | Bench.Test.create_group ~name:"Perf" [ 70 | Bench.Test.create ~name:"TSC.now" ... 71 | ``` 72 | 73 | and the output shows: 74 | 75 | ``` 76 | Estimated testing time 7s (7 benchmarks x 1s). Change using -quota SECS. 77 | ┌───────────────────────────────────────────┬──────────┬─────────┬────────────┐ 78 | │ Name │ Time/Run │ mWd/Run │ Percentage │ 79 | ├───────────────────────────────────────────┼──────────┼─────────┼────────────┤ 80 | │ Time.now │ 41.38ns │ 2.00w │ 16.72% │ 81 | │ Calibrator.calibrate │ 247.42ns │ 32.00w │ 100.00% │ 82 | │ Perf/TSC.now │ 7.84ns │ │ 3.17% │ 83 | │ Perf/TSC.to_time │ 9.35ns │ 2.00w │ 3.78% │ 84 | │ Perf/TSC.to_time (TSC.now ()) │ 13.22ns │ 2.00w │ 5.34% │ 85 | │ Perf/TSC.to_nanos_since_epoch │ 10.83ns │ │ 4.38% │ 86 | │ Perf/TSC.to_nanos_since_epoch(TSC.now ()) │ 14.86ns │ │ 6.00% │ 87 | └───────────────────────────────────────────┴──────────┴─────────┴────────────┘ 88 | ``` 89 | 90 | ## 109.53.00 91 | 92 | - Fixed a bug in `Core_bench` where the linear regression was 93 | sometimes supplied with spurious data. 94 | 95 | This showed up when doing custom regressions that allow for a non-zero 96 | y-intercept. 97 | 98 | ## 109.52.00 99 | 100 | - Exposed an extensible form of `make_command` so that 101 | inline-benchmarking and the other tools can add more commandline 102 | flags. 103 | - A significant rewrite of `Core_bench`. 104 | 105 | The rewrite provides largely the same functionality as the older 106 | version. The most visible external change is that the API makes it 107 | clear that `Core_bench` performs linear regressions to come up with 108 | its numbers. Further, it allows running user-specified multivariate 109 | regressions in addition to the built in ones. 110 | 111 | The underlying code has been cleaned up in many ways, some of which 112 | are aimed at improving the implementation of inline benchmarking 113 | (the `BENCH` syntax, which has not yet been released). 114 | 115 | ## 109.41.00 116 | 117 | - Columns that have a `+` prefix are now always displayed, whereas 118 | columns that don't are displayed only if they have meaningful data. 119 | 120 | - Added the ability to reload saved metrics (benchmark test data) so 121 | that bench can re-analyze them. 122 | 123 | ## 109.39.00 124 | 125 | - Added support for additional predictors like minor/major GCs and 126 | compactions, using multi-variable linear regression. 127 | 128 | Replaced linear regression with multi-variable linear regression. 129 | The original algorithm estimated the cost of a function `f` by using 130 | a linear regression of the time taken to run `f` vs the number of 131 | runs. The new version adds the ability to include additional 132 | predictors such as minor GCs, compactions etc. 133 | 134 | This allows a more fine-grained split-up of the running costs of a 135 | function, distinguishing between the time spent actually running `f` 136 | and the time spent doing minor GCs, major GCs or compactions. 137 | - Added a forking option that allows benchmarks to be run in separate 138 | processes. 139 | 140 | This avoids any influence (e.g. polluting the cache, size of live 141 | heap words) they might otherwise have on each other. 142 | 143 | ## 109.32.00 144 | 145 | - Changed `-save` to output compaction information. 146 | 147 | - Added indexed tests. 148 | 149 | These are benchmarks of the form `int -> unit -> unit`, which can be 150 | profiled for a list of user specified `int`s. 151 | 152 | ## 109.30.00 153 | 154 | - Report compaction stats 155 | 156 | ## 109.27.00 157 | 158 | - Added R^2 error estimation. 159 | 160 | Adding this metric should give us a sense of how closely the given 161 | values fit a line. Even dots that are fairly scattered can give 162 | tight confidence intervals. We would like to have to number to have 163 | a sense of how much noise we have. 164 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2013--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /core_profiler.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/core_profiler" 5 | bug-reports: "https://github.com/janestreet/core_profiler/issues" 6 | dev-repo: "git+https://github.com/janestreet/core_profiler.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/core_profiler/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "core" 15 | "core_kernel" 16 | "core_unix" 17 | "ppx_jane" 18 | "re2" 19 | "shell" 20 | "textutils" 21 | "textutils_kernel" 22 | "dune" {>= "3.17.0"} 23 | ] 24 | available: arch != "arm32" & arch != "x86_32" 25 | synopsis: "Profiling library" 26 | description: " 27 | Core_profiler is a library that helps you profile programs and 28 | estimate various costs. 29 | " 30 | -------------------------------------------------------------------------------- /disabled_lib/core_profiler_disabled.ml: -------------------------------------------------------------------------------- 1 | module Disabled = Disabled 2 | module Intf = Intf 3 | module Profiler_units = Profiler_units 4 | module Std = Std 5 | -------------------------------------------------------------------------------- /disabled_lib/disabled.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Profiler = struct 4 | let is_enabled = false 5 | let safe_to_delay () = () 6 | let dump_stats () = () 7 | 8 | let configure 9 | ?don't_require_core_profiler_env:_ 10 | ?offline_profiler_data_file:_ 11 | ?online_print_time_interval_secs:_ 12 | ?online_print_by_default:_ 13 | () 14 | = 15 | () 16 | ;; 17 | end 18 | 19 | module Timer = struct 20 | type t = unit 21 | type probe = t 22 | 23 | let create ~name:_ = () 24 | let record _id = () 25 | 26 | module Group = struct 27 | type t = unit 28 | 29 | let create ~name:_ = () 30 | let add_probe _group ?sources:_ ~name:_ () = () 31 | let reset _group = () 32 | end 33 | end 34 | 35 | module Probe = struct 36 | type t = unit 37 | type probe = t 38 | 39 | let create ~name:_ ~units:_ = () 40 | let record _id _value = () 41 | 42 | module Group = struct 43 | type t = unit 44 | 45 | let create ~name:_ ~units:_ = () 46 | let add_probe _group ?sources:_ ~name:_ () = () 47 | let reset _group = () 48 | end 49 | end 50 | 51 | module Delta_timer = struct 52 | type state = unit 53 | type t = unit 54 | 55 | let create ~name:_ = () 56 | let stateless_start _t = () 57 | let stateless_stop _t _state = () 58 | let start _t = () 59 | let stop _t = () 60 | let pause _t = () 61 | let record _t = () 62 | let wrap_sync _t f x = f x 63 | let wrap_sync2 _t f x y = f x y 64 | let wrap_sync3 _t f x y z = f x y z 65 | let wrap_sync4 _t f x y z w = f x y z w 66 | 67 | (* let wrap_async _t f x = f x *) 68 | end 69 | 70 | module Delta_probe = struct 71 | type state = unit 72 | type t = unit 73 | 74 | let create ~name:_ ~units:_ = () 75 | let stateless_start _t _value = () 76 | let stateless_stop _t _state _value = () 77 | let start _t _value = () 78 | let stop _t _value = () 79 | let pause _t _value = () 80 | let record _t = () 81 | end 82 | -------------------------------------------------------------------------------- /disabled_lib/disabled.mli: -------------------------------------------------------------------------------- 1 | (** Every function in [Disabled] compiles to a no-op with the least overhead possible. 2 | Also see comments in [intf.ml]. *) 3 | 4 | open! Core 5 | 6 | include 7 | Intf.Profiler_intf 8 | with type Timer.t = private unit 9 | and type Probe.t = private unit 10 | and type Delta_timer.t = private unit 11 | and type Delta_probe.t = private unit 12 | -------------------------------------------------------------------------------- /disabled_lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core_profiler_disabled) 3 | (public_name core_profiler.disabled) 4 | (libraries core) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /disabled_lib/intf.ml: -------------------------------------------------------------------------------- 1 | (** For a tutorial on using [Core_profiler] please look at: 2 | [http://docs/programming/performance/core_profiler.html] 3 | 4 | This interface file defines the [Profiler_intf] interface, which has three 5 | implementations: 6 | 7 | (1) By opening [Core_profiler_disabled.Std] you get an implementation of the interface 8 | where the profiling functions are no-ops. 9 | 10 | (2) By opening [Core_profiler.Std_online] you get an implementation where the 11 | profiling stats like mean, stddev etc are maintained online, i.e. in-process with 12 | the process that is being profiled. Running the online profiler causes the program 13 | to print a table of stats periodically to stdout as your program runs. 14 | 15 | (3) By opening [Core_profiler.Std_offline] you get the implementation where the 16 | profiling data is held in-memory in a buffer and is written out to a file at 17 | process exit and the stats can be analyzed offline. For most programs this is the 18 | preferred approach to profiling. 19 | 20 | Broadly, there are two ways to collect metrics using [Core_profiler]: 21 | 22 | (1) One can collect time-stamped metrics at various points in your programs using 23 | [Probe]s. The metrics are integers that represent some application specific 24 | quantity, for example the length of some list, the number of allocated words on 25 | the heap etc. 26 | 27 | (2) Alternately, one can use [Timer]s to collect time stamps without recording any 28 | associated metric. [Timer]s are a special kind of [Probe] that are useful when one 29 | only wants to measure *when something happened* and there is no associated 30 | quantity to measure. [Timer]s are strictly less general than [Probe]s, but are 31 | slightly more efficient. *) 32 | 33 | open! Core 34 | 35 | module type Probe = sig 36 | type t 37 | type probe = t 38 | 39 | (** The [*_args] below are instantiated differently for [Timer]s and [Probe]s. See 40 | [Profiler_intf] below. *) 41 | type 'a create_args 42 | 43 | type 'a record_args 44 | 45 | (** Create a timer or probe that isn't in a group. *) 46 | val create : name:string -> t create_args 47 | 48 | (** [record] a particular data sample. *) 49 | val record : t record_args 50 | 51 | (** A [Group] provides a way of grouping multiple probes (or timers). Once grouped, one 52 | can measure stats between members of a group -- i.e. the time it takes to get from 53 | one probe to the other in the group, or the change in a metric between two probes in 54 | a group. 55 | 56 | [Core_profiler] supports a path query syntax where one can ask for stats 57 | about *paths* in the time series of data. The idea of a group is best explained by 58 | an example, which you can find in the tutorial. *) 59 | module Group : sig 60 | type t 61 | 62 | val create : name:string -> t create_args 63 | 64 | (** [sources] should be a list of probes, specifying the edges that we care about. 65 | (i.e., we care about (s, this) for all s in [sources]). When using online 66 | profiling, if no sources are specified no, stats will be collected. 67 | 68 | For offline profiling sources are less relevant. All the probe information is 69 | collected in the output and sources provides a default configuration to the 70 | profiler_tool. If no sources are specified, the offline tool will fall back to the 71 | default of "all two-probe direct paths" of a group. *) 72 | val add_probe : t -> ?sources:probe array -> name:string -> unit -> probe 73 | 74 | (** Resetting a group avoids path/delta calculation across the reset. This shouldn't 75 | be necessary in simple cases if you specify the edges you care about, via 76 | [sources] or otherwise. In more complex cases with cycles, you will need to call 77 | this at the start or end of the function you are instrumenting. *) 78 | val reset : t -> unit 79 | end 80 | end 81 | 82 | type 'a timer_create_args = 'a 83 | type 'a timer_record_args = 'a -> unit 84 | type 'a probe_create_args = units:Profiler_units.t -> 'a 85 | type 'a probe_record_args = 'a -> int -> unit 86 | 87 | (** All three profilers -- the disabled one, the online one and the offline one -- 88 | implement [Profiler_intf]. *) 89 | module type Profiler_intf = sig 90 | module Profiler : sig 91 | (** [is_enabled] can be used to "guard" expensive computations done while recording a 92 | metric. For example: 93 | 94 | {[ 95 | Probe.record len 96 | ]} 97 | 98 | If is just a variable reference it is free (when using 99 | [Core_profiler_disabled]). However, if it involves some actual work, it is better 100 | to write: 101 | 102 | {[ 103 | if Profiler.is_enabled then Probe.record len 104 | ]} 105 | 106 | When using online or offline profiling, the boolean is constant [true] and with 107 | disabled profiling, the boolean is [false]. *) 108 | val is_enabled : bool 109 | 110 | (** [configure] lets one set various profiler parameters programmatically. 111 | 112 | - [don't_require_core_profiler_env] : To protect against Core_profiler being 113 | enabled in production, it will check the environment variable [CORE_PROFILER] 114 | whenever you try to create the first [Timer] or [Probe]. Setting 115 | [don't_require_core_profiler_env] disables raising an exception if the 116 | [CORE_PROFILER] environment variable is not set. 117 | 118 | You need to call this before any [Timer] or [Probe] has been created. If you set 119 | [don't_require_core_profiler_env] after a [Timer] or [Probe] has been created, 120 | then it will raise an exception if the value you are trying to set disagrees with 121 | that which was read from the environment. 122 | 123 | - [offline_profiler_data_file] : This specifies the name of the data file to use. 124 | By default this is "profiler.dat". 125 | 126 | - [online_print_time_interval_secs] : This is the rate at which stats should be 127 | printed by the online profiler. Stats may not be printed at this rate is one 128 | does not call [at] or [safe_to_delay] periodically. 129 | 130 | - [online_print_by_default] : Setting this to [false] disables printing stats 131 | every time interval. One can print stats by explicitly calling [dump_stats]. 132 | 133 | The environment variable [CORE_PROFILER] can be used to configure the app. Also 134 | see [core_profiler_env_help_string] below. *) 135 | val configure 136 | : ?don't_require_core_profiler_env:unit 137 | -> ?offline_profiler_data_file:string 138 | -> ?online_print_time_interval_secs:int 139 | -> ?online_print_by_default:bool 140 | -> unit 141 | -> unit 142 | 143 | (** There are several slow operations that may happen occasionally when calling 144 | [record]: allocation, [Time_stamp_counter] calibration, etc. [safe_to_delay] 145 | checks if they will be necessary soon, and does them in advance. If possible, call 146 | this (fairly regularly) from a time-insensitive point in code (or at least, 147 | outside any deltas / groups) to reduce the number of spurious jumps in time 148 | deltas. If you know for certain that you will be using [Core_profiler], you also 149 | probably want to call this at startup, to perform the first allocation. *) 150 | val safe_to_delay : unit -> unit 151 | 152 | (** In the online profiler, [dump_stats] prints a table of stats -- this is the same 153 | table that is printed periodically and this function gives the user the option to 154 | disable the automatic printing and take control of the printing process. 155 | 156 | In the offline profiler, [dump_stats] writes out all the collected stats so far. 157 | This normally happens [at_exit] and this function lets the programmer dump the 158 | stats earlier. *) 159 | val dump_stats : unit -> unit 160 | end 161 | 162 | (** A [Timer] contains only a time stamp and no extra information; however, it is useful 163 | because (in [Offline]) the current time is recorded when measurements are made. *) 164 | module Timer : 165 | Probe 166 | with type 'a create_args := 'a timer_create_args 167 | and type 'a record_args := 'a timer_record_args 168 | 169 | (** A [Probe] records some integer value that is passed to [at] along with a timestamp. *) 170 | module Probe : 171 | Probe 172 | with type 'a create_args := 'a probe_create_args 173 | and type 'a record_args := 'a probe_record_args 174 | 175 | (** [Delta_probe] is an optimized two-probe group to track changes to some counter. *) 176 | module Delta_probe : sig 177 | type t 178 | type state 179 | 180 | val create : name:string -> units:Profiler_units.t -> t 181 | 182 | (** To measure changes in a value, one can call [start] followed by a call [stop] 183 | after some time. The call to [stop] will record the delta. Calls to [start]/[stop] 184 | must be interleaved for each [t]. 185 | 186 | Calling [pause] in place of [stop] causes [t] to accumulate, but not record, the 187 | delta. [start] and [pause] can then be interleaved multiple times. Afterwards, 188 | calling [record] will record the sum of the deltas between each [start]/[pause], 189 | and reset [t]. 190 | 191 | Valid sequences should satisfy this regular expression: 192 | 193 | {v 194 | start;(pause;start;)*((pause;record;)|stop;) 195 | v} 196 | 197 | Calling these functions out of order will cause bad data to be recorded. This API 198 | does not raise exceptions, so one will not be warned of errors. 199 | 200 | For each [t], there are two valid sequences of calls. The first is calling [start] 201 | then [stop]. The second is calling [start] then [pause] an arbitrary number of 202 | times, and ending with [record]. *) 203 | val start : t -> int -> unit 204 | 205 | val stop : t -> int -> unit 206 | val pause : t -> int -> unit 207 | val record : t -> unit 208 | 209 | (** These are non-stateful and can be used in Async, wherein multiple jobs might call 210 | [stateless_start] before the corresponding [stop_async] is called. One can use 211 | [stateless_start] and [stateless_stop] to wrap async functions roughly like the 212 | following. This function cannot be provided as part of the [Core_profiler] library 213 | because we'd like the library to be usable in [Async] and hence now depend on it. 214 | 215 | {[ 216 | let wrap_async t f x = 217 | let state = stateless_start t (Gc.minor_words ()) in 218 | try_with ~run:`Now (fun () -> f x) 219 | >>= fun res -> 220 | stateless_stop t state (Gc.minor_words ()); 221 | match res with 222 | | Ok x -> return x 223 | | Error ex -> Exn.reraise ex "Core_profiler wrap_async" 224 | ;; 225 | ]} 226 | 227 | The stateless API does not support pausing. This is because state would require 228 | memory allocation if it supported accumulating the counter. *) 229 | val stateless_start : t -> int -> state 230 | 231 | val stateless_stop : t -> state -> int -> unit 232 | end 233 | 234 | (** [Delta_timer] is an optimized two-probe group to track time differences between 235 | calls to [start] and [stop]. *) 236 | module Delta_timer : sig 237 | type t 238 | type state 239 | 240 | val create : name:string -> t 241 | val start : t -> unit 242 | val stop : t -> unit 243 | val pause : t -> unit 244 | val record : t -> unit 245 | val stateless_start : t -> state 246 | val stateless_stop : t -> state -> unit 247 | 248 | (** Typically partially applied (the first two arguments) to produce a 'wrapped' 249 | function. This behaves like the identity function on functions, except it times 250 | the inner function. *) 251 | val wrap_sync : t -> ('a -> 'b) -> 'a -> 'b 252 | 253 | val wrap_sync2 : t -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c 254 | val wrap_sync3 : t -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd 255 | val wrap_sync4 : t -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e 256 | end 257 | end 258 | 259 | let core_profiler_env_help_string = 260 | "\n\ 261 | \ Assign a value to environment variable CORE_PROFILER in order to proceed,\n\ 262 | \ or replace references to [Core_profiler] with [Core_profiler_disabled].\n\n\ 263 | \ The environment variable [CORE_PROFILER] must be set to run a program that uses the\n\ 264 | \ [Core_profiler] library. This check is meant to protect us from accidentally\n\ 265 | \ deploying binaries with profiling into production. The variable can contain zero \ 266 | or\n\ 267 | \ more name-value pairs.\n\n\ 268 | \ Syntax:\n\ 269 | \ CORE_PROFILER=[name=value(,name=value)+] \n\n\ 270 | \ i.e. commas are separators and invalid names will simply be ignored.\n\n\ 271 | \ The valid names are:\n\n\ 272 | \ OUTPUT_FILE=\n\ 273 | \ This determines the output filename for the offline profiler.\n\n\ 274 | \ PRINT_INTERVAL=\n\ 275 | \ This determines the integer number of seconds between outputing online stats\n\ 276 | \ summaries. Setting print interval does not affect the offline profiler.\n\n\ 277 | \ PRINT_ENABLED=\n\ 278 | \ Setting this to false disables printing in the online profiler. One can use this to\n\ 279 | \ control printing by calling the [Profiler.dump_stats] function.\n\n\ 280 | \ Example:\n\ 281 | \ CORE_PROFILER=PRINT_INTERVAL=3 myprog.exe\n\n\ 282 | \ Example:\n\ 283 | \ CORE_PROFILER= myprog.exe\n" 284 | ;; 285 | -------------------------------------------------------------------------------- /disabled_lib/profiler_units.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Poly 3 | 4 | type t = 5 | | Words 6 | | Seconds 7 | | Nanoseconds 8 | | Int 9 | [@@deriving sexp, compare] 10 | 11 | let to_string t = t |> [%sexp_of: t] |> Sexp.to_string 12 | let of_string str = str |> Sexp.of_string |> [%of_sexp: t] 13 | 14 | let format_int t x = 15 | let float_to_string = Float.to_string_hum ~strip_zero:true ~decimals:2 in 16 | let rec loop x_div suffixes = 17 | match suffixes with 18 | | [] -> assert false 19 | | [ s ] -> float_to_string x_div ^ s 20 | | s :: ss -> 21 | if Float.abs x_div < 1000. 22 | then float_to_string x_div ^ s 23 | else loop (x_div /. 1000.) ss 24 | in 25 | let x = float x in 26 | match t with 27 | | Seconds -> float_to_string x ^ "s" 28 | | Nanoseconds -> loop x [ "ns"; "us"; "ms"; "s" ] 29 | | Words -> loop x [ "w"; "kw"; "Mw"; "Gw" ] 30 | | Int -> loop x [ ""; "e3"; "e6"; "e9"; "e12" ] 31 | ;; 32 | 33 | let%test_unit "format_int" = 34 | let long = 5_000_001_000_000_001L |> Int64.to_int_exn in 35 | List.iter 36 | [ long, Nanoseconds, "5_000_001s" 37 | ; -100_100, Nanoseconds, "-100.1us" 38 | ; -99_010, Nanoseconds, "-99.01us" 39 | ; -99_001, Nanoseconds, "-99us" 40 | ; 201, Nanoseconds, "201ns" 41 | ; 4_500_000, Nanoseconds, "4.5ms" 42 | ; 1_000, Seconds, "1_000s" 43 | ; 100, Words, "100w" 44 | ; -235, Int, "-235" 45 | ] 46 | ~f:(fun (num, units, str) -> [%test_eq: string] (format_int units num) str) 47 | ;; 48 | -------------------------------------------------------------------------------- /disabled_lib/profiler_units.mli: -------------------------------------------------------------------------------- 1 | (** Units for the measurements made by [Core_profiler], used to get better output 2 | formatting. This has no performance implications. *) 3 | 4 | open! Core 5 | 6 | type t = 7 | | Words 8 | | Seconds 9 | | Nanoseconds 10 | | Int 11 | [@@deriving sexp, compare] 12 | 13 | val to_string : t -> string 14 | val of_string : string -> t 15 | val format_int : t -> int -> string 16 | -------------------------------------------------------------------------------- /disabled_lib/std.ml: -------------------------------------------------------------------------------- 1 | (** [Core_profiler_disabled] is the library in the base projection that exposes the same 2 | profiling interface as [Core_profiler]. 3 | 4 | The profiling functions exposed by this library do not collect any profiling metrics 5 | and do not have any runtime performance on the programs they are embedded in. This 6 | allows one to ship productions applications that include profiling code, but with the 7 | profiling turned off. *) 8 | module Profiler_units = Profiler_units 9 | 10 | include Disabled 11 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /offline_tool/bin/dump_metrics.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core_profiler_offline_tool.Std 3 | module Time_ns = Time_ns_unix 4 | 5 | let rec name id_map id = 6 | match Reader.Header.find_exn id_map id with 7 | | Single { name = n; _ } -> n 8 | | Group { name = n; _ } -> n 9 | | Group_point { name = n; parent; sources = _ } -> name id_map parent ^ "." ^ n 10 | ;; 11 | 12 | let display_message (m : Reader.Short_message.t) id_map = 13 | match m with 14 | | Timer (id, time) -> printf !"%{Time_ns} %-20s mark\n" time (name id_map id) 15 | | Probe (id, time, value) -> printf !"%{Time_ns} %-20s %i\n" time (name id_map id) value 16 | | Group_reset (id, time) -> 17 | printf !"%{Time_ns} %-20s group reset\n" time (name id_map id) 18 | ;; 19 | 20 | let main buffer () = 21 | let epoch, id_map = Reader.consume_header buffer in 22 | Reader.iter_short_messages buffer epoch id_map ~f:(fun message -> 23 | display_message message id_map) 24 | ;; 25 | 26 | let command = 27 | Command.basic_spec 28 | ~summary:"Dump the contents of a Core_profiler.Offline file" 29 | Command.Spec.( 30 | let iobuf_file_arg_type = Arg_type.create Reader.map_file in 31 | empty +> anon ("filename" %: iobuf_file_arg_type)) 32 | main 33 | ;; 34 | 35 | let () = Command_unix.run command 36 | -------------------------------------------------------------------------------- /offline_tool/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names dump_metrics profiler_tool) 4 | (libraries textutils.ascii_table core_unix.command_unix textutils.console 5 | core core_profiler core_profiler_disabled core_profiler_offline_tool 6 | shell.string_extended core_unix.sys_unix textutils_kernel.text_graph 7 | core_unix.time_ns_unix) 8 | (preprocess 9 | (pps ppx_jane))) 10 | 11 | (install 12 | (section bin) 13 | (files 14 | (dump_metrics.exe as core-profiler-dump-metrics) 15 | (profiler_tool.exe as core-profiler-tool))) 16 | -------------------------------------------------------------------------------- /offline_tool/bin/profiler_tool.mli: -------------------------------------------------------------------------------- 1 | (* Empty MLI so that the compiler generates unused globals warnings *) 2 | -------------------------------------------------------------------------------- /offline_tool/lib/core_profiler_offline_tool.ml: -------------------------------------------------------------------------------- 1 | module Event_generator = Event_generator 2 | module Filter = Filter 3 | module Id_table = Id_table 4 | module Interest = Interest 5 | module Path = Path 6 | module Reader = Reader 7 | module Reservoir_sampling = Reservoir_sampling 8 | module Std = Std 9 | module Util = Util 10 | -------------------------------------------------------------------------------- /offline_tool/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core_profiler_offline_tool) 3 | (public_name core_profiler.offline_tool) 4 | (libraries core_unix.bigstring_unix core core_unix.interval_lib re2 5 | core_profiler core_profiler_disabled core_unix core_kernel.iobuf 6 | core_unix.time_float_unix core_unix.time_ns_unix) 7 | (preprocess 8 | (pps ppx_jane))) 9 | -------------------------------------------------------------------------------- /offline_tool/lib/event_generator.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler 4 | open Core_profiler_disabled 5 | module Time_ns = Time_ns_unix 6 | 7 | (* (As per Path.readme,) This does not have the full power of regular expressions 8 | Notably, the same point may not appear in a path twice, except for when its 9 | second appearance is the last point in the path. *) 10 | 11 | (* The [current_session] of all groups is initialised to 0; and the session of 12 | all points is initialised to -1. 13 | 14 | To save memory and avoid allocations, junk values (-1) are stored in 15 | [point_state.at_index], [point_state.value] and [point_state.time] at startup. 16 | 17 | The mis-match in [session] between group and point prevents the junk values in 18 | [at_index], [value] and [time] from ever being used. *) 19 | 20 | type group_state = 21 | { mutable current_session : int 22 | (* The number of calls to [at] (on points in this group) in this session *) 23 | ; mutable session_at_count : int 24 | } 25 | 26 | type point_state = 27 | { mutable time : Time_ns.t 28 | ; mutable session : int 29 | (* [at_index]: when this point was marked in this session 30 | (i.e., set to [group_state.session_at_count] when marked) *) 31 | ; mutable at_index : int 32 | ; mutable value : int 33 | } 34 | 35 | type t = 36 | { id_map : Reader.Header.t 37 | ; epoch : Profiler_epoch.t (* Read only tables, but the cells are mutable records. *) 38 | ; group_state : (group_state, read) Id_table.t 39 | ; point_state : (point_state, read) Id_table.t 40 | (* Interests at this point, or interests in paths ending at this point. *) 41 | ; interests : (Probe_id.t Interest.Raw.t array, read) Id_table.t 42 | ; buffer : (read, Iobuf.no_seek) Iobuf.t 43 | } 44 | 45 | type timer_path = 46 | { interest : Probe_id.t Interest.Raw.t 47 | ; time : Time_ns.t 48 | ; time_delta : Time_ns.Span.t 49 | } 50 | [@@deriving sexp, compare] 51 | 52 | type probe_path = 53 | { interest : Probe_id.t Interest.Raw.t 54 | ; time : Time_ns.t 55 | ; time_delta : Time_ns.Span.t 56 | ; value : int 57 | ; delta : int 58 | } 59 | [@@deriving sexp, compare] 60 | 61 | type event = 62 | | Timer of Probe_id.t Interest.Raw.t * Time_ns.t 63 | | Probe of Probe_id.t Interest.Raw.t * Time_ns.t * int 64 | | Timer_path of timer_path 65 | | Probe_path of probe_path 66 | [@@deriving sexp, compare] 67 | 68 | let event_time = function 69 | | Timer (_, time) -> time 70 | | Probe (_, time, _) -> time 71 | | Timer_path { time; _ } -> time 72 | | Probe_path { time; _ } -> time 73 | ;; 74 | 75 | let create epoch id_map interests buffer = 76 | let interests_lookup = 77 | Reader.Header.create_table id_map ~groups:false Interest.Raw.I.Set.empty 78 | in 79 | List.iter interests ~f:(fun (interest : Probe_id.t Interest.Raw.t) -> 80 | let point = 81 | match interest with 82 | | Single id -> id 83 | | Group_point (_grp, id) -> id 84 | | Group_path (_grp, path) -> path.last 85 | in 86 | Id_table.find_exn interests_lookup point 87 | |> Fn.flip Set.add interest 88 | |> Id_table.set_exn interests_lookup point); 89 | let interests_lookup = 90 | Id_table.map ~f:(fun _id set -> Set.to_array set) interests_lookup 91 | in 92 | { id_map 93 | ; epoch 94 | ; group_state = 95 | Id_table.filter_map id_map ~f:(fun _id header_item -> 96 | match header_item with 97 | | Reader.Header.Item.Group _ -> Some { current_session = 0; session_at_count = 0 } 98 | | Single _ | Group_point _ -> None) 99 | ; point_state = 100 | Id_table.filter_map id_map ~f:(fun _id header_item -> 101 | match header_item with 102 | | Reader.Header.Item.Group_point _ -> 103 | Some { session = -1; time = Time_ns.epoch; value = -1; at_index = 0 } 104 | | Single _ | Group _ -> None) 105 | ; interests = Id_table.read_only interests_lookup 106 | ; buffer = Iobuf.no_seek (Iobuf.read_only buffer) 107 | } 108 | ;; 109 | 110 | let at_group_point t ~point_id ~group_id time value = 111 | let group_state = Id_table.find_exn t.group_state group_id in 112 | let point_state = Id_table.find_exn t.point_state point_id in 113 | point_state.session <- group_state.current_session; 114 | point_state.at_index <- group_state.session_at_count; 115 | point_state.time <- time; 116 | Option.iter value ~f:(fun value -> point_state.value <- value); 117 | group_state.session_at_count <- group_state.session_at_count + 1 118 | ;; 119 | 120 | let test_path t group_state (path : Probe_id.t Path.t) = 121 | let current_session = group_state.current_session in 122 | (* [last_at_index] is the [at_index] of the previous point that was considered. 123 | It's used to check whether a point was marked before the previous point 124 | (it walks from the last point to the first), and whether an edge was direct. *) 125 | let test point last_at_index = 126 | match point with 127 | | Path.Direct_point id -> 128 | let point_state = Id_table.find_exn t.point_state id in 129 | let at_index = point_state.at_index in 130 | if point_state.session = current_session && at_index = last_at_index - 1 131 | then `Point_ok at_index 132 | else `No_match 133 | | Point id -> 134 | let point_state = Id_table.find_exn t.point_state id in 135 | let at_index = point_state.at_index in 136 | if point_state.session = current_session && at_index < last_at_index 137 | then `Point_ok at_index 138 | else `No_match 139 | in 140 | (* Note that we walk from the last point to the first. *) 141 | let rec loop points last_at_index = 142 | match points with 143 | | [] -> 144 | (match test path.first last_at_index with 145 | | `Point_ok _ -> true 146 | | `No_match -> false) 147 | | pt :: points -> 148 | (match test pt last_at_index with 149 | | `Point_ok at_index -> loop points at_index 150 | | `No_match -> false) 151 | in 152 | loop path.Path.rest_rev group_state.session_at_count 153 | ;; 154 | 155 | let iter_events t ~f = 156 | Reader.iter_short_messages t.buffer t.epoch t.id_map ~f:(fun message -> 157 | let id = Reader.Short_message.id message in 158 | let header_item = Id_table.find_exn t.id_map id in 159 | (* This variable represents both /whether/ this is a group point, and if so, 160 | /what/ its group id is *) 161 | let group_point_parent = 162 | match header_item with 163 | | Group_point { parent; _ } -> Some parent 164 | | Single _ | Group _ -> None 165 | in 166 | let group_state = 167 | lazy (Option.value_exn group_point_parent |> Id_table.find_exn t.group_state) 168 | in 169 | let at_group_point' time value = 170 | Option.iter group_point_parent ~f:(fun parent -> 171 | at_group_point t ~point_id:id ~group_id:parent time value) 172 | in 173 | let interests = Id_table.find t.interests id in 174 | match message with 175 | | Timer (id, time) -> 176 | Array.iter (Option.value_exn interests) ~f:(fun interest -> 177 | match interest with 178 | | Single id2 | Group_point (_, id2) -> 179 | assert (id = id2); 180 | f (Timer (interest, time)) 181 | | Group_path (_gp, path) -> 182 | assert (id = Path.last path); 183 | if test_path t (Lazy.force group_state) path 184 | then ( 185 | let first_point_state = Id_table.find_exn t.point_state (Path.first path) in 186 | let time_delta = Time_ns.diff time first_point_state.time in 187 | f (Timer_path { interest; time; time_delta }))); 188 | at_group_point' time None 189 | | Probe (id, time, value) -> 190 | Array.iter (Option.value_exn interests) ~f:(fun interest -> 191 | match interest with 192 | | Single id2 | Group_point (_, id2) -> 193 | assert (id = id2); 194 | f (Probe (interest, time, value)) 195 | | Group_path (_gp, path) -> 196 | assert (id = Path.last path); 197 | if test_path t (Lazy.force group_state) path 198 | then ( 199 | let first_point_state = Id_table.find_exn t.point_state (Path.first path) in 200 | let time_delta = Time_ns.diff time first_point_state.time in 201 | let delta = value - first_point_state.value in 202 | f (Probe_path { interest; time; time_delta; delta; value }))); 203 | at_group_point' time (Some value) 204 | | Group_reset (id, _) -> 205 | let group_state = Id_table.find_exn t.group_state id in 206 | group_state.current_session <- group_state.current_session + 1) 207 | ;; 208 | 209 | module%test [@name "iter_group_events"] _ = struct 210 | module Protocol = Core_profiler.Protocol 211 | 212 | let to_id = Probe_id.of_int_exn 213 | let to_time_delta = Time_ns.Span.of_int_sec 214 | let to_time n = Profiler_epoch.add Protocol.Writer.epoch (to_time_delta n) 215 | 216 | let header = 217 | let open Protocol in 218 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 219 | Writer.Unsafe_internals.write_epoch (); 220 | Writer.write_new_group (to_id 0) "group" (Probe_type.Probe Profiler_units.Seconds); 221 | List.iter 222 | [ "a", 1; "b", 2; "c", 3; "d", 4; "e", 5; "f", 6; "g", 7 ] 223 | ~f:(fun (name, id) -> 224 | Writer.write_new_group_point ~id:(to_id id) ~group_id:(to_id 0) name [||]); 225 | Writer.Unsafe_internals.write_end_of_header (); 226 | Buffer.get_header_chunk () |> Reader.consume_header |> snd) 227 | ;; 228 | 229 | let name_map = Util.Name_map.of_id_map header 230 | let header_group = Map.find_exn name_map.groups "group" 231 | 232 | let to_path s = 233 | Path.string_t_of_string s |> Option.value_exn |> Fn.flip Path.lookup_ids header_group 234 | ;; 235 | 236 | let to_path_int s = Interest.Raw.Group_path (to_id 0, to_path s) 237 | 238 | let run_case ats interests = 239 | protect ~finally:Protocol.Buffer.Unsafe_internals.reset ~f:(fun () -> 240 | let at id n = Protocol.Writer.write_probe_at (to_id id) (to_time n) n in 241 | String.to_list ats 242 | |> List.iteri ~f:(fun n c -> 243 | match c with 244 | | 'a' -> at 1 n 245 | | 'b' -> at 2 n 246 | | 'c' -> at 3 n 247 | | 'd' -> at 4 n 248 | | 'e' -> at 5 n 249 | | 'f' -> at 6 n 250 | | 'g' -> at 7 n 251 | | 'r' -> Protocol.Writer.write_group_reset (to_id 0) (to_time n) 252 | | ' ' -> () 253 | | _ -> failwith "Bad test case"); 254 | let buffer = 255 | match Protocol.Buffer.get_chunks () with 256 | | [ x ] -> x 257 | | _ -> failwith "expected one chunk" 258 | in 259 | let ev_gen = create Protocol.Writer.epoch header interests buffer in 260 | let events_rev = ref [] in 261 | iter_events ev_gen ~f:(fun x -> events_rev := x :: !events_rev); 262 | List.rev !events_rev) 263 | ;; 264 | 265 | let to_event interest value delta = 266 | Probe_path 267 | { interest; time = to_time value; time_delta = to_time_delta delta; value; delta } 268 | ;; 269 | 270 | let%test_unit "multiple simultaneous events" = 271 | [%test_eq: event list] 272 | (run_case "abc" [ to_path_int "a..c"; to_path_int "b,c" ]) 273 | [ to_event (to_path_int "b,c") 2 1; to_event (to_path_int "a..c") 2 2 ] 274 | ;; 275 | 276 | let%test_unit "reset" = 277 | [%test_eq: event list] (run_case "aaa r ccc" [ to_path_int "a..c" ]) [] 278 | ;; 279 | 280 | let%test_unit "directness" = 281 | [%test_eq: event list] 282 | (run_case "cd d dc r c d ced r ced" [ to_path_int "c,d" ]) 283 | [ to_event (to_path_int "c,d") 1 1; to_event (to_path_int "c,d") 14 4 ] 284 | ;; 285 | 286 | let%test_unit "repeated" = 287 | let p = to_path_int "a,a" in 288 | [%test_eq: event list] 289 | (run_case "aaaaa r a" [ p ]) 290 | [ to_event p 1 1; to_event p 2 1; to_event p 3 1; to_event p 4 1 ] 291 | ;; 292 | 293 | (* TEST_UNIT "multiple simultaneous events" = 294 | * <:test_eq< event list >> 295 | * (run_case "abc" [ to_path_int "a,c"; to_path_int "b.c" ]) 296 | * [ to_event (to_path_int "b.c") 2 1; to_event (to_path_int "a,c") 2 2 ] 297 | * 298 | * TEST_UNIT "reset" = 299 | * <:test_eq< event list >> (run_case "aaa r ccc" [ to_path_int "a,c" ]) [] 300 | * 301 | * TEST_UNIT "directness" = 302 | * <:test_eq< event list >> 303 | * (run_case "cd d dc r c d ced r ced" [ to_path_int "c.d" ]) 304 | * [ to_event (to_path_int "c.d") 1 1; to_event (to_path_int "c.d") 14 4 ] 305 | * 306 | * TEST_UNIT "repeated" = 307 | * let p = to_path_int "a.a" in 308 | * <:test_eq< event list >> 309 | * (run_case "aaaaa r a" [ p ]) 310 | * [ to_event p 1 1; to_event p 2 1; to_event p 3 1; to_event p 4 1 ] *) 311 | end 312 | -------------------------------------------------------------------------------- /offline_tool/lib/event_generator.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | 4 | (** Reads profiler data stored in a file and filters them appropriately *) 5 | type t 6 | 7 | type timer_path = 8 | { interest : Probe_id.t Interest.Raw.t 9 | ; time : Time_ns.t 10 | ; time_delta : Time_ns.Span.t 11 | } 12 | [@@deriving sexp, compare] 13 | 14 | type probe_path = 15 | { interest : Probe_id.t Interest.Raw.t 16 | ; time : Time_ns.t 17 | ; time_delta : Time_ns.Span.t 18 | ; value : int 19 | ; delta : int 20 | } 21 | [@@deriving sexp, compare] 22 | 23 | type event = 24 | (* Timer and probe events are emitted for both singles and points. *) 25 | | Timer of Probe_id.t Interest.Raw.t * Time_ns.t 26 | | Probe of Probe_id.t Interest.Raw.t * Time_ns.t * int 27 | | Timer_path of timer_path 28 | | Probe_path of probe_path 29 | [@@deriving sexp, compare] 30 | 31 | val event_time : event -> Time_ns.t 32 | 33 | (** A [t] emits (via [iter_events]) all [event]s that match the list of raw interests 34 | provided. The source of the event is identified by passing the raw interest inside the 35 | [event]; interests are hashable and comparable. *) 36 | val create 37 | : Profiler_epoch.t 38 | -> Reader.Header.t 39 | -> Probe_id.t Interest.Raw.t list 40 | -> ([> read ], _) Iobuf.t 41 | -> t 42 | 43 | val iter_events : t -> f:(event -> unit) -> unit 44 | -------------------------------------------------------------------------------- /offline_tool/lib/filter.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler 4 | open Core_profiler_disabled 5 | module Interval = Interval_lib.Interval 6 | 7 | type -'rw t = 8 | { (* This table maps raw interests (from the event generator) to 9 | (the filter we want to check, the original interest). *) 10 | interests : Probe_id.t Interest.t list Interest.Raw.I.Table.t 11 | ; id_map : Reader.Header.t 12 | } 13 | 14 | let create (id_map : Reader.Header.t) = 15 | { interests = Interest.Raw.I.Table.create (); id_map } 16 | ;; 17 | 18 | let add_interest t interest = 19 | (* Check that value/delta filters are only applied to probes, 20 | and that the units on all filters are correct. *) 21 | (match interest with 22 | | Interest.All _ -> () 23 | | Interest.In_interval (_, Time_delta, iv_units, _) -> 24 | if iv_units <> Profiler_units.Nanoseconds 25 | then failwith "Units of time delta interval should be nanoseconds" 26 | | Interest.In_interval (_, (Value | Delta), iv_units, _) -> 27 | let units = 28 | Interest.spec interest t.id_map 29 | |> Probe_type.units 30 | |> Option.value_exn ~message:"Can't test the value / delta of a timer" 31 | in 32 | if units <> iv_units then failwith "Units of interval do not match units of Probe"); 33 | (* Check that delta / time_delta filters are only applied to paths *) 34 | (match interest with 35 | | Interest.All _ -> () 36 | | Interest.In_interval (Group_path _, (Delta | Time_delta), _, _) -> () 37 | | Interest.In_interval (_, Value, _, _) -> () 38 | | Interest.In_interval ((Group_point _ | Single _), (Delta | Time_delta), _, _) -> 39 | failwith "Can only filter time deltas / deltas when considering a path"); 40 | Hashtbl.add_multi t.interests ~key:(Interest.raw interest) ~data:interest 41 | ;; 42 | 43 | let read_only (t : _ t) = (t :> read t) 44 | 45 | (* [add_interest] asserts that we only filter on legal subjects, so 46 | we can safely pass junk values in delta and time_delta when appropriate, 47 | and it won't match a case that uses them *) 48 | let test_one ~value ~time_delta ~delta interest = 49 | match (interest : 'a Interest.t) with 50 | | All _ -> true 51 | | In_interval (_, sub, _, interval) -> 52 | let sub' = 53 | match sub with 54 | | Value -> value 55 | | Time_delta -> Time_ns.Span.to_int_ns time_delta 56 | | Delta -> delta 57 | in 58 | Interval.Int.contains interval sub' 59 | ;; 60 | 61 | let test t event = 62 | match (event : Event_generator.event) with 63 | | Timer (interest, _t) -> 64 | Hashtbl.find t.interests interest 65 | (* Since the only interests that can be registered for Timers are [All]... *) 66 | |> Option.value ~default:[] 67 | | Probe (interest, _t, value) -> 68 | Hashtbl.find t.interests interest 69 | |> Option.value ~default:[] 70 | |> List.filter ~f:(test_one ~value ~time_delta:Time_ns.Span.zero ~delta:0) 71 | | Timer_path { interest; time_delta; time = _ } -> 72 | Hashtbl.find t.interests interest 73 | |> Option.value ~default:[] 74 | |> List.filter ~f:(test_one ~value:0 ~time_delta ~delta:0) 75 | | Probe_path { interest; time_delta; delta; value; time = _ } -> 76 | Hashtbl.find t.interests interest 77 | |> Option.value ~default:[] 78 | |> List.filter ~f:(test_one ~value ~time_delta ~delta) 79 | ;; 80 | 81 | (* = not (List.is_empty (test t event)) *) 82 | let test' t event = 83 | match (event : Event_generator.event) with 84 | | Timer (interest, _t) -> 85 | (match Hashtbl.find t.interests interest with 86 | | None | Some [] -> false 87 | | Some (_ :: _) -> true) 88 | | Probe (interest, _t, value) -> 89 | Hashtbl.find t.interests interest 90 | |> Option.value ~default:[] 91 | |> List.exists ~f:(test_one ~value ~time_delta:Time_ns.Span.zero ~delta:0) 92 | | Timer_path { interest; time_delta; time = _ } -> 93 | Hashtbl.find t.interests interest 94 | |> Option.value ~default:[] 95 | |> List.exists ~f:(test_one ~value:0 ~time_delta ~delta:0) 96 | | Probe_path { interest; time_delta; delta; value; time = _ } -> 97 | Hashtbl.find t.interests interest 98 | |> Option.value ~default:[] 99 | |> List.exists ~f:(test_one ~value ~time_delta ~delta) 100 | ;; 101 | 102 | let iter_events t events ~f = 103 | Event_generator.iter_events events ~f:(fun event -> 104 | match test t event with 105 | | [] -> () 106 | | _ :: _ as interests -> f event interests) 107 | ;; 108 | 109 | let iter_events_interests t events ~f = 110 | Event_generator.iter_events events ~f:(fun event -> 111 | List.iter (test t event) ~f:(f event)) 112 | ;; 113 | 114 | let raw_interests t = Hashtbl.keys t.interests 115 | -------------------------------------------------------------------------------- /offline_tool/lib/filter.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | 4 | type -'rw t 5 | 6 | val create : Reader.Header.t -> [< _ perms ] t 7 | val read_only : [> read ] t -> read t 8 | val add_interest : read_write t -> Probe_id.t Interest.t -> unit 9 | 10 | (** Which interests does this event match? *) 11 | val test : [> read ] t -> Event_generator.event -> Probe_id.t Interest.t list 12 | 13 | (** Does this event match anything? *) 14 | val test' : [> read ] t -> Event_generator.event -> bool 15 | 16 | (** [f] is given the event, and the interests it matched *) 17 | val iter_events 18 | : [> read ] t 19 | -> Event_generator.t 20 | -> f:(Event_generator.event -> Probe_id.t Interest.t list -> unit) 21 | -> unit 22 | 23 | val iter_events_interests 24 | : [> read ] t 25 | -> Event_generator.t 26 | -> f:(Event_generator.event -> Probe_id.t Interest.t -> unit) 27 | -> unit 28 | 29 | (** All raw interests the filter is (currently) interested in receiving events for. In the 30 | basic case, you'll want to construct a [t] (a filter), and then build a 31 | [Event_generator.t] using the raw interests specified by this function. *) 32 | val raw_interests : [> read ] t -> Probe_id.t Interest.Raw.t list 33 | -------------------------------------------------------------------------------- /offline_tool/lib/id_table.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core_profiler 3 | 4 | type ('a, +'rw) t = 'a option array 5 | 6 | let ids_range ids = 7 | let ids = List.map ids ~f:Probe_id.to_int_exn in 8 | List.iter ids ~f:(fun id -> assert (id >= 0)); 9 | match List.max_elt ids ~compare:Int.compare with 10 | | None -> 0 11 | | Some x -> x + 1 12 | ;; 13 | 14 | let create ids empty = 15 | let len = ids_range ids in 16 | let t = Array.create ~len None in 17 | List.iter ids ~f:(fun id -> t.(Probe_id.to_int_exn id) <- Some empty); 18 | t 19 | ;; 20 | 21 | let create' other_t empty = 22 | Array.map other_t ~f:(function 23 | | None -> None 24 | | Some _x -> Some empty) 25 | ;; 26 | 27 | let init ids ~f = 28 | let len = ids_range ids in 29 | let t = Array.create ~len None in 30 | List.iter ids ~f:(fun id -> t.(Probe_id.to_int_exn id) <- Some (f id)); 31 | t 32 | ;; 33 | 34 | let init_from_map id_map ~f = 35 | let len = 36 | match Map.min_elt id_map, Map.max_elt id_map with 37 | | None, _ | _, None -> 0 38 | | Some (min_elt, _), Some (max_elt, _) -> 39 | let min_elt = Probe_id.to_int_exn min_elt in 40 | let max_elt = Probe_id.to_int_exn max_elt in 41 | assert (min_elt >= 0); 42 | max_elt + 1 43 | in 44 | let t = Array.create ~len None in 45 | Map.iteri id_map ~f:(fun ~key:id ~data:metadata -> 46 | t.(Probe_id.to_int_exn id) <- Some (f id metadata)); 47 | t 48 | ;; 49 | 50 | let find t id = 51 | let id' = Probe_id.to_int_exn id in 52 | if id' < 0 || id' >= Array.length t then None else Array.unsafe_get t id' 53 | ;; 54 | 55 | let find_exn t id = 56 | match find t id with 57 | | None -> failwithf !"Id %{Probe_id} not found amongst" id () 58 | | Some data -> data 59 | ;; 60 | 61 | let set_exn (type a) (t : (a, 'rw) t) id data = 62 | (* Check that the cell is filled / the Id is legit first: *) 63 | ignore (find_exn t id : a); 64 | t.(Probe_id.to_int_exn id) <- Some data 65 | ;; 66 | 67 | let iter t ~f = 68 | Array.iteri t ~f:(fun id data -> 69 | match data with 70 | | Some data -> f (Probe_id.of_int_exn id) data 71 | | None -> ()) 72 | ;; 73 | 74 | let fold t ~init ~f = 75 | Array.foldi t ~init ~f:(fun id accum data -> 76 | match data with 77 | | Some data -> f accum (Probe_id.of_int_exn id) data 78 | | None -> accum) 79 | ;; 80 | 81 | let fold_right t ~init ~f = 82 | let rec loop i accum = 83 | let accum = 84 | match t.(i) with 85 | | Some data -> f accum (Probe_id.of_int_exn i) data 86 | | None -> accum 87 | in 88 | if i <= 0 then accum else loop (i - 1) accum 89 | in 90 | loop (Array.length t - 1) init 91 | ;; 92 | 93 | let to_alist t = fold_right t ~init:[] ~f:(fun accum id item -> (id, item) :: accum) 94 | 95 | let map t ~f = 96 | let ( >>| ) = Option.( >>| ) in 97 | Array.mapi t ~f:(fun id' data -> 98 | let id = Probe_id.of_int_exn id' in 99 | data >>| f id) 100 | ;; 101 | 102 | let filter_map t ~f = 103 | let ( >>= ) = Option.( >>= ) in 104 | Array.mapi t ~f:(fun id' data -> 105 | let id = Probe_id.of_int_exn id' in 106 | data >>= f id) 107 | ;; 108 | 109 | let read_only t = t 110 | -------------------------------------------------------------------------------- /offline_tool/lib/id_table.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | 4 | (** An [Id_table.t] exploits the fact that [Probe_id.t]s should be consecutive integers to 5 | make lookups fast *) 6 | (* Perhaps this would be far simpler if we used separate Id spaces for each type 7 | (with a couple of type bits for the header?) *) 8 | 9 | type ('a, +'rw) t 10 | 11 | (** To create a table you need to specify which [Probe_id.t]s are valid cells, and give an 12 | empty value. This can either be in the form of a list of [Probe_id.t]s, or by copying 13 | the list from another [Id_table.t] (whose cell contents are ignored) *) 14 | val create : Probe_id.t list -> 'a -> ('a, _) t 15 | 16 | val create' : (_, _) t -> 'a -> ('a, _) t 17 | val init : Probe_id.t list -> f:(Probe_id.t -> 'a) -> ('a, _) t 18 | val init_from_map : 'b Probe_id.Map.t -> f:(Probe_id.t -> 'b -> 'a) -> ('a, _) t 19 | val set_exn : ('a, read_write) t -> Probe_id.t -> 'a -> unit 20 | 21 | (** A [('a, read_only) Id_table.t] is meant to look like an [Probe_id.Map.t]: *) 22 | val find : ('a, _) t -> Probe_id.t -> 'a option 23 | 24 | val find_exn : ('a, _) t -> Probe_id.t -> 'a 25 | val iter : ('a, _) t -> f:(Probe_id.t -> 'a -> unit) -> unit 26 | val fold : ('a, _) t -> init:'accum -> f:('accum -> Probe_id.t -> 'a -> 'accum) -> 'accum 27 | 28 | val fold_right 29 | : ('a, _) t 30 | -> init:'accum 31 | -> f:('accum -> Probe_id.t -> 'a -> 'accum) 32 | -> 'accum 33 | 34 | val to_alist : ('a, _) t -> (Probe_id.t * 'a) list 35 | val map : ('a, _) t -> f:(Probe_id.t -> 'a -> 'b) -> ('b, _) t 36 | val filter_map : ('a, _) t -> f:(Probe_id.t -> 'a -> 'b option) -> ('b, _) t 37 | val read_only : ('a, _) t -> ('a, read) t 38 | -------------------------------------------------------------------------------- /offline_tool/lib/interest.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler 4 | open Core_profiler_disabled 5 | module Interval = Interval_lib.Interval 6 | 7 | module Raw = struct 8 | type 'a t = 9 | | Single of 'a 10 | | Group_point of 'a * 'a 11 | | Group_path of 'a * 'a Path.t 12 | [@@deriving sexp, compare] 13 | 14 | let is_path = function 15 | | Single _ | Group_point _ -> false 16 | | Group_path _ -> true 17 | ;; 18 | 19 | module I = struct 20 | type id_raw_interest = Probe_id.t t [@@deriving sexp, compare] 21 | 22 | module T = struct 23 | type t = id_raw_interest [@@deriving sexp, compare] 24 | 25 | let hash = function 26 | | Single id -> Probe_id.to_int_exn id 27 | | Group_point (_, id) -> Probe_id.to_int_exn id 28 | | Group_path (_, path) -> Path.I.hash path 29 | ;; 30 | end 31 | 32 | include T 33 | include Comparable.Make (T) 34 | include Hashable.Make_and_derive_hash_fold_t (T) 35 | end 36 | end 37 | 38 | module Interval_subject = struct 39 | type t = 40 | | Value 41 | | Delta 42 | | Time_delta 43 | [@@deriving sexp, compare] 44 | 45 | let of_string = function 46 | | "v" -> Value 47 | | "dv" -> Delta 48 | | "dt" -> Time_delta 49 | | _ -> failwith "Bad interval subject, expected one of v, dv or dt" 50 | ;; 51 | 52 | let to_string = function 53 | | Value -> "v" 54 | | Delta -> "dv" 55 | | Time_delta -> "dt" 56 | ;; 57 | 58 | let to_int = function 59 | | Value -> 1 60 | | Delta -> 2 61 | | Time_delta -> 3 62 | ;; 63 | end 64 | 65 | type 'a t = 66 | | All of 'a Raw.t 67 | | In_interval of 'a Raw.t * Interval_subject.t * Profiler_units.t * Interval.Int.t 68 | [@@deriving sexp] 69 | 70 | let interval_compare a b = 71 | match Interval.Int.bounds a, Interval.Int.bounds b with 72 | | None, None -> 0 73 | | Some _, None -> 1 74 | | None, Some _ -> -1 75 | | Some (la, ua), Some (lb, ub) -> 76 | let c = Int.compare la lb in 77 | if c <> 0 then c else Int.compare ua ub 78 | ;; 79 | 80 | let compare a_compare x y = 81 | match x, y with 82 | | All rx, All ry -> Raw.compare a_compare rx ry 83 | | In_interval (rx, sx, ux, ivx), In_interval (ry, sy, uy, ivy) -> 84 | let c = Raw.compare a_compare rx ry in 85 | if c <> 0 86 | then c 87 | else ( 88 | let c = Interval_subject.compare sx sy in 89 | if c <> 0 90 | then c 91 | else ( 92 | let c = Profiler_units.compare ux uy in 93 | if c <> 0 then c else interval_compare ivx ivy)) 94 | | All _, In_interval _ -> -1 95 | | In_interval _, All _ -> 1 96 | ;; 97 | 98 | let raw = function 99 | | All r -> r 100 | | In_interval (r, _, _, _) -> r 101 | ;; 102 | 103 | let string_t_of_sexp = t_of_sexp String.t_of_sexp 104 | let sexp_of_string_t = sexp_of_t String.sexp_of_t 105 | 106 | let parse_filter = 107 | let regex = Or_error.ok_exn (Re2.create "(v|dv|dt)\\[(.+)\\,(.+)\\]") in 108 | fun str -> 109 | let subs = Re2.find_submatches_exn regex str in 110 | let subject_str = Option.value_exn subs.(1) ~message:"missing subject" in 111 | let left_str = Option.value_exn subs.(2) ~message:"missing left limit" in 112 | let right_str = Option.value_exn subs.(3) ~message:"missing right limit" in 113 | let subject = Interval_subject.of_string subject_str in 114 | subject, Util.int_units_of_string left_str, Util.int_units_of_string right_str 115 | ;; 116 | 117 | let string_t_of_string str = 118 | let str, filter_part = 119 | match String.rsplit2 str ~on:'~' with 120 | | Some (l, r) -> l, Some r 121 | | None -> str, None 122 | in 123 | let raw = 124 | let open Raw in 125 | match String.lsplit2 str ~on:':' with 126 | | None -> Single str 127 | | Some (group, group_interest) -> 128 | (match Path.string_t_of_string group_interest with 129 | | None -> Group_point (group, group_interest) 130 | | Some path -> Group_path (group, path)) 131 | in 132 | match filter_part with 133 | | Some filter_part -> 134 | let subject, (left, left_units), (right, right_units) = parse_filter filter_part in 135 | let units = Util.choose_units left_units right_units in 136 | let left = Util.coerce_units left ~current:left_units ~desired:units in 137 | let right = Util.coerce_units right ~current:right_units ~desired:units in 138 | let interval = Interval.Int.create left right in 139 | In_interval (raw, subject, units, interval) 140 | | None -> All raw 141 | ;; 142 | 143 | let string_t_to_string interest = 144 | let raw_to_string r = 145 | let open Raw in 146 | match r with 147 | | Single a -> a 148 | | Group_point (g, pt) -> g ^ ":" ^ pt 149 | | Group_path (g, pth) -> g ^ ":" ^ Path.string_t_to_string pth 150 | in 151 | match interest with 152 | | All raw -> raw_to_string raw 153 | | In_interval (raw, sub, units, interval) -> 154 | let sub = Interval_subject.to_string sub in 155 | let l, r = Interval.Int.bounds_exn interval in 156 | sprintf 157 | "%s~%s[%s,%s]" 158 | (raw_to_string raw) 159 | sub 160 | (Profiler_units.format_int units l) 161 | (Profiler_units.format_int units r) 162 | ;; 163 | 164 | let lookup_ids' t (name_map : Util.Name_map.t) = 165 | let lookup_raw r = 166 | let open Raw in 167 | match r with 168 | | Single name -> Single (Map.find_exn name_map.singles name) 169 | | Group_point (name, point) -> 170 | let group = Map.find_exn name_map.groups name in 171 | Group_point (group.id, Map.find_exn group.children point) 172 | | Group_path (name, path) -> 173 | let group = Map.find_exn name_map.groups name in 174 | Group_path (group.id, Path.lookup_ids path group) 175 | in 176 | match t with 177 | | All raw -> All (lookup_raw raw) 178 | | In_interval (raw, subject, units, interval) -> 179 | In_interval (lookup_raw raw, subject, units, interval) 180 | ;; 181 | 182 | let lookup_ids t name_map = 183 | try lookup_ids' t name_map with 184 | | (Not_found_s _ | Stdlib.Not_found) as ex -> 185 | Exn.reraisef 186 | ex 187 | "Invalid interest %s: name lookup in header failed" 188 | (string_t_to_string t) 189 | () 190 | ;; 191 | 192 | let lookup_names t id_map = 193 | let get_name x = Reader.Header.get_name_exn ?with_group:None id_map x in 194 | let lookup_raw r = 195 | let open Raw in 196 | match r with 197 | | Single id -> Single (get_name id) 198 | | Group_point (group, point) -> Group_point (get_name group, get_name point) 199 | | Group_path (group, path) -> 200 | Group_path (get_name group, Path.lookup_names path id_map) 201 | in 202 | match t with 203 | | All raw -> All (lookup_raw raw) 204 | | In_interval (raw, subject, units, interval) -> 205 | In_interval (lookup_raw raw, subject, units, interval) 206 | ;; 207 | 208 | let id_t_to_string t id_map = string_t_to_string (lookup_names t id_map) 209 | 210 | let spec interest id_map = 211 | match (raw interest : Probe_id.t Raw.t) with 212 | | Single id | Group_point (id, _) | Group_path (id, _) -> 213 | Reader.Header.get_spec_exn id_map id 214 | ;; 215 | 216 | let is_path = function 217 | | All raw -> Raw.is_path raw 218 | | In_interval (raw, _, _, _) -> Raw.is_path raw 219 | ;; 220 | 221 | let coerce_interval_units t id_map = 222 | match t with 223 | | All _ -> t 224 | | In_interval (raw, iv_subject, iv_units, interval) -> 225 | let desired = 226 | match iv_subject with 227 | | Value | Delta -> 228 | Probe_type.units (spec t id_map) 229 | |> Option.value_exn ~message:"Can't filter the value / delta of a Timer" 230 | | Time_delta -> Profiler_units.Nanoseconds 231 | in 232 | let interval = 233 | Interval.Int.map interval ~f:(Util.coerce_units ~current:iv_units ~desired) 234 | in 235 | In_interval (raw, iv_subject, desired, interval) 236 | ;; 237 | 238 | let examples = 239 | let open Raw in 240 | [ All (Single "probe_or_timer_name") 241 | ; All (Group_point ("group1", "single_point_name")) 242 | ; In_interval 243 | (Single "some_probe", Value, Profiler_units.Words, Interval.Int.create 20_000 20_100) 244 | ; In_interval 245 | ( Group_path ("some_group", List.nth_exn Path.examples 0) 246 | , Delta 247 | , Profiler_units.Int 248 | , Interval.Int.create 5 12 ) 249 | ; In_interval 250 | ( Group_path ("some_other_group", List.nth_exn Path.examples 1) 251 | , Time_delta 252 | , Profiler_units.Nanoseconds 253 | , Interval.Int.create 20 10_000 ) 254 | ] 255 | ;; 256 | 257 | let%test "of_to_string" = 258 | List.for_all examples ~f:(fun ex -> 259 | let ex2 = ex |> string_t_to_string |> string_t_of_string in 260 | ex = ex2) 261 | ;; 262 | 263 | let readme = 264 | lazy 265 | ([ `S 266 | "An interest is a string that specifies some subset of the core-profiler file \ 267 | that you are interested in / wish to inspect.\n\n" 268 | ; `S "You can ask for an individual timer or probe by specifying its name:\n\n" 269 | ; `S " " 270 | ; `E (All (Single "probe_or_timer_name")) 271 | ; `S "\n\n" 272 | ; `S "And inspect the values (no deltas) of a point of a probe group like so:\n\n" 273 | ; `S " " 274 | ; `E (All (Group_point ("group1", "single_point_name"))) 275 | ; `S "\n\n" 276 | ; `S 277 | "To get deltas from a group, you need to describe the path you're interested in.\n" 278 | ; `S (Lazy.force Path.readme) 279 | ; `S "\n\n" 280 | ; `S 281 | "You may also filter the data by demanding that the value, delta or time_delta \ 282 | be in some interval. The syntax for filtering is as follows: \n\n" 283 | ; `S " interest~subject[lower,upper]\n\n" 284 | ; `S 285 | "Where interest is a raw interest as described above, subject is one of 't', \ 286 | 'd' or 'v', and [lower, upper] specify the interval. The interval may be \ 287 | specified using units appropriate to the probe filtered, e.g., '3ms' or \ 288 | '1kw'.\n\n" 289 | ; `S "Some examples:\n\n" 290 | ; `S " " 291 | ; `E (List.nth_exn examples 2) 292 | ; `S "\n" 293 | ; `S " " 294 | ; `E (List.nth_exn examples 3) 295 | ; `S "\n" 296 | ; `S " " 297 | ; `E (List.nth_exn examples 4) 298 | ] 299 | |> List.map ~f:(function 300 | | `S s -> s 301 | | `E e -> string_t_to_string e) 302 | |> String.concat) 303 | ;; 304 | 305 | let arg_type = Command.Spec.Arg_type.create string_t_of_string 306 | let list_arg = Command.Spec.(anon (sequence ("interest" %: arg_type))) 307 | 308 | module I = struct 309 | type id_interest = Probe_id.t t [@@deriving sexp, compare] 310 | 311 | module T = struct 312 | type t = id_interest [@@deriving sexp, compare] 313 | 314 | let hash_in_interval subj interval = 315 | let subj = Interval_subject.to_int subj in 316 | let l = Option.value ~default:1 (Interval.Int.lbound interval) in 317 | let h = Option.value ~default:2 (Interval.Int.ubound interval) in 318 | (1 lsl 17) - 1 + subj + l + h 319 | ;; 320 | 321 | let hash = function 322 | | All raw -> Raw.I.hash raw 323 | | In_interval (raw, subj, _units, interval) -> 324 | Int.hash (Raw.I.hash raw * hash_in_interval subj interval) 325 | ;; 326 | end 327 | 328 | include T 329 | include Comparable.Make (T) 330 | include Hashable.Make_and_derive_hash_fold_t (T) 331 | end 332 | 333 | let default_interests id_map = 334 | let get_points group_id = 335 | Reader.Header.((find_group_exn id_map group_id).Item.children) 336 | in 337 | let get_points_sources group_id = 338 | get_points group_id 339 | |> List.map ~f:(fun child_id -> 340 | let sources = Reader.Header.((find_group_point_exn id_map child_id).Item.sources) in 341 | child_id, sources) 342 | in 343 | let product_fold outer ~init ~get_inner ~f = 344 | List.fold outer ~init ~f:(fun acc b -> 345 | List.fold (get_inner b) ~init:acc ~f:(fun acc a -> f acc a b)) 346 | in 347 | let add_group_default_interests accum group_id = 348 | let group_points = get_points_sources group_id in 349 | let some_defaults_specified = 350 | List.exists group_points ~f:(fun (_id, sources) -> not (List.is_empty sources)) 351 | in 352 | if some_defaults_specified 353 | then 354 | product_fold 355 | group_points 356 | ~get_inner:(fun (_, sources) -> sources) 357 | ~init:accum 358 | ~f:(fun acc a (b, _) -> 359 | let path = Path.{ last = b; first = Point a; rest_rev = [] } in 360 | All (Group_path (group_id, path)) :: acc) 361 | else 362 | product_fold 363 | group_points 364 | ~get_inner:(fun _ -> group_points) 365 | ~init:accum 366 | ~f:(fun acc (a, _) (b, _) -> 367 | let path = Path.{ last = b; first = Direct_point a; rest_rev = [] } in 368 | All (Group_path (group_id, path)) :: acc) 369 | in 370 | Id_table.fold id_map ~init:[] ~f:(fun acc id header_item -> 371 | match header_item with 372 | | Single _ -> All (Single id) :: acc 373 | | Group _ -> add_group_default_interests acc id 374 | | Group_point { parent; _ } -> All (Group_point (parent, id)) :: acc) 375 | ;; 376 | -------------------------------------------------------------------------------- /offline_tool/lib/interest.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | open Core_profiler_disabled 4 | module Interval := Interval_lib.Interval 5 | 6 | module Interval_subject : sig 7 | type t = 8 | | Value 9 | | Delta 10 | | Time_delta 11 | [@@deriving sexp, compare] 12 | 13 | val of_string : string -> t 14 | val to_string : t -> string 15 | val to_int : t -> int 16 | end 17 | 18 | (** A raw or "unfiltered" interest. Specifically, an [Event_generator.t] can produce 19 | events given a buffer and a list of raw interests, which are typically then "filtered" 20 | by a [Filter.t] (a filter takes a list of actual interests / [Interest.t]s). An event 21 | will only ever match one [Interest.Raw.t] (indeed, events are keyed by raw interests 22 | in [Event_generator.t]) whereas it could match several distinct [Interest.t]s (e.g., 23 | overlapping intervals) *) 24 | module Raw : sig 25 | type 'a t = 26 | | Single of 'a 27 | | Group_point of 'a * 'a 28 | | Group_path of 'a * 'a Path.t 29 | [@@deriving sexp, compare] 30 | 31 | module I : sig 32 | type id_raw_interest = Probe_id.t t 33 | type t = id_raw_interest 34 | 35 | include Comparable.S with type t := t 36 | include Hashable.S with type t := t 37 | end 38 | end 39 | 40 | (** A [t] specifies some subset of the core-profiler file that we're interested in. *) 41 | type 'a t = 42 | | All of 'a Raw.t 43 | | In_interval of 'a Raw.t * Interval_subject.t * Profiler_units.t * Interval.Int.t 44 | [@@deriving sexp, compare] 45 | 46 | (** When keyed by [Probe_id.t]s, interests are comparable, hashable. *) 47 | module I : sig 48 | type id_interest = Probe_id.t t 49 | type t = id_interest 50 | 51 | include Comparable.S with type t := t 52 | include Hashable.S with type t := t 53 | end 54 | 55 | (** If this is a filtered interest, this drills down to the 'raw' unfiltered interest. 56 | Currently, this means it retrieves the first argument of an [In_interval] interest, 57 | and is the identity function otherwise. *) 58 | val raw : 'a t -> 'a Raw.t 59 | 60 | (** In the presence of special characters, 61 | [Fn.compose string_t_of_string string_t_to_string] might not be the identify function; 62 | indeed, it may even raise an error. *) 63 | val string_t_of_sexp : Sexp.t -> string t 64 | 65 | val sexp_of_string_t : string t -> Sexp.t 66 | val string_t_of_string : string -> string t 67 | val string_t_to_string : string t -> string 68 | val lookup_ids : string t -> Util.Name_map.t -> Probe_id.t t 69 | val lookup_names : Probe_id.t t -> Reader.Header.t -> string t 70 | val id_t_to_string : Probe_id.t t -> Reader.Header.t -> string 71 | 72 | (** Retrieve the [Probe_type.t] associated with this interest, by drilling down to the 73 | relevant [Probe_id.t] of the group or single *) 74 | val spec : Probe_id.t t -> Reader.Header.t -> Probe_type.t 75 | 76 | val is_path : _ t -> bool 77 | 78 | (** If necessary, coerce the units of any values in this interest to those that the probe 79 | that the interest refers to is quoted in. *) 80 | val coerce_interval_units : Probe_id.t t -> Reader.Header.t -> Probe_id.t t 81 | 82 | val readme : string Lazy.t 83 | val arg_type : string t Command.Spec.Arg_type.t 84 | val list_arg : string t list Command.Param.t 85 | 86 | (** Generate a (hopefully sane) set of default interests for the items in this header *) 87 | val default_interests : Reader.Header.t -> Probe_id.t t list 88 | -------------------------------------------------------------------------------- /offline_tool/lib/path.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core_profiler 3 | 4 | type 'a point = 5 | | Direct_point of 'a 6 | | Point of 'a 7 | [@@deriving sexp, compare] 8 | 9 | type 'id t = 10 | { first : 'id point (* i.e., penultimate point first *) 11 | ; rest_rev : 'id point list 12 | ; last : 'id 13 | } 14 | [@@deriving sexp, compare] 15 | 16 | let first t = 17 | match t.first with 18 | | Direct_point i -> i 19 | | Point i -> i 20 | ;; 21 | 22 | let last t = t.last 23 | let direct_sep = "," 24 | let indirect_sep = ".." 25 | 26 | let next str pos = 27 | let next_pos pattern = String.substr_index str ~pos ~pattern in 28 | let sub pos2 = String.sub str ~pos ~len:(pos2 - pos) in 29 | match next_pos indirect_sep, next_pos direct_sep with 30 | | Some a, None -> Some (Point (sub a), a + String.length indirect_sep) 31 | | None, Some b -> Some (Direct_point (sub b), b + String.length direct_sep) 32 | | Some a, Some b -> 33 | if a < b 34 | then Some (Point (sub a), a + String.length indirect_sep) 35 | else Some (Direct_point (sub b), b + String.length direct_sep) 36 | | None, None -> None 37 | ;; 38 | 39 | let string_t_of_string str = 40 | let ( >>| ) = Option.( >>| ) in 41 | next str 0 42 | >>| fun (first, first_pos) -> 43 | let rec loop pos rest_rev = 44 | match next str pos with 45 | | Some (pt, new_pos) -> loop new_pos (pt :: rest_rev) 46 | | None -> 47 | let last = String.sub str ~pos ~len:(String.length str - pos) in 48 | { last; rest_rev; first } 49 | in 50 | loop first_pos [] 51 | ;; 52 | 53 | let string_t_to_string { first; rest_rev; last } = 54 | let point_to_string = function 55 | | Direct_point name -> [ name; direct_sep ] 56 | | Point name -> [ name; indirect_sep ] 57 | in 58 | (point_to_string first :: List.rev_map rest_rev ~f:point_to_string) @ [ [ last ] ] 59 | |> List.concat 60 | |> String.concat 61 | ;; 62 | 63 | module%test _ = struct 64 | let check s p = 65 | [%test_eq: string t option] (string_t_of_string s) (Some p); 66 | [%test_eq: string] (string_t_to_string p) s 67 | ;; 68 | 69 | let%test_unit "aaa..bbb" = 70 | check "aaa..bbb" { last = "bbb"; rest_rev = []; first = Point "aaa" } 71 | ;; 72 | 73 | let%test_unit "aaa..b..cc..ddd" = 74 | check 75 | "aaa..b..cc..ddd" 76 | { first = Point "aaa"; rest_rev = [ Point "cc"; Point "b" ]; last = "ddd" } 77 | ;; 78 | 79 | let%test_unit "aaa,bbb" = 80 | check "aaa,bbb" { first = Direct_point "aaa"; rest_rev = []; last = "bbb" } 81 | ;; 82 | 83 | let%test_unit "a..b,c..d,e" = 84 | check 85 | "a..b,c..d,e" 86 | { first = Point "a" 87 | ; rest_rev = [ Direct_point "d"; Point "c"; Direct_point "b" ] 88 | ; last = "e" 89 | } 90 | ;; 91 | end 92 | 93 | let examples = 94 | [ { first = Point "a"; last = "b"; rest_rev = [] } 95 | ; { first = Direct_point "b"; rest_rev = [ Direct_point "d"; Point "c" ]; last = "e" } 96 | ] 97 | ;; 98 | 99 | let readme = 100 | lazy 101 | (let examples = 102 | examples |> List.map ~f:(fun p -> " " ^ string_t_to_string p) |> String.concat 103 | in 104 | "To describe a path, specify a sequence of points. The separator determines whether \ 105 | whether you would like to consider paths that went from a to b directly (\"a.b\"), \ 106 | or paths that went from a to b, possibly (but not necessarily) via some other \ 107 | points (\"a..b\"). A point may not appear twice, except for when its second \ 108 | appearance is as the last point in the path.\n\n\ 109 | Some examples:" 110 | ^ examples) 111 | ;; 112 | 113 | let lookup_ids path { Util.Name_map.children = name_map; _ } = 114 | let lookup_point = function 115 | | Point p -> Point (Map.find_exn name_map p) 116 | | Direct_point p -> Direct_point (Map.find_exn name_map p) 117 | in 118 | { first = lookup_point path.first 119 | ; rest_rev = List.map ~f:lookup_point path.rest_rev 120 | ; last = Map.find_exn name_map path.last 121 | } 122 | ;; 123 | 124 | let lookup_names path id_map = 125 | let get_name = Fn.compose Reader.Header.Item.name (Reader.Header.find_exn id_map) in 126 | let lookup_point = function 127 | | Point p -> Point (get_name p) 128 | | Direct_point p -> Direct_point (get_name p) 129 | in 130 | { first = lookup_point path.first 131 | ; rest_rev = List.map ~f:lookup_point path.rest_rev 132 | ; last = get_name path.last 133 | } 134 | ;; 135 | 136 | let id_t_to_string path ?with_group id_map = 137 | (match with_group with 138 | | Some sep -> 139 | let group_name = Reader.Header.((get_parent_exn id_map path.last).Item.name) in 140 | group_name ^ sep 141 | | None -> "") 142 | ^ string_t_to_string (lookup_names path id_map) 143 | ;; 144 | 145 | module I = struct 146 | type id_path = Probe_id.t t [@@deriving sexp, compare] 147 | 148 | module T = struct 149 | type t = id_path [@@deriving sexp, compare] 150 | 151 | let hash_point = function 152 | | Direct_point id -> Probe_id.to_int_exn id 153 | | Point id -> Probe_id.to_int_exn id + ((1 lsl 17) - 1) 154 | ;; 155 | 156 | let hash { last; rest_rev; first } = 157 | let product = 158 | List.fold rest_rev ~init:1 ~f:(fun accum pt -> 159 | accum * hash_point pt mod ((1 lsl 31) - 1)) 160 | * hash_point first 161 | * Probe_id.to_int_exn last 162 | in 163 | Int.hash product 164 | ;; 165 | end 166 | 167 | include T 168 | include Comparable.Make (T) 169 | include Hashable.Make_and_derive_hash_fold_t (T) 170 | end 171 | -------------------------------------------------------------------------------- /offline_tool/lib/path.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | 4 | (** The first and last points are stored explicitly, not least to ensure that there are 5 | two of them. The list of points in the middle is stored in reverse order for 6 | convenience when checking the path. 7 | 8 | In a path, we might demand that we go from A -> B directly, or A -> B possibly via 9 | some other points. This is represented as [{ first = Direct_point a; last = b; ... }] 10 | and [{ first = Point a; last = b; ... }] respectively; that is, whether or not it must 11 | go directly is stored on the source, not the destination. 12 | 13 | A final example: [{ first = Point a; middle_rev = [Direct_point b]; last = c }] 14 | matches any sequence of points that starts at a, goes (possibly via some other 15 | distinct points) to b, and then directly from b to c. 16 | 17 | This and the [Event_generator.t] do not have the full power of regular expressions 18 | Notably, the same point may not appear in a path twice, except for when its second 19 | appearance is the last point in the path. *) 20 | 21 | type 'a point = 22 | | Direct_point of 'a 23 | | Point of 'a 24 | [@@deriving sexp, compare] 25 | 26 | type 'a t = 27 | { first : 'a point (* i.e., penultimate point first *) 28 | ; rest_rev : 'a point list 29 | ; last : 'a 30 | } 31 | [@@deriving sexp, compare] 32 | 33 | module I : sig 34 | type id_path = Probe_id.t t [@@deriving sexp, compare] 35 | type t = id_path [@@deriving sexp, compare] 36 | 37 | include Comparable.S with type t := t 38 | include Hashable.S with type t := t 39 | end 40 | 41 | val string_t_of_string : string -> string t option 42 | val string_t_to_string : string t -> string 43 | val examples : string t list 44 | val readme : string Lazy.t 45 | val lookup_ids : string t -> Util.Name_map.group -> Probe_id.t t 46 | val lookup_names : Probe_id.t t -> Reader.Header.t -> string t 47 | val id_t_to_string : Probe_id.t t -> ?with_group:string -> Reader.Header.t -> string 48 | 49 | (** Get [t.first], discarding whether the first point is [Direct_point] or a [Point] *) 50 | val first : 'a t -> 'a 51 | 52 | val last : 'a t -> 'a 53 | -------------------------------------------------------------------------------- /offline_tool/lib/reader.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler 4 | open Core_profiler_disabled 5 | module Unix = Core_unix 6 | module Time_ns = Time_ns_unix 7 | 8 | module Header = struct 9 | module Item = struct 10 | type single = 11 | { name : string 12 | ; spec : Probe_type.t 13 | } 14 | 15 | type group = 16 | { name : string 17 | ; points_spec : Probe_type.t 18 | ; children : Probe_id.t list 19 | } 20 | 21 | type group_point = 22 | { name : string 23 | ; parent : Probe_id.t 24 | ; sources : Probe_id.t list 25 | } 26 | 27 | type t = 28 | | Single of single 29 | | Group of group 30 | | Group_point of group_point 31 | 32 | let name = function 33 | | Single m -> m.name 34 | | Group p -> p.name 35 | | Group_point pp -> pp.name 36 | ;; 37 | end 38 | 39 | type t = (Item.t, read) Id_table.t 40 | 41 | let find_exn = Id_table.find_exn 42 | 43 | let find_single_exn t id = 44 | match find_exn t id with 45 | | Item.Single m -> m 46 | | _ -> failwithf !"Id %{Probe_id} does not refer to a single" id () 47 | ;; 48 | 49 | let find_group_exn t id = 50 | match find_exn t id with 51 | | Item.Group p -> p 52 | | _ -> failwithf !"Id %{Probe_id} does not refer to a Group" id () 53 | ;; 54 | 55 | let find_group_point_exn t id = 56 | match find_exn t id with 57 | | Item.Group_point pp -> pp 58 | | _ -> failwithf !"Id %{Probe_id} does not refer to a Group_point" id () 59 | ;; 60 | 61 | let get_parent_id_exn t id = 62 | match find_exn t id with 63 | | Item.Group_point pp -> pp.parent 64 | | _ -> failwithf !"Id %{Probe_id} does not refer to a Group_point" id () 65 | ;; 66 | 67 | let get_parent_exn t id = find_group_exn t (get_parent_id_exn t id) 68 | 69 | let get_name_exn t ?with_group id = 70 | match find_exn t id with 71 | | Item.Single { Item.name; _ } -> name 72 | | Item.Group { Item.name; _ } -> name 73 | | Item.Group_point { Item.name; parent; _ } -> 74 | (match with_group with 75 | | Some sep -> 76 | let { Item.name = group_name; points_spec = _; _ } = find_group_exn t parent in 77 | group_name ^ sep ^ name 78 | | None -> name) 79 | ;; 80 | 81 | let get_spec_exn t id = 82 | match find_exn t id with 83 | | Item.Single { spec; _ } -> spec 84 | | Item.Group { points_spec; _ } -> points_spec 85 | | Group_point { parent; _ } -> 86 | let { Item.points_spec; _ } = find_group_exn t parent in 87 | points_spec 88 | ;; 89 | 90 | let get_units_exn t id = 91 | match get_spec_exn t id with 92 | | Probe_type.Probe units -> units 93 | | Probe_type.Timer -> 94 | failwithf !"Id %{Probe_id} does not refer to something with units" id () 95 | ;; 96 | 97 | let create_table 98 | t 99 | ?(singles = true) 100 | ?(groups = true) 101 | ?(group_points = true) 102 | ?(timers = true) 103 | ?(probes = true) 104 | empty 105 | = 106 | Id_table.filter_map t ~f:(fun id header_item -> 107 | let spec_ok = 108 | match get_spec_exn t id with 109 | | Probe_type.Timer -> timers 110 | | Probe_type.Probe _ -> probes 111 | in 112 | let item_type_ok = 113 | match header_item with 114 | | Item.Single _ -> singles 115 | | Item.Group _ -> groups 116 | | Item.Group_point _ -> group_points 117 | in 118 | if spec_ok && item_type_ok then Some empty else None) 119 | ;; 120 | end 121 | 122 | let consume_header buffer = 123 | let module HP = Header_protocol in 124 | let module HP_MsgT = Header_protocol.Message_type_and_errors in 125 | let add_exn map id data = 126 | match Map.find map id with 127 | | Some existing -> 128 | failwithf 129 | !"Duplicate Id %{Probe_id} (%s, %s)" 130 | id 131 | (Header.Item.name existing) 132 | (Header.Item.name data) 133 | () 134 | | None -> Map.set map ~key:id ~data 135 | in 136 | let add_point_to_group map ~group_id ~point_id = 137 | match Map.find map group_id with 138 | | Some (Header.Item.Group p) -> 139 | let p = { p with children = point_id :: p.children } in 140 | Map.set map ~key:group_id ~data:(Header.Item.Group p) 141 | | Some (Header.Item.Single _ | Group_point _) | None -> 142 | failwith "Tried to add a point to something that isn't a group" 143 | in 144 | let check_sources_parent map ~point_id ~group_id sources = 145 | List.iter sources ~f:(fun source_id -> 146 | match Map.find map source_id with 147 | | Some (Header.Item.Group_point pp) -> 148 | if pp.parent <> group_id 149 | then 150 | failwithf 151 | !"Point %{Probe_id} of group %{Probe_id} references source point %{Probe_id} \ 152 | not belonging to the same group" 153 | point_id 154 | group_id 155 | source_id 156 | () 157 | | Some (Header.Item.Single _ | Header.Item.Group _) | None -> 158 | failwithf 159 | !"Point %{Probe_id} of group %{Probe_id} references source point %{Probe_id} \ 160 | that is not a group point" 161 | point_id 162 | group_id 163 | source_id 164 | ()) 165 | in 166 | let get_message_buffer buffer = 167 | let b = Iobuf.sub_shared buffer in 168 | HP.skip_message buffer; 169 | b 170 | in 171 | let rec scan epoch map = 172 | let this_message_buffer = get_message_buffer buffer in 173 | let (HP_MsgT.T packed_type) = HP.get_message_type this_message_buffer in 174 | let message = HP.of_iobuf this_message_buffer ~trusted:packed_type in 175 | match packed_type with 176 | | HP_MsgT.New_single -> 177 | HP.New_single.( 178 | let spec = get_spec message in 179 | let map = 180 | add_exn 181 | map 182 | (get_id message) 183 | (Header.Item.Single { name = get_name message; spec }) 184 | in 185 | scan epoch map) 186 | | HP_MsgT.New_group -> 187 | HP.New_group.( 188 | let points_spec = get_spec message in 189 | let group_spec = 190 | { name = get_name message; Header.Item.points_spec; children = [] } 191 | in 192 | let map = add_exn map (get_id message) (Header.Item.Group group_spec) in 193 | scan epoch map) 194 | | HP_MsgT.New_group_point -> 195 | HP.New_group_point.( 196 | let sources = 197 | let count = get_sources_count message in 198 | List.init ~f:(fun i -> get_sources_source_id message ~count ~index:i) count 199 | in 200 | let point_id = get_id message in 201 | let group_id = get_group_id message in 202 | check_sources_parent map ~point_id ~group_id sources; 203 | let metadata = 204 | Header.Item.Group_point { name = get_name message; parent = group_id; sources } 205 | in 206 | let map = add_exn map point_id metadata in 207 | let map = add_point_to_group map ~group_id ~point_id in 208 | scan epoch map) 209 | | HP_MsgT.Epoch -> 210 | HP.Epoch.( 211 | (match epoch with 212 | | Some epoch -> 213 | failwithf 214 | !"Header contained two epochs: %{Profiler_epoch}, %{Profiler_epoch}" 215 | epoch 216 | (get_epoch message) 217 | () 218 | | None -> scan (Some (get_epoch message)) map)) 219 | | HP_MsgT.End_of_header -> epoch, map 220 | | HP_MsgT.Need_more_data -> failwith "Invalid header (truncated)" 221 | | HP_MsgT.Invalid_message_type_or_subtype -> 222 | failwith "Invalid header (bad message type)" 223 | | HP_MsgT.Message_length_too_short -> 224 | failwith "Invalid header (message length too short)" 225 | in 226 | let epoch, map = scan None Probe_id.Map.empty in 227 | let epoch = Option.value_exn ~message:"Header did not contain an epoch" epoch in 228 | let table = Id_table.init_from_map map ~f:(fun _id item -> item) in 229 | epoch, table 230 | ;; 231 | 232 | let%test_unit "read_header" = 233 | let module Buffer = Protocol.Buffer in 234 | let module Writer = Protocol.Writer in 235 | let module HI = Header.Item in 236 | let to_id = Probe_id.of_int_exn in 237 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 238 | Writer.Unsafe_internals.write_epoch (); 239 | Writer.write_new_single (to_id 3) "timer3" Probe_type.Timer; 240 | Writer.write_new_group (to_id 2) "group2" (Probe_type.Probe Profiler_units.Seconds); 241 | Writer.write_new_group (to_id 1) "group1" Probe_type.Timer; 242 | Writer.write_new_group_point ~id:(to_id 4) ~group_id:(to_id 1) "group1point4" [||]; 243 | Writer.write_new_group_point ~id:(to_id 5) ~group_id:(to_id 2) "group2point5" [||]; 244 | Writer.write_new_group_point 245 | ~id:(to_id 6) 246 | ~group_id:(to_id 2) 247 | "group2point6" 248 | [| to_id 5 |]; 249 | Writer.write_new_single (to_id 0) "probe0" (Probe_type.Probe Profiler_units.Words); 250 | Writer.write_new_single (to_id 8) "timer8" Probe_type.Timer; 251 | Writer.write_new_group_point 252 | ~id:(to_id 7) 253 | ~group_id:(to_id 2) 254 | "group2point7" 255 | [| to_id 5; to_id 6 |]; 256 | Writer.Unsafe_internals.write_end_of_header (); 257 | let epoch2, id_map = consume_header (Buffer.get_header_chunk ()) in 258 | let id_map_alist = Id_table.to_alist id_map in 259 | [%test_pred: Profiler_epoch.t] (fun a -> a = Writer.epoch) epoch2; 260 | [%test_eq: int] (List.length id_map_alist) 9; 261 | let expect = 262 | [ ( to_id 0 263 | , HI.Single { name = "probe0"; spec = Probe_type.Probe Profiler_units.Words } ) 264 | ; ( to_id 1 265 | , HI.Group 266 | { name = "group1"; points_spec = Probe_type.Timer; children = [ to_id 4 ] } ) 267 | ; ( to_id 2 268 | , HI.Group 269 | { name = "group2" 270 | ; HI.points_spec = Probe_type.Probe Profiler_units.Seconds 271 | ; children = [ to_id 7; to_id 6; to_id 5 ] 272 | } ) 273 | ; to_id 3, HI.Single { name = "timer3"; spec = Probe_type.Timer } 274 | ; to_id 4, HI.Group_point { name = "group1point4"; parent = to_id 1; sources = [] } 275 | ; to_id 5, HI.Group_point { name = "group2point5"; parent = to_id 2; sources = [] } 276 | ; ( to_id 6 277 | , HI.Group_point 278 | { name = "group2point6"; parent = to_id 2; sources = [ to_id 5 ] } ) 279 | ; ( to_id 7 280 | , HI.Group_point 281 | { name = "group2point7"; parent = to_id 2; sources = [ to_id 5; to_id 6 ] } ) 282 | ; to_id 8, HI.Single { name = "timer8"; spec = Probe_type.Timer } 283 | ] 284 | in 285 | assert (id_map_alist = expect)) 286 | ;; 287 | 288 | (* There's scope for making a zero-copy version of this *) 289 | module Short_message = struct 290 | module Header = Protocol.Short_header 291 | 292 | type t = 293 | | Timer of Probe_id.t * Time_ns.t 294 | | Probe of Probe_id.t * Time_ns.t * int 295 | | Group_reset of Probe_id.t * Time_ns.t 296 | [@@deriving sexp, compare] 297 | 298 | let id = function 299 | | Timer (id, _) -> id 300 | | Probe (id, _, _) -> id 301 | | Group_reset (id, _) -> id 302 | ;; 303 | 304 | let time = function 305 | | Timer (_, time) -> time 306 | | Probe (_, time, _) -> time 307 | | Group_reset (_, time) -> time 308 | ;; 309 | end 310 | 311 | let consume_short_message buffer epoch header = 312 | let module SM = Short_message in 313 | let module HI = Header.Item in 314 | let remaining = Iobuf.length buffer in 315 | if remaining = 0 316 | then failwith "Invalid short message: empty buffer" 317 | else if remaining < 8 318 | then failwith "Invalid short message: truncated" 319 | else ( 320 | (* fields common to read_timer, probe and group_reset *) 321 | let sm_header = Iobuf.Peek.int64_le_exn buffer ~pos:0 in 322 | let sm_id = SM.Header.unpack_id sm_header in 323 | let sm_time = SM.Header.unpack_time epoch sm_header in 324 | let read_by_spec = function 325 | | Probe_type.Timer -> 326 | Iobuf.unsafe_advance buffer 8; 327 | SM.Timer (sm_id, sm_time) 328 | | Probe_type.Probe _ -> 329 | if remaining < 16 330 | then failwith "Invalid short message: truncated" 331 | else ( 332 | let value = Iobuf.Peek.int64_le_exn buffer ~pos:8 in 333 | Iobuf.unsafe_advance buffer 16; 334 | SM.Probe (sm_id, sm_time, value)) 335 | in 336 | let read_group_reset () = 337 | Iobuf.unsafe_advance buffer 8; 338 | SM.Group_reset (sm_id, sm_time) 339 | in 340 | match Header.find_exn header sm_id with 341 | | HI.Group _ -> read_group_reset () 342 | | HI.Single { spec; _ } -> read_by_spec spec 343 | | HI.Group_point { parent; _ } -> 344 | let { HI.points_spec; _ } = Header.find_group_exn header parent in 345 | read_by_spec points_spec) 346 | ;; 347 | 348 | let%test_unit "consume_short_message" = 349 | let module Buffer = Protocol.Buffer in 350 | let module Writer = Protocol.Writer in 351 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 352 | let to_id = Probe_id.of_int_exn in 353 | let time_past_epoch x = Profiler_epoch.add Writer.epoch (Time_ns.Span.of_int_ns x) in 354 | Writer.Unsafe_internals.write_epoch (); 355 | Writer.write_new_single (to_id 1) "timer" Probe_type.Timer; 356 | Writer.write_new_single (to_id 2) "probe" (Probe_type.Probe Profiler_units.Seconds); 357 | Writer.write_new_group (to_id 3) "timer-group" Probe_type.Timer; 358 | Writer.write_new_group_point ~group_id:(to_id 3) ~id:(to_id 4) "timer-group-point" [||]; 359 | Writer.write_new_group (to_id 5) "probe-group" (Probe_type.Probe Profiler_units.Int); 360 | Writer.write_new_group_point ~group_id:(to_id 5) ~id:(to_id 6) "probe-group-point" [||]; 361 | Writer.Unsafe_internals.write_end_of_header (); 362 | Writer.write_timer_at (to_id 1) (time_past_epoch 100); 363 | Writer.write_probe_at (to_id 2) (time_past_epoch 200) 22; 364 | Writer.write_group_reset (to_id 3) (time_past_epoch 300); 365 | Writer.write_timer_at (to_id 4) (time_past_epoch 400); 366 | Writer.write_probe_at (to_id 6) (time_past_epoch 600) 66; 367 | let epoch, header = consume_header (Buffer.get_header_chunk ()) in 368 | let short_messages_chunk = 369 | match Buffer.get_chunks () with 370 | | [ x ] -> Iobuf.sub_shared x 371 | | _ -> assert false 372 | in 373 | let read () = consume_short_message short_messages_chunk epoch header in 374 | [%test_eq: Short_message.t] (read ()) (Timer (to_id 1, time_past_epoch 100)); 375 | [%test_eq: Short_message.t] (read ()) (Probe (to_id 2, time_past_epoch 200, 22)); 376 | [%test_eq: Short_message.t] (read ()) (Group_reset (to_id 3, time_past_epoch 300)); 377 | [%test_eq: Short_message.t] (read ()) (Timer (to_id 4, time_past_epoch 400)); 378 | [%test_eq: Short_message.t] (read ()) (Probe (to_id 6, time_past_epoch 600, 66))) 379 | ;; 380 | 381 | let fold_short_messages buffer epoch header ~init ~f = 382 | Iobuf.protect_window_bounds_and_buffer (Iobuf.no_seek buffer) ~f:(fun buffer -> 383 | let rec loop accum = 384 | if Iobuf.is_empty buffer 385 | then accum 386 | else ( 387 | let message = consume_short_message buffer epoch header in 388 | loop (f accum message)) 389 | in 390 | loop init) 391 | ;; 392 | 393 | let iter_short_messages buffer epoch header ~f = 394 | Iobuf.protect_window_bounds_and_buffer (Iobuf.no_seek buffer) ~f:(fun buffer -> 395 | while not (Iobuf.is_empty buffer) do 396 | f (consume_short_message buffer epoch header) 397 | done) 398 | ;; 399 | 400 | let iteri_short_messages buffer epoch header ~f = 401 | Iobuf.protect_window_bounds_and_buffer (Iobuf.no_seek buffer) ~f:(fun buffer -> 402 | let i = ref 0 in 403 | while not (Iobuf.is_empty buffer) do 404 | f !i (consume_short_message buffer epoch header); 405 | incr i 406 | done) 407 | ;; 408 | 409 | let map_file filename = 410 | let file_length fd = 411 | let current_pos = Unix.lseek fd ~mode:Unix.SEEK_CUR Int64.zero in 412 | let length = Unix.lseek fd ~mode:Unix.SEEK_END Int64.zero in 413 | ignore (Unix.lseek fd ~mode:Unix.SEEK_SET current_pos : int64); 414 | length |> Int64.to_int |> Option.value_exn 415 | in 416 | Unix.with_file filename ~mode:[ Unix.O_RDONLY ] ~f:(fun fd -> 417 | let map = Bigstring_unix.map_file ~shared:false fd (file_length fd) in 418 | Iobuf.of_bigstring map) 419 | ;; 420 | -------------------------------------------------------------------------------- /offline_tool/lib/reader.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler.Std_offline 3 | open Core_profiler 4 | 5 | module Header : sig 6 | (** A [Header.Item.t] is anything that is uniquely identified by a [Probe_id.t]. *) 7 | module Item : sig 8 | type single = 9 | { name : string 10 | ; spec : Probe_type.t 11 | } 12 | 13 | type group = 14 | { name : string 15 | ; points_spec : Probe_type.t 16 | ; children : Probe_id.t list 17 | } 18 | 19 | type group_point = 20 | { name : string 21 | ; parent : Probe_id.t 22 | ; sources : Probe_id.t list 23 | } 24 | 25 | type t = 26 | | Single of single 27 | | Group of group 28 | | Group_point of group_point 29 | 30 | val name : t -> string 31 | end 32 | 33 | type t = (Item.t, read) Id_table.t 34 | 35 | val find_exn : t -> Probe_id.t -> Item.t 36 | val find_single_exn : t -> Probe_id.t -> Item.single 37 | val find_group_exn : t -> Probe_id.t -> Item.group 38 | val find_group_point_exn : t -> Probe_id.t -> Item.group_point 39 | 40 | (** Get a group point's parent *) 41 | val get_parent_id_exn : t -> Probe_id.t -> Probe_id.t 42 | 43 | val get_parent_exn : t -> Probe_id.t -> Item.group 44 | 45 | (** If [add_group] is specified and the id refers to a group point, 46 | [group_name ^ add_group ^ group_point_name] is returned *) 47 | val get_name_exn : t -> ?with_group:string -> Probe_id.t -> string 48 | 49 | val get_spec_exn : t -> Probe_id.t -> Probe_type.t 50 | val get_units_exn : t -> Probe_id.t -> Profiler_units.t 51 | 52 | (** Conditions are ANDed, and default to true *) 53 | val create_table 54 | : t 55 | -> ?singles:bool 56 | -> ?groups:bool 57 | -> ?group_points:bool 58 | -> ?timers:bool 59 | -> ?probes:bool 60 | -> 'a 61 | -> ('a, _) Id_table.t 62 | end 63 | 64 | val consume_header : ([> read ], Iobuf.seek) Iobuf.t -> Profiler_epoch.t * Header.t 65 | 66 | module Short_message : sig 67 | module Header : module type of Core_profiler.Protocol.Short_header 68 | 69 | type t = 70 | | Timer of Probe_id.t * Time_ns.t 71 | | Probe of Probe_id.t * Time_ns.t * int 72 | | Group_reset of Probe_id.t * Time_ns.t 73 | 74 | val id : t -> Probe_id.t 75 | val time : t -> Time_ns.t 76 | end 77 | 78 | val consume_short_message 79 | : ([> read ], Iobuf.seek) Iobuf.t 80 | -> Profiler_epoch.t 81 | -> Header.t 82 | -> Short_message.t 83 | 84 | val fold_short_messages 85 | : ([> read ], _) Iobuf.t 86 | -> Profiler_epoch.t 87 | -> Header.t 88 | -> init:'accum 89 | -> f:('accum -> Short_message.t -> 'accum) 90 | -> 'accum 91 | 92 | val iter_short_messages 93 | : ([> read ], _) Iobuf.t 94 | -> Profiler_epoch.t 95 | -> Header.t 96 | -> f:(Short_message.t -> unit) 97 | -> unit 98 | 99 | val iteri_short_messages 100 | : ([> read ], _) Iobuf.t 101 | -> Profiler_epoch.t 102 | -> Header.t 103 | -> f:(int -> Short_message.t -> unit) 104 | -> unit 105 | 106 | val map_file : string -> (read, _) Iobuf.t 107 | -------------------------------------------------------------------------------- /offline_tool/lib/reservoir_sampling.ml: -------------------------------------------------------------------------------- 1 | (** This is a copy of resevoir sampling from [Jane.Order_stats_reservoir_sampling.Int] 2 | with several non-essential functions removed. 3 | 4 | We can kill this someday when the [Jane] is publicly released. *) 5 | open Core 6 | 7 | open Poly 8 | 9 | module Make (E : sig 10 | type t [@@deriving sexp, bin_io, compare] 11 | 12 | val make_array : len:int -> t array 13 | val set : t array -> int -> t -> unit 14 | end) = 15 | struct 16 | type element = E.t [@@deriving sexp, bin_io] 17 | 18 | type t = 19 | { mutable total_samples_seen : int (* total number of samples seen by [add] *) 20 | ; mutable samples_count : int (* number of samples retained in [samples] *) 21 | ; mutable samples : E.t array 22 | (* remembered samples (between the indices 0 and 23 | samples_count-1 inclusive; the other values are 24 | meaningless) *) 25 | ; mutable samples_are_sorted : bool (* flag to avoid resorting *) 26 | } 27 | [@@deriving sexp, bin_io] 28 | 29 | let create ?(num_samples_to_keep = 10_000) () = 30 | if num_samples_to_keep < 1 31 | then invalid_arg "num_samples_to_keep must be positive" 32 | else if num_samples_to_keep > 1_000_000_000 33 | then invalid_arg "num_samples_to_keep shouldn't be over a billion" 34 | else 35 | { total_samples_seen = 0 36 | ; samples_count = 0 37 | ; samples = E.make_array ~len:num_samples_to_keep 38 | ; samples_are_sorted = true 39 | } 40 | ;; 41 | 42 | let add t sample = 43 | t.total_samples_seen <- t.total_samples_seen + 1; 44 | let index_to_replace = Random.int t.total_samples_seen in 45 | let len = Array.length t.samples in 46 | if index_to_replace < len 47 | then ( 48 | if t.samples_count < len 49 | then ( 50 | (* t.samples has unoccupied slots *) 51 | E.set t.samples t.samples_count sample; 52 | t.samples_count <- t.samples_count + 1) 53 | else E.set t.samples index_to_replace sample; 54 | t.samples_are_sorted <- false) 55 | ;; 56 | 57 | let sort t = 58 | if not t.samples_are_sorted 59 | then ( 60 | Array.sort t.samples ~compare:E.compare ~pos:0 ~len:t.samples_count; 61 | t.samples_are_sorted <- true) 62 | ;; 63 | 64 | let percentile t p = 65 | if p < 0. || p > 1. 66 | then Or_error.error_string "Order_stats.percentile: must be between 0 and 1" 67 | else if t.samples_count = 0 68 | then Or_error.error_string "Order_stats.percentile: no samples yet" 69 | else ( 70 | sort t; 71 | let index = Float.iround_towards_zero_exn (p *. Float.of_int t.samples_count) in 72 | let index = 73 | if index >= t.samples_count (* in case p=1 or rounding error *) 74 | then t.samples_count - 1 75 | else index 76 | in 77 | Result.Ok t.samples.(index)) 78 | ;; 79 | 80 | let percentile_exn t p = Or_error.ok_exn (percentile t p) 81 | 82 | let distribution t = 83 | sort t; 84 | (* looping in reverse to construct the list in sorted order *) 85 | let rec loop i ls = if i = -1 then ls else loop (i - 1) (t.samples.(i) :: ls) in 86 | loop (t.samples_count - 1) [] 87 | ;; 88 | end 89 | 90 | include Make (struct 91 | include Int 92 | 93 | let make_array ~len = Array.create ~len 0 94 | let set (t : int array) i v = t.(i) <- v 95 | end) 96 | -------------------------------------------------------------------------------- /offline_tool/lib/reservoir_sampling.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t [@@deriving sexp] 4 | 5 | val create : ?num_samples_to_keep:int -> unit -> t 6 | val add : t -> int -> unit 7 | val percentile : t -> float -> int Or_error.t 8 | val percentile_exn : t -> float -> int 9 | val distribution : t -> int list 10 | -------------------------------------------------------------------------------- /offline_tool/lib/std.ml: -------------------------------------------------------------------------------- 1 | include Util 2 | module Reader = Reader 3 | module Path = Path 4 | module Interest = Interest 5 | module Filter = Filter 6 | module Id_table = Id_table 7 | module Event_generator = Event_generator 8 | module Reservoir_sampling = Reservoir_sampling 9 | -------------------------------------------------------------------------------- /offline_tool/lib/util.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler 4 | open Core_profiler_disabled 5 | module Time = Time_float_unix 6 | 7 | module Name_map = struct 8 | type group = 9 | { id : Probe_id.t 10 | ; children : Probe_id.t String.Map.t 11 | } 12 | 13 | type t = 14 | { singles : Probe_id.t String.Map.t 15 | ; groups : group String.Map.t 16 | } 17 | 18 | let of_id_map (id_map : Reader.Header.t) = 19 | let warn_if_duplicate what map key data = 20 | match Map.find map key with 21 | | Some _ -> printf !"Duplicate %s name %s; keeping %{Probe_id}" what key data 22 | | None -> () 23 | in 24 | let collect_children group_id group_name = 25 | let warning_what = sprintf "group %s point" group_name in 26 | Id_table.fold id_map ~init:String.Map.empty ~f:(fun t id item -> 27 | match item with 28 | | Single _ | Group _ -> t 29 | | Group_point { name; parent; _ } -> 30 | if parent = group_id 31 | then ( 32 | warn_if_duplicate warning_what t name id; 33 | Map.set t ~key:name ~data:id) 34 | else t) 35 | in 36 | Id_table.fold 37 | id_map 38 | ~init:{ singles = String.Map.empty; groups = String.Map.empty } 39 | ~f:(fun t id item -> 40 | match item with 41 | | Single { name; _ } -> 42 | warn_if_duplicate "single" t.singles name id; 43 | { t with singles = Map.set t.singles ~key:name ~data:id } 44 | | Group { name; _ } -> 45 | warn_if_duplicate "group" t.groups name id; 46 | let data = { id; children = collect_children id name } in 47 | { t with groups = Map.set t.groups ~key:name ~data } 48 | | Group_point _ -> t) 49 | ;; 50 | end 51 | 52 | let int_units_of_string str = 53 | let str = String.lowercase str in 54 | let len = String.length str in 55 | let getend n = if len >= n then str.[len - n] else ' ' in 56 | let multiplier, slice, units = 57 | match getend 2, getend 1 with 58 | | 'n', 's' -> 1., 2, Profiler_units.Nanoseconds 59 | | 'u', 's' -> 1e3, 2, Profiler_units.Nanoseconds 60 | | 'm', 's' -> 1e6, 2, Profiler_units.Nanoseconds 61 | | _, 's' -> 1e9, 1, Profiler_units.Nanoseconds 62 | | 'k', 'w' -> 1e3, 2, Profiler_units.Words 63 | | 'm', 'w' -> 1e6, 2, Profiler_units.Words 64 | | 'g', 'w' -> 1e9, 2, Profiler_units.Words 65 | | _, 'w' -> 1., 1, Profiler_units.Words 66 | | _, 'k' -> 1e3, 1, Profiler_units.Int 67 | | _, 'm' -> 1e6, 1, Profiler_units.Int 68 | | _, 'g' -> 1e9, 1, Profiler_units.Int 69 | | _ -> 1., 0, Profiler_units.Int 70 | in 71 | let number = String.slice str 0 (-slice) |> Float.of_string in 72 | Float.iround_nearest_exn (number *. multiplier), units 73 | ;; 74 | 75 | let%test_unit "int_units_of_string" = 76 | List.iter 77 | [ "5s", 5_000_000_000L, Profiler_units.Nanoseconds 78 | ; "-12ms", -12_000_000L, Profiler_units.Nanoseconds 79 | ; "1.23us", 1_230L, Profiler_units.Nanoseconds 80 | ; "50_500ns", 50_500L, Profiler_units.Nanoseconds 81 | ; "5kw", 5_000L, Profiler_units.Words 82 | ; "100Mw", 100_000_000L, Profiler_units.Words 83 | ; "-1.5Gw", -1_500_000_000L, Profiler_units.Words 84 | ; "-100_000w", -100_000L, Profiler_units.Words 85 | ; "100k", 100_000L, Profiler_units.Int 86 | ; "1M", 1_000_000L, Profiler_units.Int 87 | ; "-9G", -9_000_000_000L, Profiler_units.Int 88 | ; "-2.56", -3L, Profiler_units.Int 89 | ; "12", 12L, Profiler_units.Int 90 | ] 91 | ~f:(fun (str, num, units) -> 92 | let num = Int64.to_int_exn num in 93 | [%test_eq: int * Profiler_units.t] (int_units_of_string str) (num, units)) 94 | ;; 95 | 96 | let coerce_units value ~current ~desired = 97 | match current, desired with 98 | | _, Profiler_units.Int -> value 99 | | Profiler_units.Int, _ -> value 100 | | x, y when x = y -> value 101 | | Profiler_units.Seconds, Profiler_units.Nanoseconds -> value * 1_000_000_000 102 | | Profiler_units.Nanoseconds, Profiler_units.Seconds -> value / 1_000_000_000 103 | | _ -> 104 | failwithf 105 | !"Don't know how to convert %{Profiler_units} to %{Profiler_units}" 106 | current 107 | desired 108 | () 109 | ;; 110 | 111 | let choose_units a b = 112 | match a, b with 113 | | Profiler_units.Seconds, Profiler_units.Nanoseconds -> Profiler_units.Nanoseconds 114 | | Profiler_units.Nanoseconds, Profiler_units.Seconds -> Profiler_units.Nanoseconds 115 | | x, y when x = y -> x 116 | | x, Profiler_units.Int -> x 117 | | Profiler_units.Int, x -> x 118 | | _ -> Profiler_units.Int 119 | ;; 120 | 121 | let span_to_string sp = 122 | Profiler_units.format_int Profiler_units.Nanoseconds (Time_ns.Span.to_int_ns sp) 123 | ;; 124 | 125 | let time_ns_to_ofday_string t = 126 | let t = Time_ns.to_int_ns_since_epoch t in 127 | let s = t / 1_000_000_000 in 128 | let ns = t mod 1_000_000_000 in 129 | let hms = 130 | Time.of_span_since_epoch (Time.Span.of_sec (float s)) 131 | |> Time.to_ofday ~zone:(force Time.Zone.local) 132 | |> Time.Ofday.to_sec_string 133 | in 134 | sprintf !"%s.%09i" hms ns 135 | ;; 136 | 137 | let choices_argtype name choices = 138 | (* Not only is this a fast path, but if one choice is a prefix of another 139 | (e.g., "time" and "time-delta") we don't want to suggest "time-delta" in 140 | response to "time". *) 141 | let fast_path = String.Map.of_alist_exn choices in 142 | let search prefix = 143 | match Map.find fast_path prefix with 144 | | Some d -> [ prefix, d ] 145 | | None -> List.filter choices ~f:(fun (key, _) -> String.is_prefix key ~prefix) 146 | in 147 | Command.Spec.Arg_type.create 148 | ~complete:(fun _ ~part -> List.map ~f:fst (search part)) 149 | (fun s -> 150 | match search s with 151 | | [ (_key, data) ] -> data 152 | | [] -> failwithf "Unrecognised %s %s" name s () 153 | | (x, _) :: (y, _) :: others -> 154 | let more = 155 | match others with 156 | | [] -> "" 157 | | _ -> ", ..." 158 | in 159 | failwithf "Ambiguous %s %s: could be %s, %s%s" name s x y more ()) 160 | ;; 161 | -------------------------------------------------------------------------------- /offline_tool/lib/util.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler 3 | open Core_profiler_disabled 4 | 5 | (** A [Name_map.t] maps string names to [Core_profiler_stubs.Common.Probe_id.t]s *) 6 | module Name_map : sig 7 | type group = 8 | { id : Probe_id.t 9 | ; children : Probe_id.t String.Map.t 10 | } 11 | 12 | type t = 13 | { singles : Probe_id.t String.Map.t 14 | ; groups : group String.Map.t 15 | } 16 | 17 | val of_id_map : Reader.Header.t -> t 18 | end 19 | 20 | (* See Core_profiler_stubs.Common for the counterpart int_units_to_string *) 21 | val int_units_of_string : string -> int * Profiler_units.t 22 | val span_to_string : Time_ns.Span.t -> string 23 | val coerce_units : int -> current:Profiler_units.t -> desired:Profiler_units.t -> int 24 | 25 | (** Choose the best 'common' units to use to coerce the two arguments to *) 26 | val choose_units : Profiler_units.t -> Profiler_units.t -> Profiler_units.t 27 | 28 | val time_ns_to_ofday_string : Time_ns.t -> string 29 | val choices_argtype : string -> (string * 'a) list -> 'a Command.Spec.Arg_type.t 30 | -------------------------------------------------------------------------------- /src/check_environment.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let debug = false 4 | 5 | (* This is set if we have examined the core_profiler env variable. *) 6 | let core_profiler_env_table_opt : string String.Table.t option ref = ref None 7 | 8 | let print_help_and_exit () = 9 | eprintf "%s\n%!" Core_profiler_disabled.Intf.core_profiler_env_help_string; 10 | exit 1 11 | ;; 12 | 13 | let set_env_table_from_string str = 14 | if debug then printf "profiler var = %s\n" str; 15 | let tbl = String.Table.create () in 16 | List.iter (String.split str ~on:',') ~f:(fun name_val -> 17 | if not (String.is_empty name_val) 18 | then ( 19 | match String.lsplit2 name_val ~on:'=' with 20 | | None -> print_help_and_exit () 21 | | Some (name, value) -> Hashtbl.set tbl ~key:name ~data:value)); 22 | core_profiler_env_table_opt := Some tbl; 23 | Some tbl 24 | ;; 25 | 26 | (** entirely suppress checking for the environment variable if we are in a inline test or 27 | inline benchmark *) 28 | let () = 29 | match Array.to_list (Sys.get_argv ()) with 30 | | _name :: "inline-test-runner" :: _rest | _name :: "-benchmarks-runner" :: _rest -> 31 | ignore (set_env_table_from_string "" : string String.Table.t option) 32 | | _cmd -> () 33 | ;; 34 | 35 | let get_env_table_opt () = 36 | match !core_profiler_env_table_opt with 37 | | Some tbl -> Some tbl 38 | | None -> 39 | (match Sys.getenv "CORE_PROFILER" with 40 | | None -> None 41 | | Some str -> set_env_table_from_string str) 42 | ;; 43 | 44 | let get_var str = 45 | match get_env_table_opt () with 46 | | None -> 47 | if debug then printf "no table\n%!"; 48 | None 49 | | Some tbl -> 50 | let res = Hashtbl.find tbl str in 51 | (match res with 52 | | Some v -> if debug then printf "var %s is %s\n%!" str v 53 | | None -> if debug then printf "var %s is not set\n%!" str); 54 | res 55 | ;; 56 | 57 | let check_safety_exn () = 58 | if Option.is_none (get_env_table_opt ()) then print_help_and_exit () 59 | ;; 60 | 61 | let don't_require_core_profiler_env () = 62 | if Option.is_none (get_env_table_opt ()) 63 | then ignore (set_env_table_from_string "" : string String.Table.t option) 64 | ;; 65 | -------------------------------------------------------------------------------- /src/check_environment.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | val get_var : string -> string option 4 | val check_safety_exn : unit -> unit 5 | val don't_require_core_profiler_env : unit -> unit 6 | -------------------------------------------------------------------------------- /src/common.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | 4 | type t = 5 | | Online_profiler 6 | | Offline_profiler 7 | | Any_profiler 8 | 9 | let now_no_calibrate () = 10 | Time_stamp_counter.now () 11 | |> Time_stamp_counter.to_time_ns ~calibrator:(force Time_stamp_counter.calibrator) 12 | ;; 13 | 14 | let%bench "now_no_calibrate" = now_no_calibrate () 15 | 16 | (* When we last ran the slow tasks *) 17 | let last_slow_tasks = ref (now_no_calibrate ()) 18 | 19 | (* NB: Time_stamp_counter calibrates at startup *) 20 | let slow_tasks : (t * (unit -> unit)) list ref = ref [] 21 | let slow_tasks_every_ns = 1_000_000_000 22 | let add_slow_task kind f = slow_tasks := (kind, f) :: !slow_tasks 23 | 24 | let () = 25 | add_slow_task Any_profiler (fun () -> 26 | Time_stamp_counter.Calibrator.calibrate (force Time_stamp_counter.calibrator)) 27 | ;; 28 | 29 | let maybe_do_slow_tasks' kind now reluctance = 30 | (* We don't want to pay for a [now] call to work out whether we should do slow tasks. 31 | If Time_stamp_counter gets so far out of sync with reality that the value below 32 | is not good enough to compare with values on the order of one second, then we have 33 | bigger problems, not least because Time_stamp_counter's EWMA isn't going to catch up 34 | quickly enough for the next measurement to be good. *) 35 | let diff = Time_ns.diff now !last_slow_tasks |> Time_ns.Span.to_int_ns |> abs in 36 | if diff > slow_tasks_every_ns * reluctance 37 | then ( 38 | List.iter !slow_tasks ~f:(fun (orig_kind, g) -> 39 | if orig_kind = kind || orig_kind = Any_profiler then g ()); 40 | last_slow_tasks := now) 41 | ;; 42 | 43 | let now kind ~reluctance () = 44 | let x = now_no_calibrate () in 45 | maybe_do_slow_tasks' kind x reluctance; 46 | (* It is OK to take the value we were given /before/ calibration as "now" because 47 | Time_stamp_counter provides monotonicity and smoothness: it won't jump. *) 48 | x 49 | ;; 50 | 51 | let maybe_do_slow_tasks kind ~reluctance = 52 | maybe_do_slow_tasks' kind (now_no_calibrate ()) reluctance 53 | ;; 54 | 55 | let%bench "now" = now Any_profiler ~reluctance:1 () 56 | let%bench "maybe_do_slow_tasks (r=4)" = maybe_do_slow_tasks Any_profiler ~reluctance:4 57 | -------------------------------------------------------------------------------- /src/common.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = 4 | | Online_profiler 5 | | Offline_profiler 6 | | Any_profiler 7 | 8 | (** now, possibly with calibration error. *) 9 | val now_no_calibrate : unit -> Time_ns.t 10 | 11 | (** [slow_tasks] is a list of functions that should be called rougly every second while 12 | the library is in use. The time-since-we-last-did-slow-tasks is checked on every call 13 | to [now] and [maybe_do_slow_tasks] below. [add_slow_task] adds one more slow task. *) 14 | val add_slow_task : t -> (unit -> unit) -> unit 15 | 16 | (** [reluctance] is higher if we don't want to do 'slow tasks' / don't want a potential 17 | 300ns spike. 18 | 19 | We _really_ don't want this in [Group.Point.at]s and [Delta_probe.start]s 20 | (reluctance:4) since the spike would be included in the calculation of a delta. We'd 21 | rather not on [Timer.record]s (r:3) since they are more liable to be in the middle of 22 | something performance sensitive. We're slightly more happy to calibrate after a 23 | [Group.reset] (r:2), but ideally want to calibrate on a call to [safe_to_delay] (r:1; 24 | lowest). 25 | 26 | Here [t] specifies the kind of slow tasks to run if the reluctance has been overcome. *) 27 | val now : t -> reluctance:int -> unit -> Time_ns.t 28 | 29 | val maybe_do_slow_tasks : t -> reluctance:int -> unit 30 | -------------------------------------------------------------------------------- /src/core_profiler.ml: -------------------------------------------------------------------------------- 1 | module Check_environment = Check_environment 2 | module Common = Common 3 | module Fstats = Fstats 4 | module Header_protocol = Header_protocol 5 | module Offline = Offline 6 | module Online = Online 7 | module Probe_id = Probe_id 8 | module Probe_type = Probe_type 9 | module Profiler_epoch = Profiler_epoch 10 | module Protocol = Protocol 11 | module Std_offline = Std_offline 12 | module Std_online = Std_online 13 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core_profiler) 3 | (public_name core_profiler) 4 | (libraries textutils.ascii_table core_unix.bigstring_unix core 5 | core_profiler_disabled core_unix core_kernel.iobuf core_unix.sys_unix 6 | core_unix.time_float_unix core_unix.time_ns_unix 7 | core_unix.time_stamp_counter) 8 | (preprocess 9 | (pps ppx_jane))) 10 | 11 | (documentation) 12 | -------------------------------------------------------------------------------- /src/fstats.ml: -------------------------------------------------------------------------------- 1 | (** This module is basically copied straight from [Jane.Rstats], however: 2 | - [decay] removed (to avoid Option.value branch in [update_in_place]) 3 | - [update_in_place] optimised so that it doesn't allocate (see below) 4 | 5 | This copy can be killed when the original is available publicly. *) 6 | 7 | open Core 8 | open Poly 9 | 10 | type t = 11 | { (* Note: we keep samples as a float instead of an int so that all floats in the record 12 | are kept unboxed. *) 13 | mutable samples : float (* sum of sample^0 *) 14 | ; mutable sum : float (* sum of sample^1 *) 15 | ; mutable sqsum : float (* sum of sample^2 *) 16 | ; (* The naive algorithm of (sqsum - sum^2) exhibits catastrophic cancellation, 17 | so we use an alternative algorithm that keeps a running total of the variance 18 | and gets much better numerical precision. 19 | 20 | See "Weighted incremental algorithm" and "Parallel algorithm" at 21 | http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance 22 | *) 23 | mutable varsum : float (* sum of running_variance *) 24 | ; mutable max : float (* largest sample *) 25 | ; mutable min : float (* smallest sample *) 26 | } 27 | 28 | let create () = 29 | { sum = 0. 30 | ; sqsum = 0. 31 | ; varsum = 0. 32 | ; samples = 0. 33 | ; max = Float.neg_infinity 34 | ; min = Float.infinity 35 | } 36 | ;; 37 | 38 | let samples t = Float.to_int t.samples 39 | let total t = t.sum 40 | let min t = t.min 41 | let max t = t.max 42 | let mean t = t.sum /. t.samples 43 | 44 | let var t = 45 | if t.samples <= 1. 46 | then Float.nan 47 | else Float.max 0. (t.varsum /. t.samples *. (t.samples /. (t.samples -. 1.))) 48 | ;; 49 | 50 | let stdev t = sqrt (var t) 51 | 52 | (* we need [update_in_place] to be inlined in order to eliminate the float allocation at 53 | the callsites where we have an int to hand instead of a float. *) 54 | let[@inline] update_in_place t value = 55 | if t.samples <= 0. 56 | then ( 57 | (* [Rstats.safe_mean] allocates, even after it's been inlined. 58 | It seems that in general, expressions of form 59 | [if expr then some_float else other_float] 60 | cause allocation, even in cases where it is unnecessary. 61 | 62 | So, I handle the [t.samples <= 0] separately, so that [safe_mean] is 63 | not needed. *) 64 | t.samples <- 1.; 65 | t.sum <- value; 66 | t.sqsum <- value *. value; 67 | t.max <- value; 68 | t.min <- value; 69 | t.varsum <- 0.) 70 | else ( 71 | (* [Option.value decay ~default_decay:...] suffers the same problem. *) 72 | let old_mean = mean t in 73 | t.samples <- t.samples +. 1.; 74 | t.sum <- t.sum +. value; 75 | t.sqsum <- t.sqsum +. (value *. value); 76 | (* [Float.max] suffers the same problem as above and causes allocation even 77 | after it's been inlined. *) 78 | if value > t.max then t.max <- value; 79 | if value < t.min then t.min <- value; 80 | let new_mean = mean t in 81 | (* Numerically stable method for computing variance. On wikipedia page: 82 | # Alternatively, "M2 = M2 + weight * delta * (x−mean)" *) 83 | t.varsum <- t.varsum +. ((value -. old_mean) *. (value -. new_mean))) 84 | ;; 85 | 86 | let copy t = { t with sum = t.sum } 87 | 88 | module%test Fstats = struct 89 | let data = 90 | [| 198215.02492520443 91 | ; 28715.0284862834887 92 | ; 434619.094190333097 93 | ; 800678.330169520807 94 | ; 200186.54372400351 95 | ; 137503.258498826239 96 | ; 566498.60534151 97 | ; 549219.475914424169 98 | ; 780230.679805230233 99 | ; 712168.552241884521 100 | ; 512045.175157501479 101 | ; 606136.851468109642 102 | ; 368469.614224194782 103 | ; 213372.100528741139 104 | ; 487759.722525204881 105 | ; 545327.353652161313 106 | ; 565759.781024767901 107 | ; 227130.713477647136 108 | ; 14526.9831253076572 109 | ; 87168.3680568782729 110 | ; 317822.864412072755 111 | ; 328746.783061697963 112 | ; 446049.964182617899 113 | ; 451270.307992378599 114 | ; 822506.373272555647 115 | ; 947812.349198815064 116 | ; 563960.680863914196 117 | ; 73057.735605084 118 | ; 475515.868111219897 119 | ; 79103.4644861585693 120 | ; 61060.2804668050376 121 | ; 821842.058883985155 122 | ; 162383.377334053017 123 | ; 151034.116153264389 124 | ; 357173.747924180352 125 | ; 417551.514353964303 126 | ; 758440.286012416356 127 | ; 480593.8769512953 128 | ; 109763.567296876703 129 | ; 154961.955787061859 130 | ; 50902.5130336880611 131 | ; 273048.455977052858 132 | ; 673477.375928052119 133 | ; 790059.438551203464 134 | ; 817997.314074333408 135 | ; 280563.866073483776 136 | ; 858501.471649471 137 | ; 908670.036968784756 138 | ; 843433.873243822 139 | ; 717604.357264731894 140 | ; 257166.21131005112 141 | ; 587352.255237122881 142 | ; 679376.01970596856 143 | ; 93196.2210949568544 144 | ; 343319.788271304453 145 | ; 757660.644341278588 146 | ; 403271.576879935688 147 | ; 974099.221967302146 148 | ; 964390.741413959884 149 | ; 807222.013931629714 150 | ; 670868.156459537 151 | ; 656612.853921575472 152 | ; 545398.269980843412 153 | |] 154 | ;; 155 | 156 | let stats = create () 157 | let () = Array.iter data ~f:(update_in_place stats) 158 | let%test "samples" = samples stats = 63 159 | let%test "min" = min stats = 14526.9831253076572 160 | let%test "max" = max stats = 974099.221967302146 161 | let%test "total" = total stats = 29970575.106168244 162 | let%test "mean" = mean stats = 475723.414383622934 163 | let%test "var" = var stats = 78826737609.7966156 164 | let%test "stdev" = stdev stats = 280760.997308736958 165 | 166 | let%test_unit "copy" = 167 | let stats2 = copy stats in 168 | update_in_place stats2 0.; 169 | [%test_eq: int] (samples stats) 63; 170 | [%test_eq: int] (samples stats2) 64 171 | ;; 172 | end 173 | 174 | module%bench Fstats = struct 175 | let stats = create () 176 | let%bench "update_in_place" = update_in_place stats 5. 177 | end 178 | -------------------------------------------------------------------------------- /src/fstats.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t 4 | 5 | val create : unit -> t 6 | val samples : t -> int 7 | val total : t -> float 8 | val min : t -> float 9 | val max : t -> float 10 | val mean : t -> float 11 | val var : t -> Float.t 12 | val stdev : t -> float 13 | val update_in_place : t -> float -> unit 14 | val copy : t -> t 15 | -------------------------------------------------------------------------------- /src/header_protocol.mli: -------------------------------------------------------------------------------- 1 | (** This file is automatically generated by a target in the build system. Do not modify it 2 | by hand. *) 3 | 4 | open! Core 5 | module Time_ns = Time_ns_unix 6 | 7 | val module_name : string 8 | 9 | type (-'hierarchy, -'rw) t constraint 'rw = [> read ] 10 | type ('hierarchy, 'rw) message = ('hierarchy, 'rw) t 11 | 12 | val sexp_of_t : _ -> _ -> (_, _) t -> Sexp.t 13 | 14 | type ('hierarchy, 'rw) t_no_exn = ('hierarchy, 'rw) t 15 | 16 | val sexp_of_t_no_exn : _ -> _ -> (_, _) t_no_exn -> Sexp.t 17 | val backing_iobuf : (_, 'rw) t -> ('rw, Iobuf.no_seek) Iobuf.t 18 | val backing_iobuf_local : (_, 'rw) t -> ('rw, Iobuf.no_seek) Iobuf.t 19 | val globalize : ('ty, 'rw) t -> ('ty, 'rw) t 20 | 21 | module R : sig 22 | type 'message t = 23 | | Need_more_data 24 | | Ok of 'message * int 25 | | Junk of exn * (int, exn) Result.t 26 | [@@deriving sexp_of] 27 | end 28 | 29 | module Message_type_and_errors : sig 30 | type _ t = 31 | | New_single : [ `New_single ] t 32 | | New_group : [ `New_group ] t 33 | | New_group_point : [ `New_group_point ] t 34 | | End_of_header : [ `End_of_header ] t 35 | | Epoch : [ `Epoch ] t 36 | | Need_more_data : [ `Error ] t 37 | | Invalid_message_type_or_subtype : [ `Error ] t 38 | | Message_length_too_short : [ `Error ] t 39 | [@@deriving sexp_of] 40 | 41 | (** [all_of_packed] does not include the error cases. *) 42 | type packed = T : _ t -> packed [@@deriving sexp_of, enumerate] [@@unboxed] 43 | 44 | module Packed : sig 45 | (** The hash and compare functions throw on the error cases of 46 | [message_type_and_errors]. [all] does not include the error cases. *) 47 | type 'ty message_type_and_errors = 'ty t 48 | 49 | type t = packed = T : _ message_type_and_errors -> t 50 | [@@deriving sexp_of, enumerate] [@@unboxed] 51 | 52 | include Comparable.S with type t := t 53 | include Hashable.S with type t := t 54 | end 55 | 56 | val to_wire_exn : _ t -> char 57 | val of_wire : char -> packed 58 | 59 | (** [{to,of}]_index_exn provide dense packed integers starting from 0, suitable for 60 | indexing into an array. *) 61 | val to_index_exn : _ t -> int 62 | 63 | val of_index_exn : int -> packed 64 | val max_index : int 65 | end 66 | 67 | val get_message_type : ([> read ], _) Iobuf.t -> Message_type_and_errors.packed 68 | 69 | (** [of_iobuf] must be fed a message type that comes from a call to [get_message_type] on 70 | the same window, otherwise it may cause segfaults or nonsensical reads. *) 71 | val of_iobuf : ('rw, _) Iobuf.t -> trusted:'ty Message_type_and_errors.t -> ('ty, 'rw) t 72 | 73 | val of_iobuf_local 74 | : ('rw, _) Iobuf.t 75 | -> trusted:'ty Message_type_and_errors.t 76 | -> ('ty, 'rw) t 77 | 78 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'ty Message_type_and_errors.t -> ('ty, 'rw) t 79 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'ty Message_type_and_errors.t -> ('ty, 'rw) t 80 | 81 | module New_single : sig 82 | type phantom = [ `New_single ] 83 | type nonrec -'rw t = (phantom, 'rw) t constraint 'rw = [> read ] [@@deriving sexp] 84 | 85 | val message_type : char 86 | val buffer_length : int 87 | val globalize : 'rw t -> 'rw t 88 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'rw t 89 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'rw t 90 | 91 | val write 92 | : id:Probe_id.t 93 | -> spec:Probe_type.t 94 | -> name:string 95 | -> (read_write, _) Iobuf.t 96 | -> int 97 | 98 | val create 99 | : id:Probe_id.t 100 | -> spec:Probe_type.t 101 | -> name:string 102 | -> (read_write, Iobuf.seek) Iobuf.t 103 | 104 | val get_message_length : _ t -> int 105 | val get_message_type : _ t -> char 106 | val get_id : _ t -> Probe_id.t 107 | val get_spec : _ t -> Probe_type.t 108 | val name_max_len : int 109 | val get_name : _ t -> string 110 | 111 | val get_name_zero_local_result 112 | : _ t 113 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 114 | -> 'a 115 | 116 | val get_name_zero_local 117 | : _ t 118 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 119 | -> 'a 120 | 121 | val get_name_zero 122 | : _ t 123 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 124 | -> 'a 125 | 126 | val get_name_zero_padded_local_result 127 | : _ t 128 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 129 | -> 'a 130 | 131 | val get_name_zero_padded_local 132 | : _ t 133 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 134 | -> 'a 135 | 136 | val get_name_zero_padded 137 | : _ t 138 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 139 | -> 'a 140 | 141 | val set_id : (read_write, _) Iobuf.t -> Probe_id.t -> unit 142 | val set_spec : (read_write, _) Iobuf.t -> Probe_type.t -> unit 143 | val set_name : (read_write, _) Iobuf.t -> string -> unit 144 | 145 | (** [set_name_zero buf f a] calls [f] on [buf], with the window adjusted to where [name] 146 | is. Even though [f] is given a seekable buffer, it must move nothing except the 147 | lower bound of the window past the data it wrote. *) 148 | val set_name_zero 149 | : (read_write, Iobuf.seek) Iobuf.t 150 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 151 | -> 'a 152 | -> unit 153 | 154 | val set_name_zero_local 155 | : (read_write, Iobuf.seek) Iobuf.t 156 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 157 | -> 'a 158 | -> unit 159 | 160 | val to_sub_iobuf : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 161 | val to_sub_iobuf_local : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 162 | 163 | module Unpacked : sig 164 | type t = 165 | { message_length : int 166 | ; message_type : char 167 | ; id : Probe_id.t 168 | ; spec : Probe_type.t 169 | ; name : string 170 | } 171 | [@@deriving sexp] 172 | 173 | val num_bytes : t -> int 174 | val write : t -> (read_write, _) Iobuf.t -> int 175 | end 176 | 177 | val to_unpacked : 'rw t -> Unpacked.t 178 | val of_unpacked : Unpacked.t -> 'rw t 179 | end 180 | 181 | module New_group : sig 182 | type phantom = [ `New_group ] 183 | type nonrec -'rw t = (phantom, 'rw) t constraint 'rw = [> read ] [@@deriving sexp] 184 | 185 | val message_type : char 186 | val buffer_length : int 187 | val globalize : 'rw t -> 'rw t 188 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'rw t 189 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'rw t 190 | 191 | val write 192 | : id:Probe_id.t 193 | -> spec:Probe_type.t 194 | -> name:string 195 | -> (read_write, _) Iobuf.t 196 | -> int 197 | 198 | val create 199 | : id:Probe_id.t 200 | -> spec:Probe_type.t 201 | -> name:string 202 | -> (read_write, Iobuf.seek) Iobuf.t 203 | 204 | val get_message_length : _ t -> int 205 | val get_message_type : _ t -> char 206 | val get_id : _ t -> Probe_id.t 207 | val get_spec : _ t -> Probe_type.t 208 | val name_max_len : int 209 | val get_name : _ t -> string 210 | 211 | val get_name_zero_local_result 212 | : _ t 213 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 214 | -> 'a 215 | 216 | val get_name_zero_local 217 | : _ t 218 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 219 | -> 'a 220 | 221 | val get_name_zero 222 | : _ t 223 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 224 | -> 'a 225 | 226 | val get_name_zero_padded_local_result 227 | : _ t 228 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 229 | -> 'a 230 | 231 | val get_name_zero_padded_local 232 | : _ t 233 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 234 | -> 'a 235 | 236 | val get_name_zero_padded 237 | : _ t 238 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 239 | -> 'a 240 | 241 | val set_id : (read_write, _) Iobuf.t -> Probe_id.t -> unit 242 | val set_spec : (read_write, _) Iobuf.t -> Probe_type.t -> unit 243 | val set_name : (read_write, _) Iobuf.t -> string -> unit 244 | 245 | (** [set_name_zero buf f a] calls [f] on [buf], with the window adjusted to where [name] 246 | is. Even though [f] is given a seekable buffer, it must move nothing except the 247 | lower bound of the window past the data it wrote. *) 248 | val set_name_zero 249 | : (read_write, Iobuf.seek) Iobuf.t 250 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 251 | -> 'a 252 | -> unit 253 | 254 | val set_name_zero_local 255 | : (read_write, Iobuf.seek) Iobuf.t 256 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 257 | -> 'a 258 | -> unit 259 | 260 | val to_sub_iobuf : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 261 | val to_sub_iobuf_local : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 262 | 263 | module Unpacked : sig 264 | type t = 265 | { message_length : int 266 | ; message_type : char 267 | ; id : Probe_id.t 268 | ; spec : Probe_type.t 269 | ; name : string 270 | } 271 | [@@deriving sexp] 272 | 273 | val num_bytes : t -> int 274 | val write : t -> (read_write, _) Iobuf.t -> int 275 | end 276 | 277 | val to_unpacked : 'rw t -> Unpacked.t 278 | val of_unpacked : Unpacked.t -> 'rw t 279 | end 280 | 281 | module New_group_point : sig 282 | type phantom = [ `New_group_point ] 283 | type nonrec -'rw t = (phantom, 'rw) t constraint 'rw = [> read ] [@@deriving sexp] 284 | 285 | val message_type : char 286 | val buffer_length : sources_count:int -> int 287 | val globalize : 'rw t -> 'rw t 288 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'rw t 289 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'rw t 290 | 291 | val write 292 | : group_id:Probe_id.t 293 | -> id:Probe_id.t 294 | -> name:string 295 | -> sources_count:int 296 | -> (read_write, _) Iobuf.t 297 | -> int 298 | 299 | val create 300 | : group_id:Probe_id.t 301 | -> id:Probe_id.t 302 | -> name:string 303 | -> sources_count:int 304 | -> (read_write, Iobuf.seek) Iobuf.t 305 | 306 | val get_message_length : _ t -> int 307 | val get_message_type : _ t -> char 308 | val get_group_id : _ t -> Probe_id.t 309 | val get_id : _ t -> Probe_id.t 310 | val name_max_len : int 311 | val get_name : _ t -> string 312 | 313 | val get_name_zero_local_result 314 | : _ t 315 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 316 | -> 'a 317 | 318 | val get_name_zero_local 319 | : _ t 320 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 321 | -> 'a 322 | 323 | val get_name_zero 324 | : _ t 325 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 326 | -> 'a 327 | 328 | val get_name_zero_padded_local_result 329 | : _ t 330 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 331 | -> 'a 332 | 333 | val get_name_zero_padded_local 334 | : _ t 335 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 336 | -> 'a 337 | 338 | val get_name_zero_padded 339 | : _ t 340 | -> ((read, Iobuf.no_seek) Iobuf.t -> safe_pos:int -> safe_len:int -> 'a) 341 | -> 'a 342 | 343 | val get_sources_count : _ t -> int 344 | 345 | (** Beware: [count] is trusted. If it is wrong, this function could read the wrong data 346 | or segfault. *) 347 | val get_sources_source_id : 'rw t -> count:int -> index:int -> Probe_id.t 348 | 349 | val set_group_id : (read_write, _) Iobuf.t -> Probe_id.t -> unit 350 | val set_id : (read_write, _) Iobuf.t -> Probe_id.t -> unit 351 | val set_name : (read_write, _) Iobuf.t -> string -> unit 352 | 353 | (** [set_name_zero buf f a] calls [f] on [buf], with the window adjusted to where [name] 354 | is. Even though [f] is given a seekable buffer, it must move nothing except the 355 | lower bound of the window past the data it wrote. *) 356 | val set_name_zero 357 | : (read_write, Iobuf.seek) Iobuf.t 358 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 359 | -> 'a 360 | -> unit 361 | 362 | val set_name_zero_local 363 | : (read_write, Iobuf.seek) Iobuf.t 364 | -> ('a -> (read_write, Iobuf.seek) Iobuf.t -> unit) 365 | -> 'a 366 | -> unit 367 | 368 | (** Beware: [count] is trusted. If it is wrong, this function could read the wrong data. *) 369 | val set_sources_source_id 370 | : (read_write, _) Iobuf.t 371 | -> count:int 372 | -> index:int 373 | -> Probe_id.t 374 | -> unit 375 | 376 | (** Beware: [count] is trusted. If it is wrong, this function could read the wrong data. *) 377 | val write_sources 378 | : (read_write, _) Iobuf.t 379 | -> count:int 380 | -> index:int 381 | -> source_id:Probe_id.t 382 | -> unit 383 | 384 | val to_sub_iobuf : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 385 | val to_sub_iobuf_local : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 386 | 387 | module Unpacked : sig 388 | type t_sources = { source_id : Probe_id.t } [@@deriving sexp] 389 | 390 | type t = 391 | { message_length : int 392 | ; message_type : char 393 | ; group_id : Probe_id.t 394 | ; id : Probe_id.t 395 | ; name : string 396 | ; sources_grp : t_sources array 397 | } 398 | [@@deriving sexp] 399 | 400 | val num_bytes : t -> int 401 | val write : t -> (read_write, _) Iobuf.t -> int 402 | end 403 | 404 | val to_unpacked : 'rw t -> Unpacked.t 405 | val of_unpacked : Unpacked.t -> 'rw t 406 | end 407 | 408 | module End_of_header : sig 409 | type phantom = [ `End_of_header ] 410 | type nonrec -'rw t = (phantom, 'rw) t constraint 'rw = [> read ] [@@deriving sexp] 411 | 412 | val message_type : char 413 | val buffer_length : int 414 | val globalize : 'rw t -> 'rw t 415 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'rw t 416 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'rw t 417 | val write : (read_write, _) Iobuf.t -> int 418 | val create : unit -> (read_write, Iobuf.seek) Iobuf.t 419 | val get_message_length : _ t -> int 420 | val get_message_type : _ t -> char 421 | val to_sub_iobuf : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 422 | val to_sub_iobuf_local : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 423 | 424 | module Unpacked : sig 425 | type t = 426 | { message_length : int 427 | ; message_type : char 428 | } 429 | [@@deriving sexp] 430 | 431 | val num_bytes : t -> int 432 | val write : t -> (read_write, _) Iobuf.t -> int 433 | end 434 | 435 | val to_unpacked : 'rw t -> Unpacked.t 436 | val of_unpacked : Unpacked.t -> 'rw t 437 | end 438 | 439 | module Epoch : sig 440 | type phantom = [ `Epoch ] 441 | type nonrec -'rw t = (phantom, 'rw) t constraint 'rw = [> read ] [@@deriving sexp] 442 | 443 | val message_type : char 444 | val buffer_length : int 445 | val globalize : 'rw t -> 'rw t 446 | val of_iobuf_exn : ('rw, _) Iobuf.t -> 'rw t 447 | val of_iobuf_local_exn : ('rw, _) Iobuf.t -> 'rw t 448 | val write : epoch:Profiler_epoch.t -> (read_write, _) Iobuf.t -> int 449 | val create : epoch:Profiler_epoch.t -> (read_write, Iobuf.seek) Iobuf.t 450 | val get_message_length : _ t -> int 451 | val get_message_type : _ t -> char 452 | val get_epoch : _ t -> Profiler_epoch.t 453 | val set_epoch : (read_write, _) Iobuf.t -> Profiler_epoch.t -> unit 454 | val to_sub_iobuf : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 455 | val to_sub_iobuf_local : 'rw t -> ('rw, Iobuf.seek) Iobuf.t 456 | 457 | module Unpacked : sig 458 | type t = 459 | { message_length : int 460 | ; message_type : char 461 | ; epoch : Profiler_epoch.t 462 | } 463 | [@@deriving sexp] 464 | 465 | val num_bytes : t -> int 466 | val write : t -> (read_write, _) Iobuf.t -> int 467 | end 468 | 469 | val to_unpacked : 'rw t -> Unpacked.t 470 | val of_unpacked : Unpacked.t -> 'rw t 471 | end 472 | 473 | module Unpacked : sig 474 | type t = 475 | | New_single of New_single.Unpacked.t 476 | | New_group of New_group.Unpacked.t 477 | | New_group_point of New_group_point.Unpacked.t 478 | | End_of_header of End_of_header.Unpacked.t 479 | | Epoch of Epoch.Unpacked.t 480 | [@@deriving sexp] 481 | 482 | val num_bytes : t -> int 483 | val message_type : t -> char 484 | val write : t -> (read_write, _) Iobuf.t -> int 485 | end 486 | 487 | val num_bytes_needed_for_message_length : int 488 | 489 | (** Assuming the iobuf starts at a message, returns its length or raise if the window 490 | doesn't contain [num_bytes_needed_for_message_length] bytes. *) 491 | val num_bytes_in_message : ([> read ], _) Iobuf.t -> int 492 | 493 | (** Equivalent to [Iobuf.advance buf (num_bytes_in_message buf)] *) 494 | val skip_message : ([> read ], Iobuf.seek) Iobuf.t -> unit 495 | 496 | val buffer_contains_full_message : ([> read ], _) Iobuf.t -> bool 497 | val of_unpacked : Unpacked.t -> (_, _) Iobuf.t 498 | val to_unpacked : ([> read ], _) Iobuf.t -> Unpacked.t R.t 499 | val to_unpacked_exn : ([> read ], _) Iobuf.t -> Unpacked.t 500 | -------------------------------------------------------------------------------- /src/index.mld: -------------------------------------------------------------------------------- 1 | {0 Core_profiler} 2 | 3 | [Core_profiler] is a library that helps you profile programs and 4 | estimate various various costs. 5 | 6 | {{!Core_profiler}{b The full API is browsable here}}. 7 | 8 | Here is a toy program to help understand how to use it: 9 | {[ 10 | (* No usage of core_profiler yet *) 11 | open! Core.Std 12 | 13 | let func () = 14 | let key = Random.int 100 in 15 | if key mod 3 <> 0 then begin 16 | ignore (Array.create ~len:100 10); 17 | end 18 | 19 | let () = 20 | for _i = 1 to 10_000_000 do 21 | func () 22 | done 23 | ]} 24 | 25 | The library lets us put probes into our program. Here is a probe: 26 | {[ 27 | open! Core.Std 28 | open Core_profiler.Std_offline 29 | 30 | let p = Probe.create ~name:"array_len" ~units:Profiler_units.Int 31 | 32 | let func () = 33 | let len = 100 in 34 | let key = Random.int 100 in 35 | if key mod 3 <> 0 then begin 36 | ignore (Array.create ~len 10); 37 | Probe.record p len 38 | end 39 | 40 | let () = 41 | for _i = 1 to 10_000_000 do 42 | func () 43 | done 44 | ]} 45 | 46 | You can run the program like this: 47 | {v 48 | CORE_PROFILER= ./prog2.exe 49 | v} 50 | 51 | If the environment variable called [CORE_PROFILER] is not set, this 52 | will complain. This will let us know if we accidentally deploy a 53 | binary with profiling into production. Running this program produces 54 | an output file called [profiler.dat] whose contents we can analyze 55 | with the profiler tool: 56 | {v 57 | + profiler_tool.exe summary 58 | ┌───────────┬───┬───────┬──────┬─────┬─────┬───────┬──────┬───────┐ 59 | │ name │ │ count │ mean │ min │ max │ stdev │ 5 %l │ 95 %l │ 60 | ├───────────┼───┼───────┼──────┼─────┼─────┼───────┼──────┼───────┤ 61 | │ array_len │ v │ 6.6e6 │ 100 │ 100 │ 100 │ 0 │ 100 │ 100 │ 62 | └───────────┴───┴───────┴──────┴─────┴─────┴───────┴──────┴───────┘ 63 | v} 64 | 65 | The output says that [array_len] has its value set 6.6 million times 66 | and provides various stats about it. If the program had setup multiple 67 | probes you would see the value of all the probes. The summary 68 | subcommands can dump out various quantiles and do other things. 69 | 70 | We can change the program to prints stats "online", i.e. when the 71 | program is running by opening Std_online: 72 | {[ 73 | open! Core.Std 74 | open Core_profiler.Std_online 75 | 76 | let p = Probe.create ~name:"array_len" ~units:Profiler_units.Int 77 | 78 | let func () = 79 | let len = 100 in 80 | let key = Random.int 100 in 81 | if key mod 3 <> 0 then begin 82 | ignore (Array.create ~len 10); 83 | Probe.record p len 84 | end 85 | 86 | let () = 87 | for _i = 1 to 10_000_000 do 88 | func (); 89 | Profiler.safe_to_delay () 90 | done 91 | ]} 92 | 93 | When this program is run it will print a summary of the probes to 94 | stdout every second: 95 | {v 96 | ┌───────────┬───────┬─────────┬──────┬─────┬─────┬───────┐ 97 | │ name │ count │ sum │ mean │ min │ max │ stdev │ 98 | ├───────────┼───────┼─────────┼──────┼─────┼─────┼───────┤ 99 | │ array_len │ 6.6e6 │ 660.1e6 │ 100 │ 100 │ 100 │ 0 │ 100 | └───────────┴───────┴─────────┴──────┴─────┴─────┴───────┘ 101 | v} 102 | 103 | The rate of output can be controlled by setting [PRINT_INTERVAL] to 104 | some integer number of seconds. i.e. 105 | 106 | In general, online profiling is more limited than offline profiling in 107 | what stats in tracks. Depending on how performance sensitive your 108 | program is, it might also be more disruptive to the execution of the 109 | program because it has to do the work of maintaining stats in 110 | process. Offline probes have been tuned to reduce the impact on the 111 | running process. 112 | 113 | Finally, once you are done profiling your program and what to ship it, 114 | you can ship it as follows: 115 | {[ 116 | open! Core.Std 117 | open Core_profiler.Std_disabled 118 | 119 | let p = Probe.create ~name:"array_len" ~units:Profiler_units.Int 120 | 121 | let func () = 122 | let len = 100 in 123 | let key = Random.int 100 in 124 | if key mod 3 <> 0 then begin 125 | ignore (Array.create ~len 10); 126 | Probe.record p len 127 | end 128 | 129 | let () = 130 | for _i = 1 to 10_000_000 do 131 | func (); 132 | Profiler.safe_to_delay () 133 | done 134 | ]} 135 | 136 | All the functions exposed in {!Core_profiler_disabled.Std} are no-ops 137 | and do not contribute to the cost of the running program. If [exp] is 138 | some expensive computation in [Probe.report p ], then one should 139 | write this as [if profiling_enabled then Probe.report p ] to avoid 140 | the cost of computing [exp] when the profiling is disabled. 141 | 142 | If you just want to track times at which various events happened, you 143 | can use {!Timer} instead of probe. 144 | 145 | {1 Groups of probes} 146 | 147 | [Core_profiler] includes of a notion of groups of probes. Groups are 148 | handy for measuring changes in values between two probes in a group 149 | and times when various probes in the group were set. Here is an 150 | example: 151 | 152 | {[ 153 | open! Core.Std 154 | open Core_profiler.Std_offline 155 | 156 | 157 | let g = Probe.Group.create ~name:"func" ~units:Profiler_units.Words 158 | let p1 = Probe.Group.add_probe g ~name:"p1" () 159 | let p2 = Probe.Group.add_probe g ~name:"p2" () 160 | let px = Probe.Group.add_probe g ~name:"px" () 161 | 162 | let func () = 163 | Probe.Group.reset g; 164 | Probe.record p1 (Gc.minor_words ()); 165 | let len = 100 in 166 | let key = Random.int 100 in 167 | if key mod 3 <> 0 then begin 168 | ignore (Array.create ~len 10); 169 | Probe.record p2 (Gc.minor_words ()); 170 | end; 171 | Probe.record px (Gc.minor_words ()) 172 | 173 | let () = 174 | for _i = 1 to 10_000_000 do 175 | func (); 176 | done 177 | ]} 178 | 179 | 180 | {v 181 | + ../offline_tool/bin/profiler_tool.exe summary -file profiler.dat 182 | ┌────────────┬────┬───────┬──────────┬──────────┬──────────┬──────────┬─────────┬──────────┐ 183 | │ name │ │ count │ mean │ min │ max │ stdev │ 5 %l │ 95 %l │ 184 | ├────────────┼────┼───────┼──────────┼──────────┼──────────┼──────────┼─────────┼──────────┤ 185 | │ func:p1 │ v │ 10e6 │ 333.77Mw │ 410.53kw │ 667.12Mw │ 192.48Mw │ 32Mw │ 635.58Mw │ 186 | │ func:p2 │ v │ 6.6e6 │ 333.76Mw │ 410.63kw │ 667.12Mw │ 192.46Mw │ 38.93Mw │ 635.58Mw │ 187 | │ func:px │ v │ 10e6 │ 333.77Mw │ 410.63kw │ 667.12Mw │ 192.48Mw │ 34.21Mw │ 636.57Mw │ 188 | │ func:p1,p2 │ dt │ 6.6e6 │ 181ns │ 112ns │ 2.88ms │ 3.98us │ 122ns │ 277ns │ 189 | │ func:p1,p2 │ dv │ 6.6e6 │ 101w │ 101w │ 116w │ 0w │ 101w │ 101w │ 190 | │ func:p1,px │ dt │ 3.4e6 │ 66ns │ 40ns │ 2.43ms │ 1.85us │ 52ns │ 69ns │ 191 | │ func:p1,px │ dv │ 3.4e6 │ 0w │ 0w │ 15w │ 0w │ 0w │ 0w │ 192 | │ func:p2,px │ dt │ 6.6e6 │ 25ns │ 13ns │ 3.3ms │ 1.9us │ 16ns │ 57ns │ 193 | │ func:p2,px │ dv │ 6.6e6 │ 0w │ 0w │ 15w │ 0w │ 0w │ 0w │ 194 | └────────────┴────┴───────┴──────────┴──────────┴──────────┴──────────┴─────────┴──────────┘ 195 | v} 196 | 197 | In the above table there are a few new values like [func:p1,p2]. These 198 | refer to the change in time [dt] between [p1] and [p2] and the change 199 | in value [dv] between the same probes. The syntax [func:p1,p2] is an 200 | instance of a more general idea of paths that we will see below. 201 | 202 | 203 | {1 Specifying paths} 204 | 205 | The strings in the output [func:p1,p2] are called "interests" in the 206 | [Core_profiler] speak. 207 | 208 | Point interests: An interest can be just a probe name such as [p1]. A 209 | probe that is part of group is prefixed by the group name such as 210 | [func:p1] above. 211 | 212 | Path interests: An interest can also be a path that includes one or 213 | more probes of the same group. The interest [func:p1,px] means all 214 | paths from the probe [func:p1] directly to the probe [func:px] with no 215 | intervening probes in between. Other than the [,] separator one can 216 | also use the [..] sperator. The interest [func:p1..px] means any path 217 | from [func:p1] to [func:px] that may have intervening probes in 218 | between. 219 | 220 | Further, path calculuation does not cross a [Group.reset]. This means 221 | that in the above code there are no paths between two calls to 222 | [func]. 223 | 224 | Here is a comparison of two paths. Notice that the numbers are 225 | different for [func:p1..px] because two-thirds of the paths went 226 | through [func:p2]. 227 | 228 | {v 229 | + ../offline_tool/bin/profiler_tool.exe summary -file profiler.dat func:p1,px func:p1..px 230 | ┌─────────────┬────┬───────┬───────┬──────┬────────┬────────┬──────┬───────┐ 231 | │ name │ │ count │ mean │ min │ max │ stdev │ 5 %l │ 95 %l │ 232 | ├─────────────┼────┼───────┼───────┼──────┼────────┼────────┼──────┼───────┤ 233 | │ func:p1,px │ dt │ 3.4e6 │ 66ns │ 40ns │ 2.43ms │ 1.85us │ 54ns │ 69ns │ 234 | │ func:p1,px │ dv │ 3.4e6 │ 0w │ 0w │ 15w │ 0w │ 0w │ 0w │ 235 | │ func:p1..px │ dt │ 10e6 │ 159ns │ 40ns │ 3.3ms │ 3.74us │ 59ns │ 286ns │ 236 | │ func:p1..px │ dv │ 10e6 │ 67w │ 0w │ 116w │ 48w │ 0w │ 101w │ 237 | └─────────────┴────┴───────┴───────┴──────┴────────┴────────┴──────┴───────┘ 238 | v} 239 | 240 | One can also compose [..] and [,] in interests, [func:p1,p2..px] and 241 | [func:p1..p2..px] are valid. Note that a probe name cannot appear 242 | twice in a path other than as end points -- i.e. [func:p1..p1] is ok, 243 | but [func:p1..p1..p1] is not. 244 | 245 | {1 Range filters} 246 | 247 | Once can filter interests by value ranges. Filters have the form 248 | [~dt[]], [~dv[]] and [~v[]] to filter on time 249 | delta, value deltas and values respectively. For example: 250 | 251 | - [g:x..z~dt[0ns,400ns]] filters paths between [g:x..z] to ones where 252 | the time difference it within 0 and 400ns. 253 | 254 | {1 Graphs} 255 | 256 | One can also generate quantile plots. This shows the value difference 257 | along the path: 258 | 259 | {v 260 | + ../offline_tool/bin/profiler_tool.exe plot func:p1..px delta 261 | 0w -- 5w 34.19 |----1----2----3----4----5 262 | 6w -- 11w 0.00 | 263 | 12w -- 17w 0.00 | 264 | 18w -- 23w 0.00 | 265 | 24w -- 29w 0.00 | 266 | 30w -- 35w 0.00 | 267 | 36w -- 40w 0.00 | 268 | 41w -- 46w 0.00 | 269 | 47w -- 52w 0.00 | 270 | 53w -- 58w 0.00 | 271 | 59w -- 64w 0.00 | 272 | 65w -- 70w 0.00 | 273 | 71w -- 76w 0.00 | 274 | 77w -- 81w 0.00 | 275 | 82w -- 87w 0.00 | 276 | 88w -- 93w 0.00 | 277 | 94w -- 99w 0.00 | 278 | 100w -- 105w 65.81 |----1----2----3----4----5----6----7----8----9----| 279 | 106w -- 111w 0.00 | 280 | 112w -- 116w 0.00 | 281 | (each '-' is approximately 1.316 units.) 282 | v} 283 | 284 | This shows the time difference along the path: 285 | {v 286 | + ../offline_tool/bin/profiler_tool.exe plot 'func:p1..px~dt[0,300ns]' time_delta 287 | 42ns -- 54ns 1.80 |--- 288 | 55ns -- 67ns 21.98 |----1----2----3----4----5----6----7-- 289 | 68ns -- 80ns 9.28 |----1----2----3 290 | 81ns -- 93ns 0.79 |- 291 | 94ns -- 106ns 0.12 | 292 | 107ns -- 119ns 0.07 | 293 | 120ns -- 132ns 0.02 | 294 | 133ns -- 145ns 3.28 |----1 295 | 146ns -- 158ns 29.22 |----1----2----3----4----5----6----7----8----9----| 296 | 159ns -- 171ns 11.05 |----1----2----3--- 297 | 172ns -- 184ns 4.36 |----1-- 298 | 185ns -- 197ns 2.47 |---- 299 | 198ns -- 210ns 3.59 |----1- 300 | 211ns -- 223ns 5.28 |----1---- 301 | 224ns -- 236ns 3.08 |----1 302 | 237ns -- 249ns 1.70 |-- 303 | 250ns -- 262ns 0.75 |- 304 | 263ns -- 275ns 0.55 | 305 | 276ns -- 288ns 0.36 | 306 | 289ns -- 300ns 0.25 | 307 | (each '-' is approximately 0.584 units.) 308 | v} 309 | 310 | One can also look at the density plot in log-scale and this is useful 311 | when chasing tails. This plot takes a little gettign used to, but is 312 | handy. We scale the density to be in the range 0 to 100_000 and 313 | display the log10 of it as the 'y-axis' -- i.e. all y-axis values fall 314 | in the range 0 to 5. In log-scale a y-axis difference of 1 unit 315 | implies a 10x difference in relative density. 316 | {v 317 | + ../offline_tool/bin/profiler_tool.exe plot 'func:p1..px~dt[0,300ns]' time_delta -log 318 | 42ns -- 54ns 3.26 |----1----2----3----4----5----6----7- 319 | 55ns -- 67ns 4.34 |----1----2----3----4----5----6----7----8----9--- 320 | 68ns -- 80ns 3.97 |----1----2----3----4----5----6----7----8---- 321 | 81ns -- 93ns 2.90 |----1----2----3----4----5----6-- 322 | 94ns -- 106ns 2.08 |----1----2----3----4--- 323 | 107ns -- 119ns 1.85 |----1----2----3----4 324 | 120ns -- 132ns 1.30 |----1----2---- 325 | 133ns -- 145ns 3.52 |----1----2----3----4----5----6----7---- 326 | 146ns -- 158ns 4.47 |----1----2----3----4----5----6----7----8----9----| 327 | 159ns -- 171ns 4.04 |----1----2----3----4----5----6----7----8----9 328 | 172ns -- 184ns 3.64 |----1----2----3----4----5----6----7----8 329 | 185ns -- 197ns 3.39 |----1----2----3----4----5----6----7-- 330 | 198ns -- 210ns 3.56 |----1----2----3----4----5----6----7---- 331 | 211ns -- 223ns 3.72 |----1----2----3----4----5----6----7----8- 332 | 224ns -- 236ns 3.49 |----1----2----3----4----5----6----7---- 333 | 237ns -- 249ns 3.23 |----1----2----3----4----5----6----7- 334 | 250ns -- 262ns 2.88 |----1----2----3----4----5----6-- 335 | 263ns -- 275ns 2.74 |----1----2----3----4----5----6 336 | 276ns -- 288ns 2.56 |----1----2----3----4----5--- 337 | 289ns -- 300ns 2.40 |----1----2----3----4----5- 338 | (each '-' is approximately 0.089 units.) 339 | v} 340 | Here are two more examples of the same: 341 | {v 342 | + ../offline_tool/bin/profiler_tool.exe plot 'func:p1..px~dt[0,15us]' time_delta 343 | 42ns -- 786ns 99.94 |----1----2----3----4----5----6----7----8----9----| 344 | 787ns -- 1.53us 0.00 | 345 | 1.53us -- 2.28us 0.00 | 346 | 2.28us -- 3.02us 0.00 | 347 | 3.02us -- 3.77us 0.00 | 348 | 3.77us -- 4.51us 0.00 | 349 | 4.51us -- 5.25us 0.00 | 350 | 5.26us -- 6us 0.00 | 351 | 6us -- 6.75us 0.00 | 352 | 6.75us -- 7.49us 0.00 | 353 | 7.49us -- 8.23us 0.02 | 354 | 8.24us -- 8.98us 0.00 | 355 | 8.98us -- 9.72us 0.03 | 356 | 9.73us -- 10.47us 0.00 | 357 | 10.47us -- 11.21us 0.00 | 358 | 11.21us -- 11.96us 0.01 | 359 | 11.96us -- 12.7us 0.00 | 360 | 12.71us -- 13.45us 0.00 | 361 | 13.45us -- 14.19us 0.00 | 362 | 14.2us -- 14.94us 0.00 | 363 | (each '-' is approximately 1.999 units.) 364 | v} 365 | 366 | {v 367 | + ../offline_tool/bin/profiler_tool.exe plot 'func:p1..px~dt[0,15us]' time_delta -log 368 | 42ns -- 786ns 5.00 |----1----2----3----4----5----6----7----8----9----| 369 | 787ns -- 1.53us 0.00 | 370 | 1.53us -- 2.28us 0.00 | 371 | 2.28us -- 3.02us 0.00 | 372 | 3.02us -- 3.77us 0.00 | 373 | 3.77us -- 4.51us 0.00 | 374 | 4.51us -- 5.25us 0.00 | 375 | 5.26us -- 6us 0.00 | 376 | 6us -- 6.75us 0.00 | 377 | 6.75us -- 7.49us 0.00 | 378 | 7.49us -- 8.23us 1.30 |----1----2--- 379 | 8.24us -- 8.98us 0.00 | 380 | 8.98us -- 9.72us 1.48 |----1----2---- 381 | 9.73us -- 10.47us 0.00 | 382 | 10.47us -- 11.21us 0.00 | 383 | 11.21us -- 11.96us 1.00 |----1----2 384 | 11.96us -- 12.7us 0.00 | 385 | 12.71us -- 13.45us 0.00 | 386 | 13.45us -- 14.19us 0.00 | 387 | 14.2us -- 14.94us 0.00 | 388 | (each '-' is approximately 0.100 units.) 389 | v} 390 | 391 | {2 Viewing the time series} 392 | 393 | One can also look at the entire time series of events recorded using 394 | the log command. This is sometimes useful in figuring out what 395 | happened in a particular instance -- maybe a specific outlier. 396 | 397 | Typically dumping out the whole time series is too much 398 | information. The log command can be filtered such that one can find 399 | one event and show a few metrics (a context) around the interesting 400 | metric. For example, in the above data we could ask to see the time 401 | series near cases when going from p1 to px took somewhere between 11.9 402 | and 12 micro secs. In the output below each such instance in the 403 | dataset is demarcated by [---]. 404 | 405 | {v 406 | + ../offline_tool/bin/profiler_tool.exe log -near 'func:p1,px~dt[11.9us,12us]' 407 | 14:24:12.883846430 func:p1 v 22.37Mw 408 | 14:24:12.883846504 func:px v 22.37Mw 409 | 14:24:12.883846504 func:p1,px dt 74ns dv 0w v 22.37Mw 410 | 14:24:12.883846543 func:p1 v 22.37Mw 411 | 14:24:12.883846678 func:p2 v 22.37Mw 412 | 14:24:12.883846678 func:p1,p2 dt 135ns dv 101w v 22.37Mw 413 | 14:24:12.883846702 func:px v 22.37Mw 414 | 14:24:12.883846702 func:p2,px dt 24ns dv 0w v 22.37Mw 415 | 14:24:12.883846745 func:p1 v 22.37Mw 416 | 14:24:12.883858695 func:px v 22.37Mw 417 | 14:24:12.883858695 func:p1,px dt 11.95us dv 0w v 22.37Mw <---- 418 | 14:24:12.883858947 func:p1 v 22.37Mw 419 | 14:24:12.883859186 func:p2 v 22.37Mw 420 | 14:24:12.883859186 func:p1,p2 dt 239ns dv 101w v 22.37Mw 421 | 14:24:12.883859202 func:px v 22.37Mw 422 | 14:24:12.883859202 func:p2,px dt 16ns dv 0w v 22.37Mw 423 | 14:24:12.883859253 func:p1 v 22.37Mw 424 | 14:24:12.883859390 func:p2 v 22.37Mw 425 | 14:24:12.883859390 func:p1,p2 dt 137ns dv 101w v 22.37Mw 426 | 14:24:12.883859414 func:px v 22.37Mw 427 | 14:24:12.883859414 func:p2,px dt 24ns dv 0w v 22.37Mw 428 | --- 429 | 14:24:13.066214700 func:px v 81.91Mw 430 | 14:24:13.066214700 func:p2,px dt 18ns dv 0w v 81.91Mw 431 | 14:24:13.066214757 func:p1 v 81.91Mw 432 | 14:24:13.066214833 func:px v 81.91Mw 433 | 14:24:13.066214833 func:p1,px dt 76ns dv 0w v 81.91Mw 434 | 14:24:13.066214873 func:p1 v 81.91Mw 435 | 14:24:13.066214942 func:px v 81.91Mw 436 | 14:24:13.066214942 func:p1,px dt 69ns dv 0w v 81.91Mw 437 | 14:24:13.066214980 func:p1 v 81.91Mw 438 | 14:24:13.066226966 func:px v 81.91Mw 439 | 14:24:13.066226966 func:p1,px dt 11.99us dv 0w v 81.91Mw <----- 440 | 14:24:13.066227279 func:p1 v 81.91Mw 441 | 14:24:13.066227515 func:px v 81.91Mw 442 | 14:24:13.066227515 func:p1,px dt 236ns dv 0w v 81.91Mw 443 | 14:24:13.066227553 func:p1 v 81.91Mw 444 | 14:24:13.066227614 func:px v 81.91Mw 445 | 14:24:13.066227614 func:p1,px dt 61ns dv 0w v 81.91Mw 446 | 14:24:13.066227651 func:p1 v 81.91Mw 447 | 14:24:13.066227720 func:px v 81.91Mw 448 | 14:24:13.066227720 func:p1,px dt 69ns dv 0w v 81.91Mw 449 | 14:24:13.066227756 func:p1 v 81.91Mw 450 | --- 451 | v} 452 | -------------------------------------------------------------------------------- /src/offline.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core_profiler_disabled 3 | 4 | module Profiler = struct 5 | let is_enabled = true 6 | 7 | let safe_to_delay () = 8 | Common.maybe_do_slow_tasks Common.Offline_profiler ~reluctance:1; 9 | Protocol.Buffer.ensure_free 2048 10 | ;; 11 | 12 | let dump_stats () = Protocol.Writer.dump_stats () 13 | 14 | let configure 15 | ?don't_require_core_profiler_env 16 | ?offline_profiler_data_file 17 | ?online_print_time_interval_secs:_ 18 | ?online_print_by_default:_ 19 | () 20 | = 21 | Option.iter don't_require_core_profiler_env ~f:(fun () -> 22 | Check_environment.don't_require_core_profiler_env ()); 23 | Option.iter offline_profiler_data_file ~f:(fun file -> 24 | Protocol.set_current_output_filename file) 25 | ;; 26 | end 27 | 28 | module Timer = struct 29 | type timer = Probe_id.t 30 | type t = timer 31 | type probe = t 32 | 33 | let create ~name = 34 | Check_environment.check_safety_exn (); 35 | let id = Probe_id.create () in 36 | Protocol.Writer.write_new_single id name Probe_type.Timer; 37 | id 38 | ;; 39 | 40 | let record id = 41 | let n = Common.now Common.Offline_profiler ~reluctance:3 () in 42 | Protocol.Writer.write_timer_at id n 43 | ;; 44 | 45 | module Group = struct 46 | type t = Probe_id.t 47 | 48 | let create ~name = 49 | Check_environment.check_safety_exn (); 50 | let id = Probe_id.create () in 51 | Protocol.Writer.write_new_group id name Probe_type.Timer; 52 | id 53 | ;; 54 | 55 | let add_probe group ?(sources = [||]) ~name () = 56 | let id = Probe_id.create () in 57 | (* Note! sources : Point.t array = Point_id.t array *) 58 | Protocol.Writer.write_new_group_point ~group_id:group ~id name sources; 59 | id 60 | ;; 61 | 62 | let reset group = 63 | let n = Common.now Common.Offline_profiler ~reluctance:2 () in 64 | Protocol.Writer.write_group_reset group n 65 | ;; 66 | end 67 | end 68 | 69 | module%bench Timer = struct 70 | let () = Profiler.configure () ~don't_require_core_profiler_env:() 71 | let timer = Timer.create ~name:"bench_timer" 72 | 73 | (* let group = Timer.Group.create "bench_timer_group" () 74 | * let group_probe = Timer.Group.add_probe group "bench_timer_group_probe" *) 75 | 76 | let%bench "at" = Timer.record timer 77 | 78 | (* BENCH "group_probe_at" = Timer.Group.Probe.at group_probe 79 | * 80 | * BENCH "group_reset" = Timer.Group.reset group *) 81 | 82 | let () = Protocol.Writer.set_at_exit_handler `Disable 83 | end 84 | 85 | module Probe = struct 86 | type probe = Probe_id.t 87 | type t = probe 88 | 89 | let create ~name ~units = 90 | Check_environment.check_safety_exn (); 91 | let id = Probe_id.create () in 92 | Protocol.Writer.write_new_single id name (Probe_type.Probe units); 93 | id 94 | ;; 95 | 96 | let record id value = 97 | let n = Common.now Common.Offline_profiler ~reluctance:3 () in 98 | Protocol.Writer.write_probe_at id n value 99 | ;; 100 | 101 | module Group = struct 102 | type t = Probe_id.t 103 | 104 | let create ~name ~units = 105 | Check_environment.check_safety_exn (); 106 | let id = Probe_id.create () in 107 | Protocol.Writer.write_new_group id name (Probe_type.Probe units); 108 | id 109 | ;; 110 | 111 | let add_probe group ?(sources = [||]) ~name () = 112 | let id = Probe_id.create () in 113 | Protocol.Writer.write_new_group_point ~group_id:group ~id name sources; 114 | id 115 | ;; 116 | 117 | let reset group = 118 | let n = Common.now Common.Offline_profiler ~reluctance:2 () in 119 | Protocol.Writer.write_group_reset group n 120 | ;; 121 | end 122 | end 123 | 124 | module%bench Probe = struct 125 | let () = Profiler.configure () ~don't_require_core_profiler_env:() 126 | let timer = Probe.create ~name:"bench_probe" ~units:Profiler_units.Seconds 127 | 128 | (* let group = Probe.Group.create "bench_probe_group" Profiler_units.Int 129 | * let group_probe = Probe.Group.add_probe group "bench_probe_group_probe" *) 130 | 131 | let%bench "at" = Probe.record timer 19827312 132 | 133 | (* BENCH "group_probe_at" = Probe.Group.Probe.at group_probe 123812 134 | * 135 | * BENCH "group_reset" = Probe.Group.reset group *) 136 | 137 | let () = Protocol.Writer.set_at_exit_handler `Disable 138 | end 139 | 140 | module Delta_timer = struct 141 | type state = Time_ns.t 142 | 143 | type t = 144 | { probe : Probe.t 145 | ; mutable state : state 146 | ; mutable accum : int 147 | } 148 | 149 | let create ~name = 150 | { probe = Probe.create ~name ~units:Profiler_units.Nanoseconds 151 | ; state = Time_ns.epoch 152 | ; accum = 0 153 | } 154 | ;; 155 | 156 | let diff n state = Time_ns.diff n state |> Time_ns.Span.to_int_ns 157 | 158 | (* If we calibrate on start, we get back the time before we started calibrating, 159 | and those 300ns will be included in the delta. *) 160 | let stateless_start _t = Common.now Common.Offline_profiler ~reluctance:4 () 161 | 162 | let stateless_stop t state = 163 | (* Avoid calling Common.now () twice: *) 164 | let n = Common.now Common.Offline_profiler ~reluctance:2 () in 165 | let d = diff n state in 166 | Protocol.Writer.write_probe_at t.probe n d 167 | ;; 168 | 169 | let start t = 170 | let n = Common.now Common.Offline_profiler ~reluctance:4 () in 171 | t.state <- n 172 | ;; 173 | 174 | let accumulate t n = 175 | t.accum <- t.accum + diff n t.state; 176 | t.state <- n 177 | ;; 178 | 179 | let write_probe_at t n = 180 | Protocol.Writer.write_probe_at t.probe n t.accum; 181 | t.accum <- 0; 182 | t.state <- n 183 | ;; 184 | 185 | let pause t = 186 | let n = Common.now Common.Offline_profiler ~reluctance:4 () in 187 | accumulate t n 188 | ;; 189 | 190 | let record t = 191 | let n = Common.now Common.Offline_profiler ~reluctance:2 () in 192 | write_probe_at t n 193 | ;; 194 | 195 | let stop t = 196 | let n = Common.now Common.Offline_profiler ~reluctance:2 () in 197 | accumulate t n; 198 | write_probe_at t n 199 | ;; 200 | 201 | let wrap_sync t f x = 202 | let state = stateless_start t in 203 | let r = 204 | try f x with 205 | | ex -> 206 | stateless_stop t state; 207 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync" 208 | in 209 | stateless_stop t state; 210 | r 211 | ;; 212 | 213 | let wrap_sync2 t f x y = 214 | let state = stateless_start t in 215 | let r = 216 | try f x y with 217 | | ex -> 218 | stateless_stop t state; 219 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync2" 220 | in 221 | stateless_stop t state; 222 | r 223 | ;; 224 | 225 | let wrap_sync3 t f x y z = 226 | let state = stateless_start t in 227 | let r = 228 | try f x y z with 229 | | ex -> 230 | stateless_stop t state; 231 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync3" 232 | in 233 | stateless_stop t state; 234 | r 235 | ;; 236 | 237 | let wrap_sync4 t f x y z w = 238 | let state = stateless_start t in 239 | let r = 240 | try f x y z w with 241 | | ex -> 242 | stateless_stop t state; 243 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync4" 244 | in 245 | stateless_stop t state; 246 | r 247 | ;; 248 | 249 | (* let wrap_async t f x = 250 | * let open Async in 251 | * let state = start_async t in 252 | * try_with ~run:`Now (fun () -> f x) >>= fun res -> 253 | * stop_async t state; 254 | * match res with 255 | * | Ok x -> return x 256 | * | Error ex -> Exn.reraise ex "Core_profiler Delta_timer.wrap_async" *) 257 | end 258 | 259 | module%bench Delta_timer = struct 260 | let () = Profiler.configure () ~don't_require_core_profiler_env:() 261 | let delta = Delta_timer.create ~name:"unittest" 262 | let started = Delta_timer.stateless_start delta 263 | let%bench "start_async" = Delta_timer.stateless_start delta 264 | let%bench "stop_async" = Delta_timer.stateless_stop delta started 265 | let%bench "start" = Delta_timer.start delta 266 | let%bench "stop" = Delta_timer.stop delta 267 | end 268 | 269 | module%bench [@name "Delta_timer.wrap_sync"] _ = struct 270 | let () = Profiler.configure () ~don't_require_core_profiler_env:() 271 | let nop () = () 272 | 273 | let wrapped_nop = 274 | let delta = Delta_timer.create ~name:"nop" in 275 | Delta_timer.wrap_sync delta nop 276 | ;; 277 | 278 | let count_256 () = 279 | for _ = 1 to 256 do 280 | () 281 | done 282 | ;; 283 | 284 | let wrapped_count_256 = 285 | let delta = Delta_timer.create ~name:"count_256" in 286 | Delta_timer.wrap_sync delta count_256 287 | ;; 288 | 289 | let%bench "nop" = nop () 290 | let%bench "wrapped_nop" = wrapped_nop () 291 | let%bench "count_256" = count_256 () 292 | let%bench "wrapped_count_256" = wrapped_count_256 () 293 | end 294 | 295 | (* stateless Delta_probe does not support pausing *) 296 | module Delta_probe = struct 297 | type state = int 298 | 299 | type t = 300 | { probe : Probe.t 301 | ; mutable state : state 302 | ; mutable accum : state 303 | } 304 | 305 | let create ~name ~units = { probe = Probe.create ~name ~units; state = 0; accum = 0 } 306 | let stateless_start _t value = value 307 | let stateless_stop t state value = Probe.record t.probe (value - state) 308 | let start t value = t.state <- value 309 | 310 | let record t = 311 | Probe.record t.probe t.accum; 312 | t.accum <- 0 313 | ;; 314 | 315 | let pause t value = t.accum <- t.accum + (value - t.state) 316 | 317 | let stop t value = 318 | pause t value; 319 | record t 320 | ;; 321 | end 322 | 323 | module%bench Delta_probe = struct 324 | let () = Profiler.configure () ~don't_require_core_profiler_env:() 325 | let delta = Delta_probe.create ~name:"unittest" ~units:Profiler_units.Int 326 | let started = Delta_probe.stateless_start delta 123 327 | let%bench "start" = Delta_probe.start delta 123 328 | let%bench "stop" = Delta_probe.stop delta 456 329 | let%bench "start_async" = Delta_probe.stateless_start delta 123 330 | let%bench "stop_async" = Delta_probe.stateless_stop delta started 456 331 | end 332 | -------------------------------------------------------------------------------- /src/offline.mli: -------------------------------------------------------------------------------- 1 | (** Running a program with offline metrics collection causes it to write out a data file 2 | on exit. This data file is typically called [profiler.dat]. The collected metrics can 3 | then be analyzed using [profiler-tool.exe]. 4 | 5 | I don't trust these numbers, but here they are: 6 | {v 7 | ┌──────────────────────────────────────────────────────┬──────────┬────────────┐ 8 | │ Name │ Time/Run │ Percentage │ 9 | ├──────────────────────────────────────────────────────┼──────────┼────────────┤ 10 | │ [offline.ml:Timer] at │ 18.29ns │ 10.34% │ 11 | │ [offline.ml:Probe] at │ 21.92ns │ 12.38% │ 12 | │ [offline.ml:Delta_timer] start_async │ 10.94ns │ 6.18% │ 13 | │ [offline.ml:Delta_timer] stop_async │ 22.78ns │ 12.87% │ 14 | │ [offline.ml:Delta_timer] start │ 11.23ns │ 6.34% │ 15 | │ [offline.ml:Delta_timer] stop │ 22.84ns │ 12.91% │ 16 | │ [offline.ml:Delta_timer.wrap_sync] nop │ 2.45ns │ 1.38% │ 17 | │ [offline.ml:Delta_timer.wrap_sync] wrapped_nop │ 40.59ns │ 22.93% │ 18 | │ [offline.ml:Delta_timer.wrap_sync] count_256 │ 143.57ns │ 81.12% │ 19 | │ [offline.ml:Delta_timer.wrap_sync] wrapped_count_256 │ 176.99ns │ 100.00% │ 20 | │ [offline.ml:Delta_probe] start │ 2.47ns │ 1.40% │ 21 | │ [offline.ml:Delta_probe] stop │ 22.11ns │ 12.49% │ 22 | │ [offline.ml:Delta_probe] start_async │ 2.44ns │ 1.38% │ 23 | │ [offline.ml:Delta_probe] stop_async │ 22.20ns │ 12.54% │ 24 | └──────────────────────────────────────────────────────┴──────────┴────────────┘ 25 | v} *) 26 | 27 | open! Core 28 | 29 | (** In [Offline], a [Delta_probe] differs from a two point [Group] in that for each 30 | start/stop pair, only one message is written to the buffer. This means that only the 31 | delta in the probe is available, as opposed to deltas in both probe and time. *) 32 | 33 | (** @inline *) 34 | include 35 | Core_profiler_disabled.Intf.Profiler_intf 36 | with type Timer.t = private int 37 | and type Probe.t = private int 38 | and type Delta_timer.state = private Time_ns.t 39 | and type Delta_probe.state = private int 40 | -------------------------------------------------------------------------------- /src/online.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | open Core_profiler_disabled 4 | module Time = Time_float_unix 5 | 6 | let debug = false 7 | 8 | type row = 9 | | Count_only of int 10 | | Stats of Fstats.t 11 | 12 | let row_stats = function 13 | | Count_only _ -> None 14 | | Stats st -> Some st 15 | ;; 16 | 17 | let row_is_empty = function 18 | | Count_only n -> n = 0 19 | | Stats st -> Fstats.samples st = 0 20 | ;; 21 | 22 | let all_rows : ((unit -> row) * Profiler_units.t) String.Map.t ref = ref String.Map.empty 23 | 24 | let columns = 25 | let fstats_count (_name, _units, row) = 26 | let count = 27 | match row with 28 | | Count_only n -> n 29 | | Stats st -> Fstats.samples st 30 | in 31 | Profiler_units.format_int Profiler_units.Int count 32 | in 33 | let fstats_fget getter (_name, units, row) = 34 | let open Option.Monad_infix in 35 | row_stats row 36 | >>| getter 37 | >>= Float.iround_nearest 38 | >>| Profiler_units.format_int units 39 | |> Option.value ~default:"" 40 | in 41 | Ascii_table. 42 | [ Column.create ~align:Left "name" fst3 43 | ; Column.create ~align:Right "count" fstats_count 44 | ; Column.create ~align:Right "sum" (fstats_fget Fstats.total) 45 | ; Column.create ~align:Right "mean" (fstats_fget Fstats.mean) 46 | ; Column.create ~align:Right "min" (fstats_fget Fstats.min) 47 | ; Column.create ~align:Right "max" (fstats_fget Fstats.max) 48 | ; Column.create ~align:Right "stdev" (fstats_fget Fstats.stdev) 49 | ] 50 | ;; 51 | 52 | (* If we ever create an online probe we expect this will be set. *) 53 | let we_are_using_online_profiler = ref false 54 | let online_profiler_is_used () = we_are_using_online_profiler := true 55 | 56 | (* Used for benchmarks, tests etc where we don't what the online outputs, we can disable 57 | the printing by setting this. *) 58 | let internal_disable_print = ref false 59 | 60 | (* Printing configuration supplied by the user. *) 61 | let print_enabled = 62 | let env = "PRINT_ENABLED" in 63 | let v = 64 | match Check_environment.get_var env with 65 | | Some "true" -> true 66 | | Some "false" -> false 67 | | Some v -> 68 | Core.printf "Unknown value for %s for %s, use true or false\n%!" v env; 69 | true 70 | | None -> true 71 | in 72 | ref v 73 | ;; 74 | 75 | (* Printing configuration supplied by the user. *) 76 | let print_interval = 77 | let env = "PRINT_INTERVAL" in 78 | let v = 79 | match Check_environment.get_var env with 80 | | Some v -> Int.of_string v 81 | | None -> 1 82 | in 83 | ref v 84 | ;; 85 | 86 | let online_print () = 87 | if (not !internal_disable_print) && !we_are_using_online_profiler 88 | then ( 89 | Core.printf !"%{Time}\n%!" (Time.now ()); 90 | let table = 91 | Map.fold_right !all_rows ~init:[] ~f:(fun ~key:name ~data:(row_fn, units) acc -> 92 | let row = row_fn () in 93 | if row_is_empty row then acc else (name, units, row) :: acc) 94 | in 95 | if not (List.is_empty table) 96 | then ( 97 | Ascii_table.output ~oc:Out_channel.stdout ~limit_width_to:150 columns table; 98 | Out_channel.flush Out_channel.stdout)) 99 | ;; 100 | 101 | let maybe_print = 102 | let last_print = ref (Common.now_no_calibrate ()) in 103 | fun () -> 104 | if !print_enabled 105 | then ( 106 | let now = Common.now_no_calibrate () in 107 | let diff = Time_ns.diff now !last_print |> Time_ns.Span.to_int_sec in 108 | if debug then Core.printf "print_interval = %d, diff = %d\n" !print_interval diff; 109 | if diff >= !print_interval 110 | then ( 111 | last_print := now; 112 | online_print ())) 113 | ;; 114 | 115 | let add_print_to_slow_tasks = 116 | let once = ref false in 117 | fun () -> 118 | if not !once 119 | then ( 120 | Common.add_slow_task Common.Online_profiler maybe_print; 121 | once := true) 122 | ;; 123 | 124 | let () = at_exit online_print 125 | 126 | let add_row : string -> (unit -> row) -> Profiler_units.t -> unit = 127 | add_print_to_slow_tasks (); 128 | fun name fn units -> all_rows := Map.set !all_rows ~key:name ~data:(fn, units) 129 | ;; 130 | 131 | let safe_to_delay () = Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:1 132 | 133 | module Profiler = struct 134 | let is_enabled = true 135 | let safe_to_delay = safe_to_delay 136 | let dump_stats = online_print 137 | 138 | let configure 139 | ?don't_require_core_profiler_env 140 | ?offline_profiler_data_file:_ 141 | ?online_print_time_interval_secs 142 | ?online_print_by_default 143 | () 144 | = 145 | Option.iter don't_require_core_profiler_env ~f:(fun () -> 146 | Check_environment.don't_require_core_profiler_env ()); 147 | Option.iter online_print_by_default ~f:(fun bool -> print_enabled := bool); 148 | Option.iter online_print_time_interval_secs ~f:(fun secs -> print_interval := secs) 149 | ;; 150 | end 151 | 152 | module Timer = struct 153 | module Single = struct 154 | type t = 155 | { name : string 156 | ; mutable count : int 157 | } 158 | 159 | let create name () = 160 | online_profiler_is_used (); 161 | Check_environment.check_safety_exn (); 162 | let t = { name; count = 0 } in 163 | add_row name (fun () -> Count_only t.count) Profiler_units.Int; 164 | t 165 | ;; 166 | 167 | let record t = 168 | t.count <- t.count + 1; 169 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:3 170 | ;; 171 | end 172 | 173 | module Raw_group = struct 174 | type t = 175 | { name : string (* [session] is initialised to 0 *) 176 | ; mutable session : int 177 | } 178 | 179 | let create ~name = 180 | online_profiler_is_used (); 181 | { name; session = 0 } 182 | ;; 183 | 184 | let reset group = 185 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:2; 186 | group.session <- group.session + 1 187 | ;; 188 | end 189 | 190 | module Group_probe = struct 191 | type t = 192 | { name : string 193 | ; group : Raw_group.t 194 | ; sources : (t * Fstats.t) array (* [session] is initialised to -1 *) 195 | ; mutable session : int 196 | (* [last_time] is initalised to the epoch; the value won't be used since session 197 | won't match *) 198 | ; mutable last_time : Time_ns.t 199 | } 200 | 201 | let record t = 202 | let n = Common.now Common.Online_profiler ~reluctance:4 () in 203 | let gsession = t.group.session in 204 | for i = 0 to Array.length t.sources - 1 do 205 | let src, stats = t.sources.(i) in 206 | if src.session = gsession 207 | then 208 | Time_ns.diff n src.last_time 209 | |> Time_ns.Span.to_int_ns 210 | |> float 211 | |> Fstats.update_in_place stats 212 | done; 213 | t.last_time <- n; 214 | t.session <- gsession 215 | ;; 216 | 217 | let create group ~sources ~name = 218 | online_profiler_is_used (); 219 | Check_environment.check_safety_exn (); 220 | let probe = 221 | { name 222 | ; group 223 | ; sources = Array.map sources ~f:(fun src -> src, Fstats.create ()) 224 | ; last_time = Time_ns.epoch 225 | ; session = -1 226 | } 227 | in 228 | Array.iter probe.sources ~f:(fun (src, stats) -> 229 | let row_name = group.name ^ ":" ^ src.name ^ "," ^ name in 230 | add_row row_name (fun () -> Stats (Fstats.copy stats)) Profiler_units.Nanoseconds); 231 | probe 232 | ;; 233 | end 234 | 235 | type t = 236 | | Single of Single.t 237 | | Group_probe of Group_probe.t 238 | 239 | type probe = t 240 | 241 | let create ~name = Single (Single.create name ()) 242 | 243 | let record = function 244 | | Single t -> Single.record t 245 | | Group_probe t -> Group_probe.record t 246 | ;; 247 | 248 | module Group = struct 249 | include Raw_group 250 | 251 | let add_probe t ?(sources = [||]) ~name () = 252 | let sources = 253 | Array.map sources ~f:(fun (src : probe) -> 254 | match src with 255 | | Single _ -> failwith "Probe sources must come from the same group" 256 | | Group_probe src -> 257 | if src.group <> t 258 | then failwith "Probe sources must come from the same group" 259 | else src) 260 | in 261 | Group_probe (Group_probe.create t ~sources ~name) 262 | ;; 263 | end 264 | end 265 | 266 | module%bench Timer = struct 267 | let timer = Timer.create ~name:"bench_timer" 268 | let group = Timer.Group.create ~name:"bench_timer_group" 269 | let group_probe0 = Timer.Group.add_probe group ~name:"bench_timer_group_probe0" () 270 | 271 | let group_probe1 = 272 | Timer.Group.add_probe 273 | group 274 | ~name:"bench_timer_group_probe1" 275 | () 276 | ~sources:[| group_probe0 |] 277 | ;; 278 | 279 | let group_probe2 = 280 | Timer.Group.add_probe 281 | group 282 | ~name:"bench_timer_group_probe2" 283 | () 284 | ~sources:[| group_probe0; group_probe1 |] 285 | ;; 286 | 287 | let () = 288 | Timer.record group_probe0; 289 | Timer.record group_probe1; 290 | Timer.record group_probe2 291 | ;; 292 | 293 | let%bench "at" = Timer.record timer 294 | let%bench "group_probe_at (0 sources)" = Timer.record group_probe0 295 | let%bench "group_probe_at (1 sources)" = Timer.record group_probe1 296 | let%bench "group_probe_at (2 sources)" = Timer.record group_probe2 297 | let group2 = Timer.Group.create ~name:"bench_timer_group2" 298 | let%bench "group_reset" = Timer.Group.reset group2 299 | let () = internal_disable_print := true 300 | end 301 | 302 | module Probe = struct 303 | (* A probe doesn't need to know its name, so we can save an indirection. *) 304 | module Single = struct 305 | type t = Fstats.t 306 | 307 | let create name units = 308 | online_profiler_is_used (); 309 | Check_environment.check_safety_exn (); 310 | let t = Fstats.create () in 311 | add_row name (fun () -> Stats (Fstats.copy t)) units; 312 | t 313 | ;; 314 | 315 | let record t value = 316 | Fstats.update_in_place t (float value); 317 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:3 318 | ;; 319 | end 320 | 321 | module Raw_group = struct 322 | type t = 323 | { name : string 324 | ; units : Profiler_units.t (* [session] is initialised to 0 *) 325 | ; mutable session : int 326 | } 327 | 328 | let create ~name ~units = 329 | online_profiler_is_used (); 330 | { name; units; session = 0 } 331 | ;; 332 | 333 | let reset group = 334 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:2; 335 | group.session <- group.session + 1 336 | ;; 337 | end 338 | 339 | module Group_probe = struct 340 | type t = 341 | { name : string 342 | ; group : Raw_group.t 343 | ; sources : (t * Fstats.t) array (* See [Timer.Group.Probe.t] *) 344 | ; mutable session : int 345 | ; mutable last_value : int 346 | } 347 | 348 | let create group ~sources ~name = 349 | online_profiler_is_used (); 350 | Check_environment.check_safety_exn (); 351 | let probe = 352 | { name 353 | ; group 354 | ; sources = Array.map sources ~f:(fun src -> src, Fstats.create ()) 355 | ; last_value = 0 356 | ; session = -1 357 | } 358 | in 359 | Array.iter probe.sources ~f:(fun (src, stats) -> 360 | let row_name = group.name ^ ":" ^ src.name ^ "," ^ name in 361 | add_row row_name (fun () -> Stats (Fstats.copy stats)) group.units); 362 | probe 363 | ;; 364 | 365 | let record t value = 366 | let gsession = t.group.session in 367 | (* Using Array.iter would cause allocation of a closure *) 368 | for i = 0 to Array.length t.sources - 1 do 369 | let src, stats = t.sources.(i) in 370 | if src.session = gsession 371 | then Fstats.update_in_place stats (float (value - src.last_value)) 372 | done; 373 | t.last_value <- value; 374 | t.session <- gsession; 375 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:4 376 | ;; 377 | end 378 | 379 | type t = 380 | | Single of Single.t 381 | | Group_probe of Group_probe.t 382 | 383 | type probe = t 384 | 385 | let create ~name ~units = Single (Single.create name units) 386 | 387 | let record t value = 388 | match t with 389 | | Single t -> Single.record t value 390 | | Group_probe t -> Group_probe.record t value 391 | ;; 392 | 393 | module Group = struct 394 | include Raw_group 395 | 396 | let add_probe t ?(sources = [||]) ~name () = 397 | let sources = 398 | Array.map sources ~f:(fun (src : probe) -> 399 | match src with 400 | | Single _ -> failwith "Probe sources must come from the same group" 401 | | Group_probe src -> 402 | if src.group <> t 403 | then failwith "Probe sources must come from the same group" 404 | else src) 405 | in 406 | Group_probe (Group_probe.create t ~sources ~name) 407 | ;; 408 | end 409 | end 410 | 411 | module%bench Probe = struct 412 | let probe = Probe.create ~name:"bench_probe" ~units:Profiler_units.Seconds 413 | let group = Probe.Group.create ~name:"bench_probe_group" ~units:Profiler_units.Words 414 | let group_probe0 = Probe.Group.add_probe group ~name:"bench_probe_group_probe0" () 415 | 416 | let group_probe1 = 417 | Probe.Group.add_probe 418 | group 419 | ~name:"bench_probe_group_probe1" 420 | ~sources:[| group_probe0 |] 421 | () 422 | ;; 423 | 424 | let group_probe2 = 425 | Probe.Group.add_probe 426 | group 427 | ~name:"bench_probe_group_probe2" 428 | ~sources:[| group_probe0; group_probe1 |] 429 | () 430 | ;; 431 | 432 | let () = 433 | Probe.record group_probe0 2; 434 | Probe.record group_probe1 3; 435 | Probe.record group_probe2 4 436 | ;; 437 | 438 | let%bench "at" = Probe.record probe 10 439 | let%bench "group_probe_at (0 sources)" = Probe.record group_probe0 5 440 | let%bench "group_probe_at (1 sources)" = Probe.record group_probe1 6 441 | let%bench "group_probe_at (2 sources)" = Probe.record group_probe2 7 442 | let group2 = Probe.Group.create ~name:"bench_probe_group2" ~units:Profiler_units.Int 443 | let%bench "group_reset" = Probe.Group.reset group2 444 | let () = internal_disable_print := true 445 | end 446 | 447 | (* stateless Delta_timer does not support pausing *) 448 | module Delta_timer = struct 449 | type state = Time_ns.t 450 | 451 | type t = 452 | { name : string 453 | ; stats : Fstats.t 454 | ; mutable state : state 455 | ; mutable accum : int 456 | } 457 | 458 | let create ~name = 459 | let t = { name; stats = Fstats.create (); state = Time_ns.epoch; accum = 0 } in 460 | online_profiler_is_used (); 461 | add_row name (fun () -> Stats (Fstats.copy t.stats)) Profiler_units.Nanoseconds; 462 | t 463 | ;; 464 | 465 | let diff n state = Time_ns.diff n state |> Time_ns.Span.to_int_ns 466 | let update_in_place t d = Fstats.update_in_place t.stats (float d) 467 | 468 | let update_in_place_and_reset_accum t d = 469 | update_in_place t d; 470 | t.accum <- 0 471 | ;; 472 | 473 | let stateless_start _ = Common.now Common.Online_profiler ~reluctance:4 () 474 | 475 | let stateless_stop t state = 476 | let n = Common.now Common.Online_profiler ~reluctance:4 () in 477 | let d = diff n state in 478 | update_in_place t d 479 | ;; 480 | 481 | let start t = t.state <- Common.now Common.Online_profiler ~reluctance:4 () 482 | 483 | let pause t = 484 | let n = Common.now Common.Online_profiler ~reluctance:4 () in 485 | t.accum <- t.accum + diff n t.state 486 | ;; 487 | 488 | let record t = 489 | update_in_place_and_reset_accum t t.accum; 490 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:2 491 | ;; 492 | 493 | let stop t = 494 | pause t; 495 | update_in_place_and_reset_accum t t.accum 496 | ;; 497 | 498 | let wrap_sync t f x = 499 | let state = stateless_start t in 500 | let r = 501 | try f x with 502 | | ex -> 503 | stateless_stop t state; 504 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync" 505 | in 506 | stateless_stop t state; 507 | r 508 | ;; 509 | 510 | let wrap_sync2 t f x y = 511 | let state = stateless_start t in 512 | let r = 513 | try f x y with 514 | | ex -> 515 | stateless_stop t state; 516 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync2" 517 | in 518 | stateless_stop t state; 519 | r 520 | ;; 521 | 522 | let wrap_sync3 t f x y z = 523 | let state = stateless_start t in 524 | let r = 525 | try f x y z with 526 | | ex -> 527 | stateless_stop t state; 528 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync3" 529 | in 530 | stateless_stop t state; 531 | r 532 | ;; 533 | 534 | let wrap_sync4 t f x y z w = 535 | let state = stateless_start t in 536 | let r = 537 | try f x y z w with 538 | | ex -> 539 | stateless_stop t state; 540 | Exn.reraise ex "Core_profiler Delta_timer.wrap_sync4" 541 | in 542 | stateless_stop t state; 543 | r 544 | ;; 545 | 546 | (* let wrap_async t f x = 547 | * let open Async in 548 | * let state = start_async t in 549 | * try_with ~run:`Now (fun () -> f x) >>= fun res -> 550 | * stop_async t state; 551 | * match res with 552 | * | Ok x -> return x 553 | * | Error ex -> Exn.reraise ex "Core_profiler Delta_timer.wrap_async" *) 554 | end 555 | 556 | module%bench Delta_timer = struct 557 | let delta = Delta_timer.create ~name:"unittest" 558 | let started = Delta_timer.stateless_start delta 559 | let%bench "stateless_start" = Delta_timer.stateless_start delta 560 | let%bench "stateless_stop" = Delta_timer.stateless_stop delta started 561 | let%bench "start" = Delta_timer.start delta 562 | let%bench "stop" = Delta_timer.stop delta 563 | let () = internal_disable_print := true 564 | end 565 | 566 | module%bench [@name "Delta_timer.wrap_sync"] _ = struct 567 | let nop () = () 568 | 569 | let wrapped_nop = 570 | let delta = Delta_timer.create ~name:"nop" in 571 | Delta_timer.wrap_sync delta nop 572 | ;; 573 | 574 | let count_256 () = 575 | for _ = 1 to 256 do 576 | () 577 | done 578 | ;; 579 | 580 | let wrapped_count_256 = 581 | let delta = Delta_timer.create ~name:"count_256" in 582 | Delta_timer.wrap_sync delta count_256 583 | ;; 584 | 585 | let%bench "nop" = nop () 586 | let%bench "wrapped_nop" = wrapped_nop () 587 | let%bench "count_256" = count_256 () 588 | let%bench "wrapped_count_256" = wrapped_count_256 () 589 | let () = internal_disable_print := true 590 | end 591 | 592 | (* stateless Delta_probe does not support pausing *) 593 | module Delta_probe = struct 594 | type state = int 595 | 596 | type t = 597 | { name : string 598 | ; stats : Fstats.t 599 | ; mutable state : state 600 | ; mutable accum : state 601 | } 602 | 603 | let create ~name ~units = 604 | let t = { name; stats = Fstats.create (); state = 0; accum = 0 } in 605 | online_profiler_is_used (); 606 | add_row name (fun () -> Stats (Fstats.copy t.stats)) units; 607 | t 608 | ;; 609 | 610 | let stateless_start _ value = value 611 | 612 | let stateless_stop t state value = 613 | Fstats.update_in_place t.stats (float (value - state)); 614 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:3 615 | ;; 616 | 617 | let start t value = t.state <- value 618 | let pause t value = t.accum <- t.accum + value - t.state 619 | 620 | let record t = 621 | Fstats.update_in_place t.stats (float t.accum); 622 | t.accum <- 0; 623 | Common.maybe_do_slow_tasks Common.Online_profiler ~reluctance:3 624 | ;; 625 | 626 | let stop t value = 627 | pause t value; 628 | record t 629 | ;; 630 | end 631 | 632 | module%bench Delta_probe = struct 633 | let delta = Delta_probe.create ~name:"unittest" ~units:Profiler_units.Int 634 | let started = Delta_probe.stateless_start delta 123 635 | let%bench "start" = Delta_probe.start delta 123 636 | let%bench "stop" = Delta_probe.stop delta 456 637 | let%bench "start_async" = Delta_probe.stateless_start delta 123 638 | let%bench "stop_async" = Delta_probe.stateless_stop delta started 456 639 | let () = internal_disable_print := true 640 | end 641 | -------------------------------------------------------------------------------- /src/online.mli: -------------------------------------------------------------------------------- 1 | (** Use this module for online tracking of perf metrics. When using this module, the 2 | metrics are written out to stdout every second. There is no mertric file generated for 3 | offline analysis. The rate at which metrics are dumped to stdout is controlled by the 4 | environment variable [CORE_PROFILER=PRINT_INTERVAL=N] where [N] is the integer number 5 | of seconds to wait between outputs. 6 | 7 | [Profiler.don't_check_env] is a no-op, provided for compatibility with [Offline]'s 8 | interface. [Time_stamp_counter] calibration is liable to happen occasionally when 9 | calling [at]. [safe_to_delay] checks if it will be necessary soon, and does it in 10 | advance. If possible, call [safe_to_delay] (fairly regularly) from a time-insensitive 11 | point in code (or at least, outside any deltas / groups) to reduce the number of 12 | spurious jumps in time deltas. 13 | 14 | This is how much the online probes cost. I don't know how much I trust these metrics, 15 | but here they are: 16 | 17 | + ./inline_benchmarks_runner -q 3 -mat online 18 | ┌─────────────────────────────────────────────────────┬──────────┬────────────┐ │ 19 | Name │ Time/Run │ Percentage │ 20 | ├─────────────────────────────────────────────────────┼──────────┼────────────┤ │ 21 | [online.ml:Fstats:Fstats] update_in_place │ 12.96ns │ 6.94% │ │ [online.ml:Timer] at 22 | │ 11.56ns │ 6.19% │ │ [online.ml:Timer] group_point_at (0 sources) │ 13.31ns │ 7.13% 23 | │ │ [online.ml:Timer] group_point_at (1 sources) │ 22.91ns │ 12.27% │ │ 24 | [online.ml:Timer] group_point_at (2 sources) │ 40.45ns │ 21.66% │ │ 25 | [online.ml:Timer] group_reset │ 11.58ns │ 6.20% │ │ [online.ml:Probe] at │ 17.94ns │ 26 | 9.61% │ │ [online.ml:Probe] group_point_at (0 sources) │ 12.03ns │ 6.44% │ │ 27 | [online.ml:Probe] group_point_at (1 sources) │ 21.35ns │ 11.43% │ │ 28 | [online.ml:Probe] group_point_at (2 sources) │ 32.17ns │ 17.22% │ │ 29 | [online.ml:Probe] group_reset │ 11.32ns │ 6.06% │ │ [online.ml:Delta_timer] 30 | start_async │ 11.52ns │ 6.17% │ │ [online.ml:Delta_timer] stop_async │ 21.99ns │ 31 | 11.77% │ │ [online.ml:Delta_timer] start │ 11.63ns │ 6.23% │ │ 32 | [online.ml:Delta_timer] stop │ 21.99ns │ 11.77% │ │ 33 | [online.ml:Delta_timer.wrap_sync] nop │ 2.87ns │ 1.54% │ │ 34 | [online.ml:Delta_timer.wrap_sync] wrapped_nop │ 45.51ns │ 24.37% │ │ 35 | [online.ml:Delta_timer.wrap_sync] count_256 │ 146.13ns │ 78.25% │ │ 36 | [online.ml:Delta_timer.wrap_sync] wrapped_count_256 │ 186.75ns │ 100.00% │ │ 37 | [online.ml:Delta_probe] start │ 3.16ns │ 1.69% │ │ [online.ml:Delta_probe] stop │ 38 | 17.59ns │ 9.42% │ │ [online.ml:Delta_probe] start_async │ 2.96ns │ 1.58% │ │ 39 | [online.ml:Delta_probe] stop_async │ 17.26ns │ 9.24% │ 40 | └─────────────────────────────────────────────────────┴──────────┴────────────┘ *) 41 | 42 | open! Core 43 | 44 | include 45 | Core_profiler_disabled.Intf.Profiler_intf 46 | with type Delta_timer.state = private Time_ns.t 47 | and type Delta_probe.state = private int 48 | -------------------------------------------------------------------------------- /src/probe_id.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module T = struct 4 | type t = int [@@deriving bin_io, compare, sexp, hash] 5 | 6 | let to_string = Int.to_string 7 | let of_string = Int.of_string 8 | let module_name = "Core_profiler.Common.Id" 9 | end 10 | 11 | include T 12 | include Identifiable.Make (T) 13 | 14 | let of_int_exn = Fn.id 15 | let to_int_exn = Fn.id 16 | let counter = ref (-1) 17 | 18 | let create () = 19 | incr counter; 20 | !counter 21 | ;; 22 | -------------------------------------------------------------------------------- /src/probe_id.mli: -------------------------------------------------------------------------------- 1 | (** Timer, Probe, Groups and Group points are all assigned globally unique [Id.t]s. *) 2 | 3 | open! Core 4 | 5 | (** Each probe ([Intf.S]) has a unique [Probe_id.t] assigned. *) 6 | type t = private int [@@deriving bin_io, compare, sexp] 7 | 8 | include Intable with type t := t 9 | include Identifiable.S with type t := t 10 | 11 | (** [create] returns a [Id.t] unique within this process *) 12 | val create : unit -> t 13 | -------------------------------------------------------------------------------- /src/probe_type.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler_disabled 3 | 4 | type t = 5 | | Timer 6 | | Probe of Profiler_units.t 7 | [@@deriving sexp, compare] 8 | 9 | let to_string = function 10 | | Timer -> "Timer" 11 | | Probe u -> "Probe " ^ Profiler_units.to_string u 12 | ;; 13 | 14 | let to_char = function 15 | | Timer -> 'M' 16 | | Probe Words -> 'W' 17 | | Probe Seconds -> 'S' 18 | | Probe Nanoseconds -> 'N' 19 | | Probe Int -> 'O' 20 | ;; 21 | 22 | let of_char = function 23 | | 'M' -> Timer 24 | | 'W' -> Probe Words 25 | | 'S' -> Probe Seconds 26 | | 'N' -> Probe Nanoseconds 27 | | 'O' -> Probe Int 28 | | _ -> failwith "Invalid Spec character" 29 | ;; 30 | 31 | let is_probe = function 32 | | Timer -> false 33 | | Probe _ -> true 34 | ;; 35 | 36 | let units = function 37 | | Timer -> None 38 | | Probe u -> Some u 39 | ;; 40 | -------------------------------------------------------------------------------- /src/probe_type.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Core_profiler_disabled 3 | 4 | (** Type of a probe ([Intf.S]). *) 5 | type t = 6 | | Timer 7 | | Probe of Profiler_units.t 8 | [@@deriving sexp, compare] 9 | 10 | val to_string : t -> string 11 | val to_char : t -> char 12 | val of_char : char -> t 13 | val is_probe : t -> bool 14 | val units : t -> Profiler_units.t option 15 | -------------------------------------------------------------------------------- /src/profiler_epoch.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Time_ns = Time_ns_unix 3 | 4 | type t = Time_ns.t [@@deriving sexp] 5 | 6 | let of_time = Fn.id 7 | let to_time = Fn.id 8 | let add t x = Time_ns.add t x 9 | let diff t x = Time_ns.diff x t 10 | let of_int = Time_ns.of_int_ns_since_epoch 11 | let to_int = Time_ns.to_int_ns_since_epoch 12 | let to_string = Time_ns.to_string 13 | -------------------------------------------------------------------------------- /src/profiler_epoch.mli: -------------------------------------------------------------------------------- 1 | (** [Time_ns] and [Time] represents time since 1970 (the unix epoch). When writing out 2 | perf mertics, we don't have enough bits to express nanos since the unix epch. Instead 3 | we record an arbitrary point of time as the [Profiler_epoch.t]. Times can be stored 4 | with respect to this epoch. 5 | 6 | In the offline protocol, in order to save space in the header, an 'epoch' is written 7 | to the header, and times are stored as an offset from this epoch. (See also: 8 | [Protocol.Short_header]) *) 9 | 10 | open! Core 11 | 12 | type t [@@deriving sexp] 13 | 14 | val of_time : Time_ns.t -> t 15 | val to_time : t -> Time_ns.t 16 | val add : t -> Time_ns.Span.t -> Time_ns.t 17 | val diff : t -> Time_ns.t -> Time_ns.Span.t 18 | val of_int : int -> t 19 | val to_int : t -> int 20 | val to_string : t -> string 21 | -------------------------------------------------------------------------------- /src/protocol.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Core_profiler_disabled 3 | module Unix = Core_unix 4 | module Time_ns = Time_ns_unix 5 | 6 | let debug = false 7 | let default_output_filename = "profiler.dat" 8 | 9 | let current_output_filename = 10 | let env = "OUTPUT_FILE" in 11 | let v = 12 | match Check_environment.get_var env with 13 | | Some v -> v 14 | | None -> default_output_filename 15 | in 16 | if debug then printf "file = %s\n" v; 17 | ref v 18 | ;; 19 | 20 | let set_current_output_filename v = current_output_filename := v 21 | 22 | module Short_header : sig 23 | val id_bits : int 24 | val time_bits : int 25 | val max_id : int 26 | val max_time_diff : Time_ns.Span.t 27 | val pack_exn : Profiler_epoch.t -> Probe_id.t -> Time_ns.t -> int 28 | val pack_unsafe : Profiler_epoch.t -> Probe_id.t -> Time_ns.t -> int 29 | val unpack_id : int -> Probe_id.t 30 | val unpack_time : Profiler_epoch.t -> int -> Time_ns.t 31 | val unpack : Profiler_epoch.t -> int -> Probe_id.t * Time_ns.t 32 | end = struct 33 | let time_bits = 54 (* ~208 days *) 34 | let%test _ = time_bits > 1 35 | let%test _ = time_bits < 63 36 | let id_bits = 63 - time_bits (* you may need to change the size of header_chunk *) 37 | let max_id = (1 lsl id_bits) - 1 38 | let max_time_diff_int = (1 lsl time_bits) - 1 39 | let max_time_diff = Time_ns.Span.of_int_ns max_time_diff_int 40 | 41 | let pack_exn epoch id time = 42 | let id = Probe_id.to_int_exn id in 43 | let time = Profiler_epoch.diff epoch time |> Time_ns.Span.to_int_ns in 44 | if time < 0 || time > max_time_diff_int || id < 0 || id > max_id 45 | then raise (Invalid_argument "parameter out of range") 46 | else time lor (id lsl time_bits) 47 | ;; 48 | 49 | let pack_unsafe epoch id time = 50 | let id = Probe_id.to_int_exn id in 51 | let time = Profiler_epoch.diff epoch time |> Time_ns.Span.to_int_ns in 52 | time land ((1 lsl time_bits) - 1) lor (id lsl time_bits) 53 | ;; 54 | 55 | let unpack_id header = header lsr time_bits |> Probe_id.of_int_exn 56 | 57 | let unpack_time epoch header = 58 | header land ((1 lsl time_bits) - 1) 59 | |> Time_ns.Span.of_int_ns 60 | |> Profiler_epoch.add epoch 61 | ;; 62 | 63 | let unpack epoch header = unpack_id header, unpack_time epoch header 64 | 65 | module%test [@name "unpack_pack"] _ = struct 66 | let epoch = 67 | Profiler_epoch.of_time 68 | (Time_ns.of_int_ns_since_epoch (Int64.to_int_exn 1405085600000000000L)) 69 | ;; 70 | 71 | let test id time = 72 | let id = Probe_id.of_int_exn id in 73 | let time = Time_ns.of_int_ns_since_epoch (Int64.to_int_exn time) in 74 | let packed = pack_exn epoch id time in 75 | let packed_unsafe = pack_unsafe epoch id time in 76 | let unpacked = unpack epoch packed_unsafe in 77 | [%test_eq: int] packed packed_unsafe; 78 | [%test_eq: Probe_id.t * Time_ns.t] unpacked (id, time) 79 | ;; 80 | 81 | let%test_unit "0 0" = test 0 1405085600000000000L 82 | let%test_unit "max max" = test 511 1423099998509481983L 83 | let%test_unit "1 1" = test 1 1405085600000000001L 84 | let%test_unit "256 100_000" = test 256 1405085600000100000L 85 | end 86 | 87 | module%bench [@name "Short message header packing"] _ = struct 88 | let epoch = 89 | Profiler_epoch.of_time 90 | (Time_ns.of_int_ns_since_epoch (Int64.to_int_exn 1405085600000000000L)) 91 | ;; 92 | 93 | let id = Probe_id.of_int_exn 123 94 | let time = Time_ns.of_int_ns_since_epoch (Int64.to_int_exn 1405085600123123000L) 95 | let%bench "pack_exn" = ignore (pack_exn epoch id time : int) 96 | let%bench "pack_unsafe" = ignore (pack_unsafe epoch id time : int) 97 | end 98 | end 99 | 100 | module Buffer : sig 101 | (* read_write buffers are exposed to Writer *) 102 | val header_chunk : (read_write, _) Iobuf.t Lazy.t 103 | val current_chunk : (read_write, _) Iobuf.t 104 | 105 | (* These are public: *) 106 | 107 | (** Is the main (short message) buffer empty? *) 108 | val is_empty : unit -> bool 109 | 110 | val get_chunks : unit -> (read_write, Iobuf.no_seek) Iobuf.t list 111 | val get_header_chunk : unit -> (read, _) Iobuf.t 112 | val ensure_free : int -> unit 113 | 114 | module Unsafe_internals : sig 115 | val reset : unit -> unit 116 | end 117 | end = struct 118 | (* If we create 512 group points with every other point as a source, 119 | this buffer _still_ won't fill up (512 * (72 + 512 * 2)) *) 120 | let header_chunk = lazy (Iobuf.create ~len:561152) 121 | 122 | let get_header_chunk () = 123 | let copy = Iobuf.create ~len:0 in 124 | if Lazy.is_val header_chunk 125 | then ( 126 | Iobuf.set_bounds_and_buffer ~src:(Lazy.force header_chunk) ~dst:copy; 127 | Iobuf.flip_lo copy); 128 | (copy :> (read, _) Iobuf.t) 129 | ;; 130 | 131 | (* Iobufs are mutable to the extent that you can swap the pointer to the underlying 132 | memory with another Iobuf. I use this to avoid a [ref] / another indirection: 133 | When we want to swap the buffer, we copy its pointer & limits into a new [Iobuf.t] 134 | structure, and then overwrite it with the pointer & limits from a freshly created 135 | [Iobuf.t] *) 136 | let current_chunk = Iobuf.create ~len:0 137 | let chunk_size = 10_000_000 138 | let previous_chunks = ref [] 139 | 140 | let allocate_new_chunk len = 141 | Iobuf.flip_lo current_chunk; 142 | if not (Iobuf.is_empty current_chunk) 143 | then ( 144 | (* Use sub to copy the Iobuf.t structure (and narrow the chunk in the process). *) 145 | let copy = Iobuf.sub_shared current_chunk in 146 | previous_chunks := copy :: !previous_chunks); 147 | let new_memory = Iobuf.create ~len in 148 | Iobuf.set_bounds_and_buffer ~src:new_memory ~dst:current_chunk; 149 | (* We need to force the kernel to actually give us the memory, or we're liable to 150 | get spikes in poke times. *) 151 | if len > 0 152 | then 153 | for i = 0 to (len - 1) / 512 do 154 | Iobuf.Unsafe.Poke.uint8_trunc current_chunk ~pos:(i * 512) 0 155 | done 156 | ;; 157 | 158 | let ensure_free len = 159 | assert (len <= chunk_size); 160 | if Iobuf.length current_chunk < len then allocate_new_chunk chunk_size 161 | ;; 162 | 163 | let get_chunks () = 164 | (* ... thereby moving the curent chunk into [previous_chunks] *) 165 | allocate_new_chunk 0; 166 | List.rev !previous_chunks 167 | ;; 168 | 169 | let is_empty () = List.is_empty (get_chunks ()) 170 | 171 | module Unsafe_internals = struct 172 | let reset () = 173 | if Lazy.is_val header_chunk then Iobuf.reset (Lazy.force header_chunk); 174 | allocate_new_chunk 0; 175 | previous_chunks := [] 176 | ;; 177 | end 178 | 179 | let%test_unit "allocate_new_chunk" = 180 | protect 181 | ~f:(fun () -> 182 | allocate_new_chunk 1000; 183 | [%test_eq: int] (Iobuf.length current_chunk) 1000; 184 | Iobuf.Fill.stringo current_chunk "the first chunk\n"; 185 | Iobuf.Fill.stringo current_chunk "still the first chunk\n"; 186 | allocate_new_chunk 500; 187 | allocate_new_chunk 500; 188 | (* empty, should be ignored *) 189 | Iobuf.Fill.stringo current_chunk "the second chunk\n"; 190 | allocate_new_chunk 0; 191 | [%test_eq: int] (Iobuf.length current_chunk) 0; 192 | [%test_eq: int] (List.length !previous_chunks) 2; 193 | match !previous_chunks with 194 | | [ second; first ] -> 195 | [%test_eq: string] 196 | (Iobuf.to_string first) 197 | "the first chunk\nstill the first chunk\n"; 198 | [%test_eq: string] (Iobuf.to_string second) "the second chunk\n" 199 | | _ -> assert false) 200 | ~finally:Unsafe_internals.reset 201 | ;; 202 | 203 | let%test_unit "ensure_free" = 204 | protect 205 | ~f:(fun () -> 206 | ensure_free 100; 207 | [%test_eq: int] (Iobuf.length current_chunk) chunk_size; 208 | [%test_eq: int] (List.length !previous_chunks) 0; 209 | Iobuf.advance current_chunk (chunk_size - 50); 210 | ensure_free 500; 211 | [%test_eq: int] (Iobuf.length current_chunk) chunk_size; 212 | [%test_eq: int] (List.length !previous_chunks) 1) 213 | ~finally:Unsafe_internals.reset 214 | ;; 215 | 216 | let%test_unit "get_header_chunk" = 217 | protect 218 | ~f:(fun () -> 219 | let header_chunk = Lazy.force header_chunk in 220 | Iobuf.Fill.stringo header_chunk "some data"; 221 | let contents = get_header_chunk () |> Iobuf.to_string in 222 | [%test_eq: string] contents "some data") 223 | ~finally:Unsafe_internals.reset 224 | ;; 225 | 226 | let%test_unit "get_chunks" = 227 | protect 228 | ~f:(fun () -> 229 | allocate_new_chunk 1000; 230 | Iobuf.Fill.stringo current_chunk "the first chunk"; 231 | allocate_new_chunk 1000; 232 | Iobuf.Fill.stringo current_chunk "the second chunk"; 233 | let contents = get_chunks () |> List.map ~f:(fun buf -> Iobuf.to_string buf) in 234 | [%test_eq: string list] contents [ "the first chunk"; "the second chunk" ]) 235 | ~finally:Unsafe_internals.reset 236 | ;; 237 | end 238 | 239 | module Writer = struct 240 | let epoch = 241 | Time_ns.now () 242 | |> Fn.flip Time_ns.sub (Time_ns.Span.of_min 1.) 243 | |> Profiler_epoch.of_time 244 | ;; 245 | 246 | let max_time = Profiler_epoch.add epoch Short_header.max_time_diff 247 | 248 | let write_epoch () = 249 | let header_chunk = Lazy.force Buffer.header_chunk in 250 | let written = Header_protocol.Epoch.write ~epoch header_chunk in 251 | Iobuf.advance header_chunk written 252 | ;; 253 | 254 | let write_end_of_header () = 255 | let header_chunk = Lazy.force Buffer.header_chunk in 256 | let written = Header_protocol.End_of_header.write header_chunk in 257 | Iobuf.advance header_chunk written 258 | ;; 259 | 260 | let write_new_single id name spec = 261 | let header_chunk = Lazy.force Buffer.header_chunk in 262 | let written = Header_protocol.New_single.write ~id ~spec ~name header_chunk in 263 | Iobuf.advance header_chunk written 264 | ;; 265 | 266 | let write_new_group id name spec = 267 | let header_chunk = Lazy.force Buffer.header_chunk in 268 | let written = Header_protocol.New_group.write ~id ~spec ~name header_chunk in 269 | Iobuf.advance header_chunk written 270 | ;; 271 | 272 | let write_new_group_point ~group_id ~id name sources = 273 | let header_chunk = Lazy.force Buffer.header_chunk in 274 | let module NPP = Header_protocol.New_group_point in 275 | let sources_count = Array.length sources in 276 | let len = NPP.write ~group_id ~id ~name ~sources_count header_chunk in 277 | Array.iteri sources ~f:(fun index id -> 278 | NPP.write_sources header_chunk ~count:sources_count ~index ~source_id:id); 279 | Iobuf.advance header_chunk len 280 | ;; 281 | 282 | let write_timer_at id time = 283 | Buffer.ensure_free 8; 284 | Iobuf.Unsafe.Fill.int64_le 285 | Buffer.current_chunk 286 | (Short_header.pack_unsafe epoch id time) 287 | ;; 288 | 289 | let write_probe_at id time value = 290 | let current_chunk = Buffer.current_chunk in 291 | Buffer.ensure_free 16; 292 | Iobuf.Unsafe.Poke.int64_le 293 | current_chunk 294 | ~pos:0 295 | (Short_header.pack_unsafe epoch id time); 296 | Iobuf.Unsafe.Poke.int64_le current_chunk ~pos:8 value; 297 | Iobuf.unsafe_advance current_chunk 16 298 | ;; 299 | 300 | let write_group_reset = write_timer_at 301 | 302 | module%test [@name "write header messages"] _ = struct 303 | let unpack_one () = 304 | let chunk = Lazy.force Buffer.header_chunk in 305 | Iobuf.flip_lo chunk; 306 | match Header_protocol.to_unpacked chunk with 307 | | Ok (unpacked, length) -> 308 | [%test_eq: int] (Iobuf.length chunk) length; 309 | unpacked 310 | | _ -> failwith "to_unpacked failed" 311 | ;; 312 | 313 | let%test_unit "write_new_single" = 314 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 315 | write_new_single (Probe_id.of_int_exn 100) "unittest" Probe_type.Timer; 316 | match unpack_one () with 317 | | New_single { id; spec; name; message_length = _; message_type = _ } -> 318 | [%test_eq: Probe_id.t] id (Probe_id.of_int_exn 100); 319 | [%test_eq: Probe_type.t] spec Probe_type.Timer; 320 | [%test_eq: string] name "unittest" 321 | | _ -> failwith "Incorrect message type") 322 | ;; 323 | 324 | let%test_unit "write_new_group" = 325 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 326 | write_new_group 327 | (Probe_id.of_int_exn 100) 328 | "unittest" 329 | (Probe_type.Probe Profiler_units.Seconds); 330 | match unpack_one () with 331 | | New_group { id; spec; name; message_length = _; message_type = _ } -> 332 | [%test_eq: Probe_id.t] id (Probe_id.of_int_exn 100); 333 | [%test_eq: Probe_type.t] spec (Probe_type.Probe Profiler_units.Seconds); 334 | [%test_eq: string] name "unittest" 335 | | _ -> failwith "Incorrect message type") 336 | ;; 337 | 338 | let%test_unit "write_new_group_point" = 339 | protect ~finally:Buffer.Unsafe_internals.reset ~f:(fun () -> 340 | write_new_group_point 341 | ~group_id:(Probe_id.of_int_exn 100) 342 | ~id:(Probe_id.of_int_exn 300) 343 | "unittest" 344 | (Array.map ~f:Probe_id.of_int_exn [| 500; 700 |]); 345 | match unpack_one () with 346 | | New_group_point 347 | { group_id; id; name; sources_grp; message_length = _; message_type = _ } -> 348 | [%test_eq: int] (Probe_id.to_int_exn group_id) 100; 349 | [%test_eq: int] (Probe_id.to_int_exn id) 300; 350 | [%test_eq: string] name "unittest"; 351 | [%test_eq: int array] 352 | (Array.map sources_grp ~f:(fun r -> 353 | let r : Header_protocol.New_group_point.Unpacked.t_sources = r in 354 | Probe_id.to_int_exn r.source_id)) 355 | [| 500; 700 |] 356 | | _ -> assert false) 357 | ;; 358 | end 359 | 360 | let write_to_fd fd header_chunk chunks = 361 | List.iter (header_chunk :: chunks) ~f:(fun chunk -> 362 | Iobuf.protect_window_bounds_and_buffer chunk ~f:(fun chunk -> 363 | Bigstring_unix.really_write fd (Iobuf.Peek.bigstringo ~pos:0 chunk))) 364 | ;; 365 | 366 | let%test_unit "write_to_fd" = 367 | let filename, fd = Unix.mkstemp "/tmp/core-profiler-tests" in 368 | protect 369 | ~f:(fun () -> 370 | let header_chunk = Iobuf.of_string "the header chunk\n" in 371 | let chunks = 372 | [ Iobuf.of_string "the first chunk\n"; Iobuf.of_string "the second chunk\n" ] 373 | in 374 | write_to_fd fd header_chunk chunks; 375 | Unix.close fd; 376 | [%test_eq: string] 377 | (In_channel.read_all filename) 378 | "the header chunk\nthe first chunk\nthe second chunk\n") 379 | ~finally:(fun () -> 380 | (try Unix.close fd with 381 | | _ -> ()); 382 | Unix.unlink filename) 383 | ;; 384 | 385 | let write_to_file name_ref header_chunk chunks = 386 | let name = !name_ref in 387 | (match Sys_unix.file_exists name with 388 | | `Yes -> Unix.rename ~src:name ~dst:(name ^ ".old") 389 | | `No | `Unknown -> ()); 390 | Unix.with_file name ~mode:[ Unix.O_CREAT; Unix.O_WRONLY; Unix.O_TRUNC ] ~f:(fun fd -> 391 | write_to_fd fd header_chunk chunks) 392 | ;; 393 | 394 | let at_exit_handler = ref (Some (write_to_file current_output_filename)) 395 | 396 | let set_at_exit_handler = function 397 | | `Write_file name -> at_exit_handler := Some (write_to_file (ref name)) 398 | | `Function f -> at_exit_handler := Some f 399 | | `Disable -> at_exit_handler := None 400 | ;; 401 | 402 | let dump_stats_internal handler = 403 | write_epoch (); 404 | write_end_of_header (); 405 | let chunks = Buffer.get_chunks () in 406 | if not (List.is_empty chunks) 407 | then 408 | handler (Buffer.get_header_chunk ()) (chunks :> (read, Iobuf.no_seek) Iobuf.t list) 409 | ;; 410 | 411 | let dump_stats () = 412 | Option.iter !at_exit_handler ~f:(fun handler -> 413 | let header_chunk = Lazy.force Buffer.header_chunk in 414 | let lo_bound = Iobuf.Lo_bound.window header_chunk in 415 | let hi_bound = Iobuf.Hi_bound.window header_chunk in 416 | dump_stats_internal handler; 417 | Iobuf.Lo_bound.restore lo_bound header_chunk; 418 | Iobuf.Hi_bound.restore hi_bound header_chunk) 419 | ;; 420 | 421 | let () = at_exit (fun () -> Option.iter !at_exit_handler ~f:dump_stats_internal) 422 | 423 | module Unsafe_internals = struct 424 | let write_epoch = write_epoch 425 | let write_end_of_header = write_end_of_header 426 | end 427 | end 428 | -------------------------------------------------------------------------------- /src/protocol.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | val default_output_filename : string 4 | val set_current_output_filename : string -> unit 5 | 6 | (** Packs [Probe_id.t] and [Time_ns.t] into a single [int]. *) 7 | module Short_header : sig 8 | (** The goal of [Short_header] is to pack a [Timer.record] into one word (we want to 9 | write an integer number of words for alignment, and don't want to pay for the size 10 | or time of writing a second word if we don't have to). 11 | 12 | A short header "contains" an [Probe_id.t] and a [Time_ns.t]. A short header is a 13 | single word / integer; we have 63 bits to play with. The 9 most significant bits 14 | contain [Probe_id.to_int_exn]; the remaining 54 bits contain a time, stored as a 15 | number of nanoseconds from some [Profiler_epoch.t] (the epoch is written into the 16 | header; see [Writer.write_epoch]). 17 | 18 | 2 ** 54 nanoseconds is approximately 208 days. The epoch is set to equal a little 19 | before now when OCaml starts up, so the header should continue to work for ~208 days 20 | after that. *) 21 | 22 | val id_bits : int 23 | val time_bits : int 24 | val max_id : int 25 | val max_time_diff : Time_ns.Span.t 26 | val pack_exn : Profiler_epoch.t -> Probe_id.t -> Time_ns.t -> int 27 | val pack_unsafe : Profiler_epoch.t -> Probe_id.t -> Time_ns.t -> int 28 | val unpack_id : int -> Probe_id.t 29 | val unpack_time : Profiler_epoch.t -> int -> Time_ns.t 30 | val unpack : Profiler_epoch.t -> int -> Probe_id.t * Time_ns.t 31 | end 32 | 33 | (** Handles allocating [Iobuf.t] and making sure there's enough space in it. *) 34 | module Buffer : sig 35 | val get_header_chunk : unit -> (read, _) Iobuf.t 36 | val ensure_free : int -> unit 37 | 38 | (** All of these will push the current chunk into the list of previous chunks first; a 39 | new chunk will then be allocated on the next write. *) 40 | 41 | (** Is the main (short message) buffer empty? *) 42 | val is_empty : unit -> bool 43 | 44 | val get_chunks : unit -> (read_write, Iobuf.no_seek) Iobuf.t list 45 | 46 | (** To aid producing test cases for Reader. *) 47 | module Unsafe_internals : sig 48 | val reset : unit -> unit 49 | end 50 | end 51 | 52 | (** The [Writer] module contains functions that invoke parts of [Header_protocol] and 53 | [Short_header] in order to write into the relevant (global variable) buffers in 54 | [Buffer] *) 55 | module Writer : sig 56 | val epoch : Profiler_epoch.t 57 | val max_time : Time_ns.t 58 | 59 | (** These write into the header chunk *) 60 | val write_new_single : Probe_id.t -> string -> Probe_type.t -> unit 61 | 62 | val write_new_group : Probe_id.t -> string -> Probe_type.t -> unit 63 | 64 | val write_new_group_point 65 | : group_id:Probe_id.t 66 | -> id:Probe_id.t 67 | -> string 68 | -> Probe_id.t array 69 | -> unit 70 | 71 | (** These write into the short message buffer *) 72 | val write_timer_at : Probe_id.t -> Time_ns.t -> unit 73 | 74 | val write_probe_at : Probe_id.t -> Time_ns.t -> int -> unit 75 | val write_group_reset : Probe_id.t -> Time_ns.t -> unit 76 | val dump_stats : unit -> unit 77 | 78 | (** Choose what to do with the in memory stats data at exit. The handler function is 79 | passed the header chunk and the list of data chunks. Defaults to 80 | [`Write_file "stats.dat"]. *) 81 | val set_at_exit_handler 82 | : [ `Write_file of string 83 | | `Function of 84 | (read, Iobuf.no_seek) Iobuf.t -> (read, Iobuf.no_seek) Iobuf.t list -> unit 85 | | `Disable 86 | ] 87 | -> unit 88 | 89 | (** To aid producing test cases for Reader. *) 90 | module Unsafe_internals : sig 91 | val write_epoch : unit -> unit 92 | val write_end_of_header : unit -> unit 93 | end 94 | end 95 | -------------------------------------------------------------------------------- /src/std_offline.ml: -------------------------------------------------------------------------------- 1 | (** Open this Std for offline use of probes. *) 2 | 3 | module Profiler_units = Core_profiler_disabled.Profiler_units 4 | 5 | include Offline (** @inline *) 6 | -------------------------------------------------------------------------------- /src/std_online.ml: -------------------------------------------------------------------------------- 1 | (** Open this Std for online use. *) 2 | 3 | module Profiler_units = Core_profiler_disabled.Profiler_units 4 | 5 | include Online (** @inline *) 6 | --------------------------------------------------------------------------------