├── .gitignore ├── .merlin ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── lib ├── dune ├── mProf.ml ├── mProf_counter.ml ├── mProf_trace_with_tracing.ml ├── mProf_trace_without_tracing.ml ├── mProf_with_tracing └── mProf_without_tracing ├── metadata ├── mirage-profile-unix.opam ├── mirage-profile-xen.opam ├── mirage-profile.opam ├── test ├── benchmark.ml └── dune ├── unix ├── dune ├── mProf_unix.ml └── mProf_unix.mli └── xen ├── dune ├── mProf_xen.ml └── mProf_xen.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.log 3 | setup.data 4 | benchmark.native 5 | mirage-profile.install 6 | *.install 7 | *.merlin 8 | 9 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt 2 | 3 | B _build/lib 4 | 5 | S 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | dist: xenial 4 | services: 5 | - docker 6 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 7 | script: bash -ex ./.travis-docker.sh 8 | env: 9 | global: 10 | - PINS="mirage-profile:. mirage-profile-unix:. mirage-profile-xen:." 11 | matrix: 12 | - PACKAGE="mirage-profile" DISTRO="debian-stable" OCAML_VERSION="4.04" 13 | - PACKAGE="mirage-profile" DISTRO="debian-stable" OCAML_VERSION="4.05" PINS="mirage-profile:. lwt:git://github.com/mirage/lwt#tracing" 14 | - PACKAGE="mirage-profile-unix" DISTRO="debian-stable" OCAML_VERSION="4.06" PINS="mirage-profile:. mirage-profile-unix:. lwt:git://github.com/mirage/lwt#tracing" POST_INSTALL_HOOK="dune runtest" 15 | - PACKAGE="mirage-profile-xen" DISTRO="debian-stable" OCAML_VERSION="4.05" 16 | - PACKAGE="mirage-profile" DISTRO="debian-stable" OCAML_VERSION="4.05" 17 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.9.1 2019-07-09 2 | ----------------- 3 | 4 | - update for mirage-xen 4.0.0 (@talex5). 5 | 6 | v0.9.0 2019-06-25 7 | ----------------- 8 | 9 | - port to dune (@talex5) 10 | - upgrade opam metadata to 2.0 format (@talex5 @avsm) 11 | 12 | v0.8.2 2017-11-22 13 | ----------------- 14 | 15 | - add ocplib-endian to jbuild rules to support cstruct >= 3.2.0 16 | 17 | v0.8.1 2017-06-19 18 | ----------------- 19 | 20 | - update opam descriptions to correctly depend on io-page-xen 21 | - fix README instructions for latest interfaces 22 | - minimum supported OCaml version is 4.03.0+ as per rest of MirageOS 3 23 | 24 | v0.8.0 2017-06-08 25 | ----------------- 26 | 27 | - split into 3 ocamlfind and opam packages: 28 | - mirage-profile: generic code 29 | - mirage-profile-unix: Unix-specific library 30 | - mirage-profile-xen: Xen kernel specific library 31 | - build with jbuilder 32 | - release with topkg 33 | - modernize travis configuration 34 | - don't link client libraries against cstruct.ppx 35 | - add "Async" thread type 36 | - fix linking problem on Ubuntu 12.04 37 | 38 | v0.7.0 2016-03-13 39 | ----------------- 40 | 41 | - depend on cstruct.ppx (from >= 1.9.0) rather than cstruct.syntax 42 | - improve usage instructions 43 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Thomas Leonard 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 11 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build clean test 3 | 4 | # mirage-profile-xen depends on mirage-xen, which depends on 5 | # mirage-profile, so dune won't let us build it against our 6 | # local mirage-profile by default. 7 | build: 8 | dune build -p mirage-profile @install 9 | dune build -p mirage-profile-xen @install 10 | dune build -p mirage-profile-unix @install 11 | 12 | test: 13 | dune runtest 14 | 15 | install: 16 | dune install 17 | 18 | uninstall: 19 | dune uninstall 20 | 21 | clean: 22 | rm -rf _build 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## mirage-profile -- collect runtime profiling information in CTF format 2 | 3 | This library can be used to trace execution of OCaml/Lwt programs (such as Mirage unikernels) at the level of Lwt threads. 4 | The traces can be viewed using JavaScript or GTK viewers provided by [mirage-trace-viewer][] or processed by tools supporting the [Common Trace Format (CTF)][ctf]. 5 | Some example traces can be found in the blog post [Visualising an Asynchronous Monad](http://roscidus.com/blog/blog/2014/10/27/visualising-an-asynchronous-monad/). 6 | 7 | Libraries can use the functions mirage-profile provides to annotate the traces with extra information. 8 | When compiled against a normal version of Lwt, mirage-profile's functions are null-ops (or call the underlying untraced operation, as appropriate) and OCaml's cross-module inlining will optimise these calls away, meaning there should be no overhead in the non-profiling case. 9 | 10 | 11 | ## Use with Mirage 12 | 13 | See http://openmirage.org/wiki/profiling for instructions. 14 | 15 | ## Recording traces manually 16 | 17 | To record traces you need to pin a version of Lwt with tracing support (this provides the `lwt.tracing` findlib module): 18 | 19 | $ opam pin add lwt.3.0 'https://github.com/mirage/lwt.git#tracing' 20 | 21 | This will cause mirage-profile and any programs using it to be recompiled with tracing enabled. 22 | 23 | To trace a **Unix process**, use `MProf_unix.mmap_buffer` to write to an mmapped file: 24 | 25 | let () = 26 | let buffer = MProf_unix.mmap_buffer ~size:1000000 "trace.ctf" in 27 | let trace_config = MProf.Trace.Control.make buffer MProf_unix.timestamper in 28 | MProf.Trace.Control.start trace_config 29 | 30 | You'll also need to link with the `mirage-profile` and `mirage-profile-unix` libraries. 31 | e.g. with this `dune` file: 32 | 33 | (executable 34 | (name test) 35 | (libraries mirage-profile mirage-profile-unix)) 36 | 37 | To begin tracing a **Xen unikernel**, create a buffer and call `MProf.Trace.Control.start`: 38 | 39 | let trace_pages = MProf_xen.make_shared_buffer ~size:1000000 40 | let () = 41 | let buffer = trace_pages |> Io_page.to_cstruct |> Cstruct.to_bigarray in 42 | let trace_config = MProf.Trace.Control.make buffer MProf_xen.timestamper in 43 | MProf.Trace.Control.start trace_config 44 | 45 | To share the buffer with dom0, do this somewhere in your initialisation code: 46 | 47 | MProf_xen.share_with (module Gnt.Gntshr) (module OS.Xs) ~domid:0 trace_pages 48 | 49 | You'll also need to link with the `mirage-profile` and `mirage-profile-xen` libraries. 50 | 51 | ## Viewing traces 52 | 53 | To view the trace you should, ideally, call `MProf.Trace.Control.stop` before reading the buffer to avoid race conditions, but in practice reading the trace at any time usually works. 54 | 55 | If your program crashes, you can still read the trace buffer. 56 | On Xen, you can ensure that the buffer doesn't disappear by adding these lines to your guest's config file: 57 | 58 | on_crash = 'preserve' 59 | on_poweroff = 'preserve' 60 | 61 | [mirage-trace-viewer][] contains tools for saving and viewing traces, as well as a `metadata` description of the format, which allows the traces to be read using e.g. [babeltrace][]. 62 | 63 | 64 | ## Recording extra trace data 65 | 66 | Programs and libraries are encouraged to record extra useful information using the `MProf` module. 67 | As using these functions generally has no overhead when a regular Lwt is used, there should be no need to use conditional compilation for this. 68 | See the `MProf.Trace` and `MProf.Counter` modules for documentation about what can be recorded. 69 | 70 | 71 | [ctf]: http://www.efficios.com/ctf 72 | [babeltrace]: http://www.efficios.com/babeltrace 73 | [mirage-trace-viewer]: https://github.com/talex5/mirage-trace-viewer 74 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name mirage-profile) 3 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_profile) 3 | (public_name mirage-profile) 4 | (libraries 5 | cstruct 6 | lwt 7 | ocplib-endian 8 | ocplib-endian.bigstring 9 | (select 10 | mProf_trace.ml 11 | from 12 | (lwt.tracing -> mProf_trace_with_tracing.ml) 13 | (!lwt.tracing -> mProf_trace_without_tracing.ml)) 14 | (select 15 | mProf.mli 16 | from 17 | (lwt.tracing -> mProf_with_tracing) 18 | (!lwt.tracing -> mProf_without_tracing))) 19 | (modules MProf MProf_trace MProf_counter) 20 | (wrapped false) 21 | (preprocess 22 | (pps ppx_cstruct))) 23 | -------------------------------------------------------------------------------- /lib/mProf.ml: -------------------------------------------------------------------------------- 1 | module Trace = MProf_trace 2 | module Counter = MProf_counter 3 | -------------------------------------------------------------------------------- /lib/mProf_counter.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | type t = { 4 | name : string; 5 | mutable value : int; 6 | } 7 | 8 | let create ?(init=0) ~name () = { name; value = init } 9 | let make ~name = create ~name () 10 | 11 | let set_value m v = 12 | m.value <- v; 13 | MProf_trace.note_counter_value m.name v 14 | 15 | let increase m amount = 16 | set_value m (m.value + amount) 17 | 18 | let value m = m.value 19 | -------------------------------------------------------------------------------- /lib/mProf_trace_with_tracing.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | (* Note: we expect some kind of logger to process the trace buffer to collect 4 | * events, but currently we don't have any barriers to ensure that the buffer 5 | * is in a consistent state (although it usually is). So for now, you should 6 | * pause tracing before trying to parse the buffer. In particular, GC events 7 | * complicate things because we may need to add a GC event while in the middle 8 | * of adding some other event. *) 9 | 10 | open Bigarray 11 | 12 | type hiatus_reason = 13 | | Wait_for_work 14 | | Suspend 15 | | Hibernate 16 | 17 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 18 | 19 | (* It's annoying that we can't call this C function directly, but it causes 20 | * linker problems by forcing anything that depends on mirage-profile to depend 21 | * on mirage-profile.xen or mirage-profile.unix, even when tracing isn't being 22 | * used. *) 23 | type timestamper = log_buffer -> int -> unit 24 | 25 | let current_thread = ref (-1L) 26 | 27 | let did_warn_types = ref false 28 | let int_of_thread_type t = 29 | let open Lwt_tracing in 30 | match t with 31 | | Wait -> 0 32 | | Task -> 1 33 | | Bind -> 2 34 | | Try -> 3 35 | | Choose -> 4 36 | | Pick -> 5 37 | | Join -> 6 38 | | Map -> 7 39 | | Condition -> 8 40 | | On_success -> 9 41 | | On_failure -> 10 42 | | On_termination -> 11 43 | | On_any -> 12 44 | | Ignore_result -> 13 45 | | Async -> 14 46 | | _ -> 47 | if not !did_warn_types then ( 48 | Printf.eprintf "Warning: unknown thread type!\n%!"; 49 | did_warn_types := true 50 | ); 51 | 99 52 | [@@ocaml.warning "-11"] 53 | 54 | module Packet = struct 55 | let magic = 0xc1fc1fc1l 56 | let uuid = "\x05\x88\x3b\x8d\x52\x1a\x48\x7b\xb3\x97\x45\x6a\xb1\x50\x68\x0c" 57 | 58 | [%%cstruct 59 | type packet_header = { 60 | (* Stream header, repeated for each packet *) 61 | magic: uint32_t; 62 | uuid: uint8_t [@len 16]; 63 | 64 | (* Packet header *) 65 | size: uint32_t; 66 | stream_packet_count: uint16_t; 67 | content_size_low: uint16_t; (* 2x16 bit to avoid allocating an Int32 *) 68 | content_size_high: uint16_t; 69 | } [@@little_endian] 70 | ] 71 | let () = 72 | ignore (copy_packet_header_uuid, hexdump_packet_header, blit_packet_header_uuid) 73 | 74 | type t = { 75 | packet_start : int; 76 | header : Cstruct.t; 77 | packet_end : int; 78 | } 79 | 80 | let first_event packet = 81 | packet.packet_start + sizeof_packet_header 82 | 83 | let packet_end packet = 84 | packet.packet_end 85 | 86 | let set_content_end packet content_end = 87 | let header = packet.header in 88 | let bits = (content_end - packet.packet_start) * 8 in 89 | set_packet_header_content_size_low header (bits land 0xffff); 90 | set_packet_header_content_size_high header (bits lsr 16) 91 | 92 | let clear ~count packet = 93 | let bits = sizeof_packet_header * 8 in 94 | let header = packet.header in 95 | set_packet_header_stream_packet_count header (count land 0xffff); 96 | set_packet_header_content_size_low header (bits land 0xffff); 97 | set_packet_header_content_size_high header (bits lsr 16) 98 | 99 | let make ~count ~off ~len buffer = 100 | let header = Cstruct.of_bigarray ~off ~len:sizeof_packet_header buffer in 101 | set_packet_header_magic header magic; 102 | set_packet_header_uuid uuid 0 header; 103 | set_packet_header_size header (Int32.of_int (len * 8)); 104 | let packet = { 105 | packet_start = off; 106 | header; 107 | packet_end = off + len; 108 | } in 109 | clear ~count packet; 110 | packet 111 | 112 | end 113 | 114 | module Control = struct 115 | (* Following LTT, our trace buffer is divided into a small number of 116 | * fixed-sized "packets", each of which contains many events. When there 117 | * isn't room in the current packet for the next event, we move to the next 118 | * packet. This wastes a few bytes at the end of each packet, but it allows 119 | * us to discard whole packets at a time when we need to overwrite something. 120 | *) 121 | type t = { 122 | log : log_buffer; 123 | timestamper : timestamper; 124 | mutable next_event : int; (* Index to write next event (always < packet_end) *) 125 | mutable packet_end: int; 126 | packets : Packet.t array; 127 | mutable active_packet : int; 128 | 129 | (* Each packet is numbered, making it easy to get the order when reading the 130 | * ring buffer and allowing for detection of missed packets. *) 131 | mutable next_stream_packet_count : int; 132 | } 133 | 134 | let event_log = ref None 135 | 136 | let stop log = 137 | match !event_log with 138 | | Some active when log == active -> 139 | Lwt_tracing.tracer := Lwt_tracing.null_tracer; 140 | event_log := None 141 | | _ -> failwith "Log is not currently tracing!" 142 | 143 | let op_creates = 0 144 | let op_read = 1 145 | let op_fulfills = 2 146 | let op_fails = 3 147 | let op_becomes = 4 148 | let op_label = 5 149 | let op_increase = 6 150 | let op_switch = 7 151 | let op_gc = 8 152 | let op_signal = 9 153 | let op_try_read = 10 154 | let op_counter_value = 11 155 | 156 | let write64 log v i = 157 | EndianBigstring.LittleEndian.set_int64 log i v; 158 | i + 8 159 | 160 | let write8 log v i = 161 | EndianBigstring.LittleEndian.set_int8 log i v; 162 | i + 1 163 | 164 | let write_string log v i = 165 | let l = String.length v in 166 | for idx = 0 to l - 1 do 167 | Array1.set log (i + idx) v.[idx] 168 | done; 169 | Array1.set log (i + l) '\x00'; 170 | i + l + 1 171 | 172 | (* The current packet is full. Move to the next one. *) 173 | let next_packet log = 174 | log.active_packet <- (log.active_packet + 1) mod Array.length log.packets; 175 | let packet = log.packets.(log.active_packet) in 176 | log.packet_end <- Packet.packet_end packet; 177 | log.next_event <- Packet.first_event packet; 178 | let count = log.next_stream_packet_count in 179 | Packet.clear packet ~count; 180 | log.next_stream_packet_count <- count + 1 181 | 182 | let rec add_event log op len = 183 | (* Note: be careful about allocation here, as doing GC will add another event... *) 184 | let i = log.next_event in 185 | let new_i = i + 9 + len in 186 | (* >= rather than > is slightly wasteful, but avoids next_event overlapping the next packet *) 187 | if new_i >= log.packet_end then ( 188 | (* Printf.printf "can't write %d at %d\n%!" (9 + len) i; *) 189 | let old_packet = log.packets.(log.active_packet) in 190 | assert (i > Packet.first_event old_packet); 191 | next_packet log; 192 | add_event log op len 193 | ) else ( 194 | (* Printf.printf "writing at %d\n%!" i; *) 195 | log.next_event <- new_i; 196 | Packet.set_content_end log.packets.(log.active_packet) new_i; 197 | log.timestamper log.log i; 198 | i + 8 |> write8 log.log op 199 | ) 200 | 201 | (* This is faster than [let end_event = ignore]! *) 202 | external end_event : int -> unit = "%ignore" 203 | (* 204 | let end_event i = 205 | match !event_log with 206 | | None -> assert false 207 | | Some log -> assert (i = log.next_event || log.next_event = 0) 208 | *) 209 | 210 | let note_created log child thread_type = 211 | add_event log op_creates 17 212 | |> write64 log.log !current_thread 213 | |> write64 log.log child 214 | |> write8 log.log (int_of_thread_type thread_type) 215 | |> end_event 216 | 217 | let note_read log input = 218 | let new_current = Lwt.current_id () in 219 | (* (avoid expensive caml_modify call if possible) *) 220 | if new_current <> !current_thread then current_thread := new_current; 221 | if !current_thread <> input then ( 222 | add_event log op_read 16 223 | |> write64 log.log !current_thread 224 | |> write64 log.log input 225 | |> end_event 226 | ) 227 | 228 | let note_try_read log thread input = 229 | add_event log op_try_read 16 230 | |> write64 log.log thread 231 | |> write64 log.log input 232 | |> end_event 233 | 234 | let note_signal log source = 235 | current_thread := Lwt.current_id (); 236 | add_event log op_signal 16 237 | |> write64 log.log !current_thread 238 | |> write64 log.log source 239 | |> end_event 240 | 241 | let note_resolved log p ~ex = 242 | match ex with 243 | | Some ex -> 244 | let msg = Printexc.to_string ex in 245 | add_event log op_fails (17 + String.length msg) 246 | |> write64 log.log !current_thread 247 | |> write64 log.log p 248 | |> write_string log.log msg 249 | |> end_event 250 | | None -> 251 | add_event log op_fulfills 16 252 | |> write64 log.log !current_thread 253 | |> write64 log.log p 254 | |> end_event 255 | 256 | let note_becomes log input main = 257 | if main <> input then ( 258 | add_event log op_becomes 16 259 | |> write64 log.log input 260 | |> write64 log.log main 261 | |> end_event 262 | ) 263 | 264 | let note_label log thread msg = 265 | add_event log op_label (9 + String.length msg) 266 | |> write64 log.log thread 267 | |> write_string log.log msg 268 | |> end_event 269 | 270 | let note_increase log counter amount = 271 | add_event log op_increase (17 + String.length counter) 272 | |> write64 log.log !current_thread 273 | |> write64 log.log (Int64.of_int amount) 274 | |> write_string log.log counter 275 | |> end_event 276 | 277 | let note_counter_value log counter value = 278 | add_event log op_counter_value (17 + String.length counter) 279 | |> write64 log.log !current_thread 280 | |> write64 log.log (Int64.of_int value) 281 | |> write_string log.log counter 282 | |> end_event 283 | 284 | let note_switch log () = 285 | let id = Lwt.current_id () in 286 | if id <> !current_thread then ( 287 | current_thread := id; 288 | add_event log op_switch 8 289 | |> write64 log.log id 290 | |> end_event 291 | ) 292 | 293 | let note_suspend log () = 294 | current_thread := (-1L); 295 | add_event log op_switch 8 296 | |> write64 log.log (-1L) 297 | |> end_event 298 | 299 | let note_gc duration = 300 | match !event_log with 301 | | None -> () 302 | | Some log -> 303 | add_event log op_gc 8 304 | |> write64 log.log (duration *. 1000000000. |> Int64.of_float) 305 | |> end_event 306 | 307 | let make log timestamper = 308 | let size = Array1.dim log in 309 | let n_packets = 4 in 310 | let packet_size = size / n_packets in 311 | let packets = Array.init n_packets (fun i -> 312 | let off = i * packet_size in 313 | let len = if i = n_packets - 1 then size - off else packet_size in 314 | Packet.make ~count:i ~off ~len log 315 | ) in 316 | let active_packet = 0 in 317 | { 318 | log; 319 | timestamper; 320 | packets; 321 | active_packet; 322 | packet_end = Packet.packet_end packets.(active_packet); 323 | next_event = Packet.first_event packets.(active_packet); 324 | next_stream_packet_count = 1; 325 | } 326 | 327 | let start log = 328 | event_log := Some log; 329 | Lwt_tracing.(tracer := {null_tracer with 330 | note_created = note_created log; 331 | note_read = note_read log; 332 | note_try_read = note_try_read log; 333 | note_resolved = note_resolved log; 334 | note_signal = note_signal log; 335 | note_becomes = note_becomes log; 336 | note_label = note_label log; 337 | note_switch = note_switch log; 338 | note_suspend = note_suspend log; 339 | }); 340 | note_switch log () 341 | [@@ocaml.warning "-23"] 342 | 343 | let () = 344 | Callback.register "MProf.Trace.note_gc" note_gc 345 | end 346 | 347 | let label name = 348 | match !Control.event_log with 349 | | None -> () 350 | | Some log -> Control.note_label log (Lwt.current_id ()) name 351 | 352 | let note_hiatus _reason = 353 | match !Control.event_log with 354 | | None -> () 355 | | Some log -> Control.note_suspend log () 356 | 357 | let note_resume () = 358 | match !Control.event_log with 359 | | None -> () 360 | | Some log -> Control.note_switch log () 361 | 362 | let note_increase counter amount = 363 | match !Control.event_log with 364 | | None -> () 365 | | Some log -> Control.note_increase log counter amount 366 | 367 | let note_counter_value counter value = 368 | match !Control.event_log with 369 | | None -> () 370 | | Some log -> Control.note_counter_value log counter value 371 | 372 | let named_condition label = 373 | Lwt_condition.create ~label () 374 | 375 | let named_wait label = 376 | let pair = Lwt.wait () in 377 | begin match !Control.event_log with 378 | | None -> () 379 | | Some log -> Control.note_label log (Lwt.id_of_thread (fst pair)) label end; 380 | pair 381 | 382 | let named_task label = 383 | let pair = Lwt.task () in 384 | begin match !Control.event_log with 385 | | None -> () 386 | | Some log -> Control.note_label log (Lwt.id_of_thread (fst pair)) label end; 387 | pair 388 | 389 | let named_mvar label v = 390 | Lwt_mvar.create ~label v 391 | 392 | let named_mvar_empty label = 393 | Lwt_mvar.create_empty ~label () 394 | 395 | let should_resolve thread = 396 | match !Control.event_log with 397 | | None -> () 398 | | Some log -> Control.note_label log (Lwt.id_of_thread thread) "__should_resolve" (* Hack! *) 399 | -------------------------------------------------------------------------------- /lib/mProf_trace_without_tracing.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | type hiatus_reason = 4 | | Wait_for_work 5 | | Suspend 6 | | Hibernate 7 | 8 | let note_hiatus _reason = () 9 | let note_resume () = () 10 | 11 | let label _label = () 12 | let named_wait _label = Lwt.wait () 13 | let named_task _label = Lwt.task () 14 | let named_condition _label = Lwt_condition.create () 15 | let named_mvar _label v = Lwt_mvar.create v 16 | let named_mvar_empty _label = Lwt_mvar.create_empty () 17 | let should_resolve _thread = () 18 | 19 | let note_increase _counter _amount = () 20 | let note_counter_value _counter _value = () 21 | -------------------------------------------------------------------------------- /lib/mProf_with_tracing: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | module Trace : sig 4 | (** Functions that libraries can use to add events to the trace. 5 | * 6 | * If mirage-profile is compiled with tracing disabled, these are null-ops (or 7 | * call the underlying untraced operation, as appropriate). The compiler should 8 | * optimise them out in this case. *) 9 | 10 | (** {2 General tracing calls for libraries} *) 11 | 12 | val label : string -> unit 13 | (** Attach a label/comment to the currently executing thread. *) 14 | 15 | val named_wait : string -> 'a Lwt.t * 'a Lwt.u 16 | (** Wrapper for [Lwt.wait] that labels the new thread. *) 17 | 18 | val named_task : string -> 'a Lwt.t * 'a Lwt.u 19 | (** Wrapper for [Lwt.task] that labels the new thread. *) 20 | 21 | val named_condition : string -> 'a Lwt_condition.t 22 | (** Create a Lwt_condition that will label its thread with the given name. *) 23 | 24 | val named_mvar_empty : string -> 'a Lwt_mvar.t 25 | (** Create a Lwt_mvar that will label its threads with the given name. *) 26 | 27 | val named_mvar : string -> 'a -> 'a Lwt_mvar.t 28 | (** Create a Lwt_mvar that will label its threads with the given name. *) 29 | 30 | val note_increase : string -> int -> unit 31 | (* Deprecated: use Counter.increase instead. *) 32 | 33 | val note_counter_value : string -> int -> unit 34 | (** Records the current value of the named counter. 35 | * (for internal use: use Counter.set_value instead) *) 36 | 37 | val should_resolve : 'a Lwt.t -> unit 38 | (** Add a hint that this thread is expected to resolve. 39 | * This is useful if a thread never completes and you want to find out why. 40 | * Without the hint, the viewer makes such threads almost invisible. *) 41 | 42 | (** {2 Interface for the main loop} *) 43 | 44 | type hiatus_reason = 45 | | Wait_for_work 46 | | Suspend 47 | | Hibernate 48 | 49 | val note_hiatus : hiatus_reason -> unit 50 | (** Record that the process is about to stop running for a while. *) 51 | 52 | val note_resume : unit -> unit 53 | (** Record that the program has just resumed running. *) 54 | 55 | (** {2 Control interface} 56 | The extended profiling interface available when compiled with tracing enabled. *) 57 | 58 | open Bigarray 59 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 60 | 61 | type timestamper = log_buffer -> int -> unit 62 | 63 | module Control : sig 64 | type t 65 | 66 | val make : log_buffer -> timestamper -> t 67 | (** Create a new trace log, backed by the given array. 68 | * Use [MProf_unix] or [MProf_xen] to get the buffer and timestamper. *) 69 | 70 | val start : t -> unit 71 | (** Start logging to the given buffer. *) 72 | 73 | val stop : t -> unit 74 | (** Stop recording. *) 75 | end 76 | 77 | end 78 | 79 | module Counter :sig 80 | (** A counter or other time-varying integer value. *) 81 | 82 | type t 83 | 84 | val create : ?init:int -> name:string -> unit -> t 85 | val make : name:string -> t 86 | 87 | val value : t -> int 88 | val set_value : t -> int -> unit 89 | 90 | val increase : t -> int -> unit 91 | (** Record a change in the value of the metric. The change can be negative. *) 92 | 93 | end 94 | -------------------------------------------------------------------------------- /lib/mProf_without_tracing: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | module Trace : sig 4 | (** Functions that libraries can use to add events to the trace. 5 | * 6 | * If mirage-profile is compiled with tracing disabled, these are null-ops (or 7 | * call the underlying untraced operation, as appropriate). The compiler should 8 | * optimise them out in this case. *) 9 | 10 | (** {2 General tracing calls for libraries} *) 11 | 12 | val label : string -> unit 13 | (** Attach a label/comment to the currently executing thread. *) 14 | 15 | val named_wait : string -> 'a Lwt.t * 'a Lwt.u 16 | (** Wrapper for [Lwt.wait] that labels the new thread. *) 17 | 18 | val named_task : string -> 'a Lwt.t * 'a Lwt.u 19 | (** Wrapper for [Lwt.task] that labels the new thread. *) 20 | 21 | val named_condition : string -> 'a Lwt_condition.t 22 | (** Create a Lwt_condition that will label its thread with the given name. *) 23 | 24 | val named_mvar_empty : string -> 'a Lwt_mvar.t 25 | (** Create a Lwt_mvar that will label its threads with the given name. *) 26 | 27 | val named_mvar : string -> 'a -> 'a Lwt_mvar.t 28 | (** Create a Lwt_mvar that will label its threads with the given name. *) 29 | 30 | val note_increase : string -> int -> unit 31 | (* Deprecated: use Counter.increase instead. *) 32 | 33 | val note_counter_value : string -> int -> unit 34 | (** Records the current value of the named counter. 35 | * (for internal use: use Counter.set_value instead) *) 36 | 37 | val should_resolve : 'a Lwt.t -> unit 38 | (** Add a hint that this thread is expected to resolve. 39 | * This is useful if a thread never completes and you want to find out why. 40 | * Without the hint, the viewer makes such threads almost invisible. *) 41 | 42 | (** {2 Interface for the main loop} *) 43 | 44 | type hiatus_reason = 45 | | Wait_for_work 46 | | Suspend 47 | | Hibernate 48 | 49 | val note_hiatus : hiatus_reason -> unit 50 | (** Record that the process is about to stop running for a while. *) 51 | 52 | val note_resume : unit -> unit 53 | (** Record that the program has just resumed running. *) 54 | 55 | end 56 | 57 | module Counter :sig 58 | (** A counter or other time-varying integer value. *) 59 | 60 | type t 61 | 62 | val create : ?init:int -> name:string -> unit -> t 63 | val make : name:string -> t 64 | 65 | val value : t -> int 66 | val set_value : t -> int -> unit 67 | 68 | val increase : t -> int -> unit 69 | (** Record a change in the value of the metric. The change can be negative. *) 70 | 71 | end 72 | -------------------------------------------------------------------------------- /metadata: -------------------------------------------------------------------------------- 1 | /* CTF 1.8 */ 2 | typealias integer { size = 8; align = 8; signed = false; base = 10; } := uint8_t; 3 | typealias integer { size = 16; align = 8; signed = false; base = hex; } := uint16_t; 4 | typealias integer { size = 32; align = 8; signed = false; base = hex; } := uint32_t; 5 | typealias integer { size = 64; align = 8; signed = false; base = hex; } := uint64_t; 6 | typealias integer { size = 64; align = 8; signed = true; base = 10; } := int64_t; 7 | 8 | trace { 9 | major = 0; 10 | minor = 1; 11 | uuid = "05883b8d-521a-487b-b397-456ab150680c"; 12 | byte_order = le; 13 | packet.header := struct { 14 | uint32_t magic; 15 | uint8_t uuid[16]; 16 | }; 17 | }; 18 | 19 | enum thread_type : uint8_t { 20 | Wait = 0, 21 | Task = 1, 22 | Bind = 2, 23 | Try = 3, 24 | Choose = 4, 25 | Pick = 5, 26 | Join = 6, 27 | Map = 7, 28 | Condition = 8, 29 | On_success = 9, 30 | On_failure = 10, 31 | On_termination = 11, 32 | On_any = 12, 33 | Ignore_result = 13, 34 | Async = 14, 35 | }; 36 | 37 | struct event_header { 38 | uint64_t timestamp; 39 | enum : uint8_t { 40 | creates = 0, 41 | read = 1, 42 | fulfills = 2, 43 | fails = 3, 44 | becomes = 4, 45 | label = 5, 46 | increase = 6, 47 | switch = 7, 48 | gc = 8, 49 | signal = 9, 50 | try_read = 10, 51 | counter = 11, 52 | } id; 53 | } align (8); 54 | 55 | struct thread_context { 56 | uint64_t thread; 57 | } align (8); 58 | 59 | stream { 60 | packet.context := struct { 61 | uint32_t packet_size; 62 | uint16_t stream_packet_count; 63 | uint32_t content_size; 64 | 65 | }; 66 | event.header := struct event_header; 67 | }; 68 | 69 | event { 70 | name = creates; 71 | id = 0; 72 | context := struct thread_context; 73 | fields := struct { 74 | uint64_t child; 75 | enum thread_type thread_type; 76 | }; 77 | }; 78 | 79 | event { 80 | name = read; 81 | id = 1; 82 | context := struct thread_context; 83 | fields := struct { 84 | uint64_t source; 85 | }; 86 | }; 87 | 88 | event { 89 | name = fulfills; 90 | id = 2; 91 | context := struct thread_context; 92 | fields := struct { 93 | uint64_t resolvee; 94 | }; 95 | }; 96 | 97 | event { 98 | name = fails; 99 | id = 3; 100 | context := struct thread_context; 101 | fields := struct { 102 | uint64_t resolvee; 103 | string exn; 104 | }; 105 | }; 106 | 107 | event { 108 | name = becomes; 109 | id = 4; 110 | context := struct thread_context; 111 | fields := struct { 112 | uint64_t sleeper; 113 | }; 114 | }; 115 | 116 | event { 117 | name = label; 118 | id = 5; 119 | context := struct thread_context; 120 | fields := struct { 121 | string label; 122 | }; 123 | }; 124 | 125 | event { 126 | name = increase; 127 | id = 6; 128 | context := struct thread_context; 129 | fields := struct { 130 | int64_t amount; 131 | string counter; 132 | }; 133 | }; 134 | 135 | event { 136 | name = switch; 137 | id = 7; 138 | context := struct thread_context; 139 | }; 140 | 141 | event { 142 | name = gc; 143 | id = 8; 144 | fields := struct { 145 | uint64_t duration_ns; 146 | }; 147 | }; 148 | 149 | event { 150 | name = signal; 151 | id = 9; 152 | context := struct thread_context; 153 | fields := struct { 154 | uint64_t source; 155 | }; 156 | }; 157 | 158 | event { 159 | name = try_read; 160 | id = 10; 161 | context := struct thread_context; 162 | fields := struct { 163 | uint64_t source; 164 | }; 165 | }; 166 | 167 | event { 168 | name = counter; 169 | id = 11; 170 | context := struct thread_context; 171 | fields := struct { 172 | int64_t value; 173 | string counter; 174 | }; 175 | }; 176 | -------------------------------------------------------------------------------- /mirage-profile-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Collect runtime profiling information in CTF format" 3 | maintainer: "Thomas Leonard " 4 | authors: "Thomas Leonard " 5 | license: "BSD-2-clause" 6 | homepage: "https://github.com/mirage/mirage-profile" 7 | doc: "https://mirage.github.io/mirage-profile/" 8 | bug-reports: "https://github.com/mirage/mirage-profile/issues" 9 | depends: [ 10 | "ocaml" {>= "4.06.0"} 11 | "dune" {>= "1.0"} 12 | "mirage-profile" {>= "0.8.0"} 13 | "mtime" {>= "1.0.0"} 14 | "ocplib-endian" 15 | ] 16 | build: [ 17 | ["dune" "build" "-p" name "-j" jobs] 18 | ] 19 | dev-repo: "git+https://github.com/mirage/mirage-profile.git" 20 | description: """ 21 | This library can be used to trace execution of OCaml/Lwt programs (such as 22 | Mirage unikernels) at the level of Lwt threads. The traces can be viewed using 23 | JavaScript or GTK viewers provided by [mirage-trace-viewer][] or processed by 24 | tools supporting the [Common Trace Format (CTF)][ctf]. 25 | 26 | This backend adds a Unix collector. 27 | """ 28 | -------------------------------------------------------------------------------- /mirage-profile-xen.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Collect runtime profiling information in CTF format" 3 | maintainer: "Thomas Leonard " 4 | authors: "Thomas Leonard " 5 | license: "BSD-2-clause" 6 | homepage: "https://github.com/mirage/mirage-profile" 7 | doc: "https://mirage.github.io/mirage-profile/" 8 | bug-reports: "https://github.com/mirage/mirage-profile/issues" 9 | depends: [ 10 | "ocaml" {>= "4.04.0"} 11 | "dune" {>= "1.0"} 12 | "mirage-profile" {=version} 13 | "io-page-xen" 14 | "io-page" 15 | "mirage-xen-minios" 16 | "ocplib-endian" 17 | "mirage-xen" {>= "4.0.0"} 18 | "xenstore" 19 | ] 20 | build: [ 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ] 23 | dev-repo: "git+https://github.com/mirage/mirage-profile.git" 24 | description: """ 25 | This library can be used to trace execution of OCaml/Lwt programs (such as 26 | Mirage unikernels) at the level of Lwt threads. The traces can be viewed using 27 | JavaScript or GTK viewers provided by [mirage-trace-viewer][] or processed by 28 | tools supporting the [Common Trace Format (CTF)][ctf]. 29 | 30 | This library adds a Xen MirageOS backend collector. 31 | """ 32 | -------------------------------------------------------------------------------- /mirage-profile.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Collect runtime profiling information in CTF format" 3 | maintainer: "Thomas Leonard " 4 | authors: "Thomas Leonard " 5 | license: "BSD-2-clause" 6 | homepage: "https://github.com/mirage/mirage-profile" 7 | doc: "https://mirage.github.io/mirage-profile/" 8 | bug-reports: "https://github.com/mirage/mirage-profile/issues" 9 | depends: [ 10 | "ocaml" {>= "4.03.0"} 11 | "dune" {>= "1.0"} 12 | "cstruct" {>= "3.0.0"} 13 | "ppx_cstruct" {build} 14 | "ocplib-endian" 15 | "lwt" 16 | ] 17 | build: [ 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ] 20 | dev-repo: "git+https://github.com/mirage/mirage-profile.git" 21 | description: """ 22 | This library can be used to trace execution of OCaml/Lwt programs (such as 23 | Mirage unikernels) at the level of Lwt threads. The traces can be viewed using 24 | JavaScript or GTK viewers provided by [mirage-trace-viewer][] or processed by 25 | tools supporting the [Common Trace Format (CTF)][ctf]. Some example traces can 26 | be found in the blog post [Visualising an Asynchronous 27 | Monad](http://roscidus.com/blog/blog/2014/10/27/visualising-an-asynchronous-monad/). 28 | 29 | Libraries can use the functions mirage-profile provides to annotate the traces 30 | with extra information. When compiled against a normal version of Lwt, 31 | mirage-profile's functions are null-ops (or call the underlying untraced 32 | operation, as appropriate) and OCaml's cross-module inlining will optimise 33 | these calls away, meaning there should be no overhead in the non-profiling 34 | case. 35 | """ 36 | -------------------------------------------------------------------------------- /test/benchmark.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let c = MProf.Counter.make ~name:"counter" 4 | 5 | let plain_lwt () = 6 | let t1, w1 = Lwt.wait () in 7 | let t2, w2 = Lwt.task () in 8 | let b1 = t1 >>= fun () -> t2 in 9 | Lwt.wakeup w1 (); 10 | Lwt.wakeup w2 (); 11 | MProf.Counter.increase c 1; 12 | b1 13 | 14 | let profile_lwt () = 15 | let t1, w1 = MProf.Trace.named_wait "Bob" in 16 | let t2, w2 = MProf.Trace.named_task "Fred" in 17 | let b1 = t1 >>= fun () -> t2 in 18 | Lwt.wakeup w1 (); 19 | Lwt.wakeup w2 (); 20 | MProf.Counter.increase c 1; 21 | b1 22 | 23 | let test ~name fn = 24 | Gc.full_major (); 25 | let rec aux = function 26 | | 0 -> Lwt.return () 27 | | i -> fn () >>= fun () -> aux (i -1) in 28 | let n = 1000000 in 29 | let t0 = Unix.gettimeofday () in 30 | Lwt_main.run (aux n); 31 | let t1 = Unix.gettimeofday () in 32 | let time = t1 -. t0 in 33 | Printf.printf "%s: %f ns/run\n" name (1_000_000_000. *. time /. float_of_int n) 34 | 35 | let () = 36 | print_endline "Tracing OFF"; 37 | test ~name:"plain_lwt:off" plain_lwt; 38 | test ~name:"profile_lwt:off" profile_lwt; 39 | 40 | print_endline "Tracing ON"; 41 | let buffer = Bigarray.(Array1.create char c_layout 1000000) in 42 | (* let buffer = MProf_unix.mmap_buffer ~size:1000000 "example/trace.bin" in *) 43 | let log = MProf.Trace.Control.make buffer MProf_unix.timestamper in 44 | MProf.Trace.Control.start log; 45 | test ~name:"plain_lwt:on" plain_lwt; 46 | test ~name:"profile_lwt:on" profile_lwt; 47 | MProf.Trace.Control.stop log 48 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names benchmark) 3 | (libraries mirage-profile mirage-profile-unix lwt lwt.unix)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps 8 | (:< benchmark.exe)) 9 | (action 10 | (run %{<}))) 11 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_profile_unix) 3 | (public_name mirage-profile-unix) 4 | (libraries cstruct mtime.clock.os ocplib-endian ocplib-endian.bigstring) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /unix/mProf_unix.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Bigarray 4 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 5 | 6 | let timestamper log_buffer ofs = 7 | let ns = Mtime.to_uint64_ns @@ Mtime_clock.now () in 8 | EndianBigstring.LittleEndian.set_int64 log_buffer ofs ns 9 | 10 | let mmap_buffer ~size path = 11 | let fd = Unix.(openfile path [O_RDWR; O_CREAT; O_TRUNC] 0o644) in 12 | Unix.set_close_on_exec fd; 13 | Unix.ftruncate fd size; 14 | let ba = array1_of_genarray (Unix.map_file fd char c_layout true [| size |]) in 15 | Unix.close fd; 16 | ba 17 | -------------------------------------------------------------------------------- /unix/mProf_unix.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | (** Trace processes on Unix, keeping the results in a file. *) 4 | 5 | open Bigarray 6 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 7 | 8 | val timestamper : log_buffer -> int -> unit 9 | 10 | val mmap_buffer : size:int -> string -> log_buffer 11 | (** [mmap_buffer ~size path] is a trace buffer that is backed by the 12 | file at [path] (which is created if it doesn't already exist). *) 13 | -------------------------------------------------------------------------------- /xen/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_profile_xen) 3 | (public_name mirage-profile-xen) 4 | (libraries cstruct io-page lwt ocplib-endian ocplib-endian.bigstring mirage-xen xenstore.client) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /xen/mProf_xen.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2014, Thomas Leonard *) 2 | 3 | open Bigarray 4 | type log_buffer = (char, int8_unsigned_elt, c_layout) Array1.t 5 | 6 | external get_monotonic_time : unit -> int64 = "caml_get_monotonic_time" 7 | 8 | module Export = Os_xen.Xen.Export 9 | module Xs = Os_xen.Xs 10 | 11 | let timestamper buf off = 12 | EndianBigstring.LittleEndian.set_int64 buf off (get_monotonic_time ()) 13 | 14 | let make_shared_buffer ~size = 15 | let open Io_page in 16 | let n_pages = round_to_page_size size / round_to_page_size 1 in 17 | get n_pages 18 | 19 | let share_with ~domid buffer = 20 | let pages = Io_page.to_pages buffer in 21 | let open Lwt in 22 | 23 | let refs = 24 | pages |> Lwt_list.map_s (fun page -> 25 | Export.get () >>= fun gnt -> 26 | Export.grant_access ~domid ~writable:false gnt page; 27 | return gnt 28 | ) in 29 | refs >>= fun refs -> 30 | 31 | let ring_ref = refs 32 | |> List.map Os_xen.Xen.Gntref.to_string 33 | |> String.concat "," in 34 | 35 | Xs.make () 36 | >>= fun c -> 37 | Xs.(immediate c (fun h -> read h "domid")) >>= fun my_domid -> 38 | Xs.(immediate c (fun h -> getdomainpath h (int_of_string my_domid))) >>= fun domainpath -> 39 | let xs_path = Printf.sprintf "%s/data/mprof" domainpath in 40 | Xs.(transaction c (fun h -> write h (xs_path ^ "/ring-ref") ring_ref)) >>= fun () -> 41 | return () 42 | -------------------------------------------------------------------------------- /xen/mProf_xen.mli: -------------------------------------------------------------------------------- 1 | (** Trace processes on Xen, keeping the results in a memory region 2 | that is shared with another domain. *) 3 | 4 | type log_buffer = 5 | (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 6 | external get_monotonic_time : unit -> int64 = "caml_get_monotonic_time" 7 | val timestamper : EndianBigstring.bigstring -> int -> unit 8 | val make_shared_buffer : size:int -> Io_page.t 9 | val share_with : domid:int -> Io_page.t -> unit Lwt.t 10 | --------------------------------------------------------------------------------