Add 'memtrace/' from commit 'a88470c3de884182503ba5fcd4729e281e544731'

git-subtree-dir: memtrace
git-subtree-mainline: fb18b2a146dd4d5de44773fc7c9ecb8da544ea32
git-subtree-split: a88470c3de884182503ba5fcd4729e281e544731

.gitignore

···
+_build
+*.install
+*.merlin
+_opam
+

.ocamlformat

···
+profile=janestreet

CHANGES.md

···
+## v0.2.2 (2021-03-03)
+
+  - Don't write to trace file from forked child process (avoids
+    corruption from concurrent writers)
+
+  - Fix a TSDL syntax error
+
+  - Bug fixes
+
+## v0.2.1.2 (2020-03-08)
+
+More fixes for 32-bit platforms.
+
+## v0.2.1.1 (2020-02-03)
+
+Fix compilation on 32-bit platforms.
+
+## v0.2.1 (2020-01-27)
+
+Packaging fixes.
+
+## v0.2 (2020-12-08)
+
+  - New support for tracing external allocations
+
+  - Bugfix for 32-bit builds
+
+  - Better error-checking for sampling_rate parameter
+
+## v0.1.2 (2020-09-16)
+
+More packaging fixes.
+
+## v0.1.1 (2020-09-09)
+
+Packaging fixes.
+
+## v0.1 (2020-09-04)
+
+Initial release.

CONTRIBUTING.md

···
+This repository contains open source software that is developed and
+maintained by [Jane Street][js].
+
+Contributions to this project are welcome and should be submitted via
+GitHub pull requests.
+
+Signing contributions
+---------------------
+
+We require that you sign your contributions. Your signature certifies
+that you wrote the patch or otherwise have the right to pass it on as
+an open-source patch. The rules are pretty simple: if you can certify
+the below (from [developercertificate.org][dco]):
+
+```
+Developer Certificate of Origin
+Version 1.1
+
+Copyright (C) 2004, 2006 The Linux Foundation and its contributors.
+1 Letterman Drive
+Suite D4700
+San Francisco, CA, 94129
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+
+Developer's Certificate of Origin 1.1
+
+By making a contribution to this project, I certify that:
+
+(a) The contribution was created in whole or in part by me and I
+    have the right to submit it under the open source license
+    indicated in the file; or
+
+(b) The contribution is based upon previous work that, to the best
+    of my knowledge, is covered under an appropriate open source
+    license and I have the right under that license to submit that
+    work with modifications, whether created in whole or in part
+    by me, under the same open source license (unless I am
+    permitted to submit under a different license), as indicated
+    in the file; or
+
+(c) The contribution was provided directly to me by some other
+    person who certified (a), (b) or (c) and I have not modified
+    it.
+
+(d) I understand and agree that this project and the contribution
+    are public and that a record of the contribution (including all
+    personal information I submit with it, including my sign-off) is
+    maintained indefinitely and may be redistributed consistent with
+    this project or the open source license(s) involved.
+```
+
+Then you just add a line to every git commit message:
+
+```
+Signed-off-by: Joe Smith <[e-mail]>
+```
+
+Use your real name (sorry, no pseudonyms or anonymous contributions.)
+
+If you set your `user.name` and `user.email` git configs, you can sign
+your commit automatically with git commit -s.
+
+[dco]: http://developercertificate.org/
+[js]: https://opensource.janestreet.com/

LICENSE.md

···
+The MIT License
+
+Copyright (c) 2020--2026 Jane Street Group, LLC <[e-mail]>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

Makefile

···
+INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
+
+default:
+	dune build
+
+install:
+	dune install $(INSTALL_ARGS)
+
+uninstall:
+	dune uninstall $(INSTALL_ARGS)
+
+reinstall: uninstall install
+
+clean:
+	dune clean
+
+.PHONY: default install uninstall reinstall clean

README.md

···
+# memtrace
+
+A streaming client for OCaml's Memprof, which generates compact traces
+of a program's memory use.
+
+To profile the memory use of a program, start by putting this line
+somewhere at the program startup:
+
+    Memtrace.trace_if_requested ~context:Version_util.version ();;
+
+If the `MEMTRACE` environment variable is present, tracing begins to
+the filename it specifies. (If it's absent, nothing happens)
+
+The ~context parameter is optional, and can be set to any string that
+helps to identify the trace file.
+
+If the program daemonises, the call to `trace_if_requested` should
+occur *after* the program forks, to ensure the right process is
+traced.
+
+The resulting trace files can be analysed with some simple
+command-line tools in bin/, but the recommended interface is the
+memtrace viewer, which lives in:
+
+    jane/app/memtrace_viewer

bin/dump_trace.ml

···
+open Memtrace.Trace
+
+let dump filename =
+  let trace = Reader.open_ ~filename in
+  Reader.iter trace (fun time ev ->
+    Printf.printf "%010Ld " (Timedelta.to_int64 time);
+    match ev with
+    | Alloc
+        { obj_id
+        ; length
+        ; domain
+        ; nsamples
+        ; source
+        ; backtrace_buffer
+        ; backtrace_length
+        ; common_prefix
+        } ->
+      let src =
+        match source with
+        | Minor -> "alloc"
+        | Major -> "alloc_major"
+        | External -> "alloc_ext"
+      in
+      Printf.printf
+        "%010d %s %d len=%d dom=%d % 4d:"
+        (obj_id :> int)
+        src
+        nsamples
+        length
+        (domain :> int)
+        common_prefix;
+      let print_location ppf loc = Printf.fprintf ppf "%s" (Location.to_string loc) in
+      for i = 0 to backtrace_length - 1 do
+        let s = backtrace_buffer.(i) in
+        match Reader.lookup_location_code trace s with
+        | [] -> Printf.printf " $%d" (s :> int)
+        | ls -> ls |> List.iter (Printf.printf " %a" print_location)
+      done;
+      Printf.printf "\n%!"
+    | Promote (id, _) -> Printf.printf "%010d promote\n" (id :> int)
+    | Collect (id, _) -> Printf.printf "%010d collect\n" (id :> int));
+  Reader.close trace
+;;
+
+let () =
+  if Array.length Sys.argv <> 2
+  then Printf.fprintf stderr "Usage: %s <trace file>\n" Sys.executable_name
+  else dump Sys.argv.(1)
+;;

bin/dune

···
+(executables
+ (modes byte exe)
+ (names dump_trace identify subsample flamegraph hotspots strip_names)
+ (libraries memtrace unix)
+ (preprocess
+  (pps ppx_jane)))

bin/flamegraph.ml

···
+open Memtrace.Trace
+
+module StrTbl = Hashtbl.Make (struct
+    type t = string
+
+    let equal = String.equal
+    let hash = Hashtbl.hash
+  end)
+
+type summary =
+  { mutable samples : int
+  ; subsums : summary StrTbl.t
+  }
+
+let summary filename =
+  let summary = { samples = 0; subsums = StrTbl.create 20 } in
+  let count (filenames, nsamples) =
+    let lastsum =
+      List.fold_left
+        (fun sum f ->
+          if StrTbl.mem sum.subsums f
+          then StrTbl.find sum.subsums f
+          else (
+            let s = { samples = 0; subsums = StrTbl.create 10 } in
+            StrTbl.add sum.subsums f s;
+            s))
+        summary
+        filenames
+    in
+    lastsum.samples <- lastsum.samples + nsamples
+  in
+  let allocs = Hashtbl.create 20 in
+  let sz = ref 0 in
+  let nallocs = ref 0 in
+  let trace = Reader.open_ ~filename in
+  Reader.iter trace (fun _time ev ->
+    match ev with
+    | Alloc
+        { obj_id
+        ; length = _
+        ; domain = _
+        ; nsamples
+        ; source = _
+        ; backtrace_buffer
+        ; backtrace_length
+        ; common_prefix = _
+        } ->
+      let str_of_location (l : Location.t) =
+        l.defname
+        (*Printf.sprintf "%s:%d" filename line*)
+      in
+      let _print_location ppf Location.{ filename; line; start_char; end_char; _ } =
+        Printf.fprintf ppf "%s:%d:%d-%d" filename line start_char end_char
+      in
+      let filenames =
+        List.concat
+          (Array.sub backtrace_buffer 0 backtrace_length
+           |> Array.map (fun l ->
+             let locs = Reader.lookup_location_code trace l in
+             List.map (fun (Location.{ filename = _; _ } as l) -> str_of_location l) locs)
+           |> Array.to_list)
+      in
+      let seen = StrTbl.create 10 in
+      let rec dedup = function
+        | [] -> []
+        | [ x ] -> [ x ]
+        | x :: x' :: xs when x = x' -> dedup (x :: xs)
+        | x :: xs -> x :: dedup xs
+      in
+      let filenames = dedup filenames in
+      let first_filenames = (*List.rev*) filenames in
+      let first_filenames =
+        first_filenames
+        |> List.filter (fun f ->
+          if StrTbl.mem seen f
+          then false
+          else (
+            StrTbl.add seen f ();
+            true))
+      in
+      Hashtbl.add allocs obj_id (first_filenames, nsamples);
+      sz := !sz + backtrace_length;
+      incr nallocs;
+      if true then count (first_filenames, nsamples)
+    (* count (first_filenames, nsamples) *)
+    (*    first_filenames |> List.iter (Printf.printf " %s");
+      Printf.printf "\n%!"*)
+    | Promote _ -> ()
+    (*count (Hashtbl.find allocs i)*)
+    | Collect (i, _) ->
+      assert (Hashtbl.mem allocs i);
+      Hashtbl.remove allocs i);
+  Reader.close trace;
+  let rec dump_summary files_rev summary =
+    if summary.samples > 0
+    then (
+      match List.rev files_rev with
+      | [] -> ()
+      | [ _ ] -> ()
+      | x :: xs ->
+        Printf.printf "%s" x;
+        List.iter (Printf.printf ";%s") xs;
+        Printf.printf " %d\n" summary.samples);
+    let keys =
+      StrTbl.fold (fun k _ ks -> k :: ks) summary.subsums [] |> List.sort String.compare
+    in
+    keys
+    |> List.iter (fun f ->
+      let s = StrTbl.find summary.subsums f in
+      dump_summary (f :: files_rev) s)
+  in
+  dump_summary [] summary
+;;
+
+let () =
+  if Array.length Sys.argv <> 2
+  then Printf.fprintf stderr "Usage: %s <trace file>\n" Sys.executable_name
+  else summary Sys.argv.(1)
+;;

bin/hotspots.ml

···
+open Memtrace.Trace
+
+module Heavy_hitters (A : Hashtbl.HashedType) : sig
+  type t
+
+  val make : int -> t
+  val add : t -> A.t -> unit
+  val length : t -> int
+  val iter : t -> (A.t -> int -> int -> unit) -> unit
+end = struct
+  module Tbl = Hashtbl.Make (A)
+
+  type counter =
+    { (* (hits - misses) is the usual Misra-Gries summary *)
+      mutable hits : int
+    ; mutable misses : int
+    ; (* number of elements added before this one (including duplicates) *)
+      added_before : int
+    ; (* number of elements skipped before this one was added *)
+      skipped_before : int
+    }
+
+  (*let upper_bound t c =
+    c.skipped_before
+  *)
+  type t =
+    { k : int
+    ; tbl : counter Tbl.t
+    ; mutable len : int
+    ; mutable added : int
+    ; mutable skipped : int
+    }
+
+  let make k = { k; tbl = Tbl.create k; len = 0; added = 0; skipped = 0 }
+
+  let _check t =
+    let hits = ref 0 in
+    t.tbl |> Tbl.iter (fun _k c -> hits := !hits + c.hits);
+    assert (t.len = Tbl.length t.tbl);
+    assert (!hits + t.skipped = t.added);
+    ()
+  ;;
+
+  let add t x =
+    (*  check t;*)
+    (match Tbl.find_opt t.tbl x with
+     | Some c -> c.hits <- c.hits + 1
+     | None ->
+       if t.len < t.k
+       then (
+         t.len <- t.len + 1;
+         Tbl.add
+           t.tbl
+           x
+           { hits = 1; misses = 0; added_before = t.added; skipped_before = t.skipped })
+       else (
+         t.skipped <- t.skipped + 1;
+         t.tbl
+         |> Tbl.filter_map_inplace (fun _k c ->
+           c.misses <- c.misses + 1;
+           if c.hits > c.misses
+           then Some c
+           else (
+             t.len <- t.len - 1;
+             t.skipped <- t.skipped + c.hits;
+             None))));
+    t.added <- t.added + 1
+  ;;
+
+  let length t = t.added
+  let iter t f = t.tbl |> Tbl.iter (fun x c -> f x c.hits c.skipped_before)
+end
+
+module Loc_tbl = Hashtbl.Make (struct
+    type t = Location_code.t
+
+    let hash (x : Location_code.t) = ((x :> int) * 218854569) lsr 17
+    let equal (x : Location_code.t) (y : Location_code.t) = x = y
+  end)
+
+module Str_tbl = Hashtbl.Make (struct
+    type t = string
+
+    let hash = Hashtbl.hash
+    let equal = String.equal
+  end)
+
+type loc_entry =
+  { line : int
+  ; start_ch : int
+  ; end_ch : int
+  ; func : func
+  ; mutable alloc_count : int
+  }
+
+and func =
+  { id : int
+  ; name : string
+  ; filename : string
+  ; mutable locs : loc_entry list
+  ; mutable total_count : int
+  ; mutable n_allocs : int
+  ; mutable total_dist_to_alloc : int
+  }
+
+module Func_tbl = Hashtbl.Make (struct
+    type t = func
+
+    let hash (f : func) = f.id * 21089245
+    let equal (f : func) (g : func) = f.id = g.id
+  end)
+
+let total_allocs (f : func) =
+  List.fold_left (fun k e -> k + e.alloc_count) f.total_count f.locs
+;;
+
+let direct_allocs (f : func) = List.fold_left (fun k e -> k + e.alloc_count) 0 f.locs
+
+let avg_dist_to_alloc (f : func) =
+  float_of_int f.total_dist_to_alloc /. float_of_int f.n_allocs
+;;
+
+type loc_table =
+  { entries : loc_entry Loc_tbl.t
+  ; funcs : (string * string, func) Hashtbl.t
+  ; trace : Reader.t
+  ; mutable next_id : int
+  }
+
+let new_loc_table trace =
+  { entries = Loc_tbl.create 10000; funcs = Hashtbl.create 10000; trace; next_id = 0 }
+;;
+
+let rec describe_location ?(max_discard = 2) trace buf i =
+  match Reader.lookup_location_code trace buf.(i) with
+  | [] when i > 0 && max_discard > 0 ->
+    describe_location ~max_discard:(max_discard - 1) trace buf (i - 1)
+  | [] -> "??", Printf.sprintf "#%x" (buf.(i) :> int), 0, 0, 0
+  | locs ->
+    let l = List.nth locs (List.length locs - 1) in
+    l.filename, l.defname, l.line, l.start_char, l.end_char
+;;
+
+let add_loc t buf i =
+  let loc = buf.(i) in
+  match Loc_tbl.find t.entries loc with
+  | e -> e
+  | exception Not_found ->
+    let filename, funcname, line, start_ch, end_ch = describe_location t.trace buf i in
+    let func =
+      match Hashtbl.find t.funcs (filename, funcname) with
+      | func -> func
+      | exception Not_found ->
+        let id = t.next_id in
+        t.next_id <- t.next_id + 1;
+        let func : func =
+          { id
+          ; filename
+          ; name = funcname
+          ; locs = []
+          ; total_count = 0
+          ; n_allocs = 0
+          ; total_dist_to_alloc = 0
+          }
+        in
+        Hashtbl.add t.funcs (filename, funcname) func;
+        func
+    in
+    let entry = { line; start_ch; end_ch; func; alloc_count = 0 } in
+    Loc_tbl.add t.entries loc entry;
+    func.locs <- entry :: func.locs;
+    entry
+;;
+
+module HH = Heavy_hitters (struct
+    type t = func * func
+
+    let hash ((a, b) : t) = (a.id * 1231441) + (b.id * 3821)
+    let equal ((a, b) : t) ((a', b') : t) = a.id = a'.id && b.id = b'.id
+    (*
+       let hash ((a : location_code), (b : location_code)) =
+    Int64.(shift_right (add (mul (a :> int64) 0x94837298472a9321L) (mul (b :> int64) 0x4783213feac37L)) 11 |> to_int)
+  let equal (a, b) (a', b') =
+    Int64.equal (a : location_code :> int64) (a' : location_code :> int64) &&
+      Int64.equal (b : location_code :> int64) (b' : location_code:> int64)*)
+  end)
+
+let count filename =
+  let trace = Reader.open_ ~filename in
+  let hh = HH.make 10000 in
+  let seen = Func_tbl.create 100 in
+  let locs = new_loc_table trace in
+  let total_samples = ref 0 in
+  Reader.iter trace (fun _time ev ->
+    match ev with
+    | Alloc
+        { obj_id = _
+        ; length = _
+        ; domain = _
+        ; nsamples
+        ; source = _
+        ; backtrace_buffer
+        ; backtrace_length
+        ; common_prefix = _
+        } ->
+      let allocpt = add_loc locs backtrace_buffer (backtrace_length - 1) in
+      allocpt.alloc_count <- allocpt.alloc_count + nsamples;
+      Func_tbl.clear seen;
+      for i' = 0 to backtrace_length - 2 do
+        let i = backtrace_length - 2 - i' in
+        let b = (add_loc locs backtrace_buffer i).func in
+        if not (Func_tbl.mem seen b)
+        then (
+          Func_tbl.add seen b ();
+          b.total_count <- b.total_count + nsamples;
+          b.n_allocs <- b.n_allocs + 1;
+          b.total_dist_to_alloc <- b.total_dist_to_alloc + (backtrace_length - 1 - i);
+          HH.add hh (b, allocpt.func))
+      done;
+      total_samples := !total_samples + nsamples
+    | Promote _ -> ()
+    | Collect _ -> ());
+  let tinfo = Reader.info trace in
+  Reader.close trace;
+  let total_samples = !total_samples in
+  let wordsize = 8. in
+  (* FIXME: store this in the trace *)
+  let print_bytes ppf = function
+    | n when n < 100. -> Printf.fprintf ppf "%4.0f B" n
+    | n when n < 100. *. 1024. -> Printf.fprintf ppf "%4.1f kB" (n /. 1024.)
+    | n when n < 100. *. 1024. *. 1024. ->
+      Printf.fprintf ppf "%4.1f MB" (n /. 1024. /. 1024.)
+    | n when n < 100. *. 1024. *. 1024. *. 1024. ->
+      Printf.fprintf ppf "%4.1f GB" (n /. 1024. /. 1024. /. 1024.)
+    | n -> Printf.fprintf ppf "%4.1f TB" (n /. 1024. /. 1024. /. 1024. /. 1024.)
+  in
+  Printf.printf
+    "Trace for %s [%Ld]:\n   %d samples of %a allocations\n\n"
+    tinfo.executable_name
+    tinfo.pid
+    total_samples
+    print_bytes
+    (float_of_int total_samples /. tinfo.sample_rate *. wordsize);
+  let hot_allocs = Func_tbl.create 100 in
+  HH.iter hh (fun (fn, al) d1 _d2 ->
+    let alloc_prop = float_of_int (direct_allocs al) /. float_of_int total_samples in
+    if alloc_prop > 0.005
+    then (
+      let callers =
+        match Func_tbl.find hot_allocs al with
+        | c -> c
+        | exception Not_found ->
+          let c = ref [] in
+          Func_tbl.add hot_allocs al c;
+          c
+      in
+      let pair_freq = float_of_int d1 in
+      let fn_freq = float_of_int (total_allocs fn) in
+      if pair_freq /. fn_freq > max 0.10 (alloc_prop *. 1.2)
+         && pair_freq /. float_of_int total_samples > 0.005
+      then callers := (fn, d1) :: !callers));
+  let hot_allocs = Func_tbl.fold (fun al c acc -> (al, !c) :: acc) hot_allocs [] in
+  let hot_allocs =
+    List.sort
+      (fun (al, _) (al', _) -> compare (direct_allocs al') (direct_allocs al))
+      hot_allocs
+  in
+  hot_allocs
+  |> List.iter (fun (al, callers) ->
+    let freq = float_of_int (direct_allocs al) /. float_of_int total_samples in
+    let bytes = float_of_int (direct_allocs al) /. tinfo.sample_rate *. wordsize in
+    Printf.printf "%a (%4.1f%%) at %s" print_bytes bytes (100. *. freq) al.name;
+    Printf.printf " (%s:" al.filename;
+    let printed = ref 0 in
+    let locs =
+      al.locs |> List.sort (fun l1 l2 -> compare l2.alloc_count l1.alloc_count)
+    in
+    locs
+    |> List.iter (fun { line; start_ch; end_ch; alloc_count; func = _ } ->
+      if alloc_count > 0
+      then (
+        (match !printed with
+         | n when n < 3 ->
+           if n > 0 then Printf.printf ", ";
+           Printf.printf "%d:%d-%d" line start_ch end_ch
+         | 3 -> Printf.printf "..."
+         | _ -> ());
+        incr printed));
+    Printf.printf ")\n";
+    let first_caller = ref true in
+    let callers =
+      List.sort
+        (fun (_c, f) (_c', f') ->
+          (*compare (avg_dist_to_alloc c) (avg_dist_to_alloc c')*)
+          (* compare (float_of_int f' /. float_of_int (total_allocs c')) (float_of_int f /. float_of_int (total_allocs c)) *)
+          compare f' f)
+        callers
+    in
+    callers
+    |> List.iter (fun (caller, freq) ->
+      let rfreq = float_of_int freq /. float_of_int (total_allocs caller) in
+      (* let pfreq = float_of_int freq /. float_of_int total_samples in *)
+      let bytes = float_of_int freq /. tinfo.sample_rate *. wordsize in
+      if float_of_int (total_allocs caller) /. float_of_int total_samples > 0.005
+      then (
+        if !first_caller then Printf.printf "      including:\n";
+        first_caller := false;
+        Printf.printf
+          "    %a via %s (%.0f%% of this)\n"
+          print_bytes
+          bytes
+          caller.name
+          (100. *. rfreq)));
+    Printf.printf "\n")
+;;
+
+(*
+   let pair_freq = d1 in
+    let tot_freq = summarize_fn fn in
+    if 100 * pair_freq / tot_freq > 20 then begin
+      let frac_of_program = float_of_int pair_freq /. float_of_int !total_samples in
+      Printf.printf "%.1f%% % 6d % 6d % 6d %d %s %s\n" (100. *. rf) !total_samples d1 d2 tot_freq fn.name al.name
+    end)
+*)
+
+let () =
+  if Array.length Sys.argv <> 2
+  then Printf.fprintf stderr "Usage: %s <trace file>\n" Sys.executable_name
+  else count Sys.argv.(1)
+;;

bin/identify.ml

···
+open Memtrace.Trace
+
+let print_duration ppf = function
+  | n -> Printf.fprintf ppf "%.3f s" n
+;;
+
+let print_bytes ppf = function
+  | n when n < 1000. -> Printf.fprintf ppf "%3.0f B" n
+  | n when n < 1000. *. 1024. ->
+    let n = n /. 1024. in
+    Printf.fprintf ppf "%3.*f kB" (if n < 10. then 1 else 0) n
+  | n when n < 1000. *. 1024. *. 1024. ->
+    let n = n /. 1024. /. 1024. in
+    Printf.fprintf ppf "%3.*f MB" (if n < 10. then 1 else 0) n
+  | n when n < 1000. *. 1024. *. 1024. *. 1024. ->
+    let n = n /. 1024. /. 1024. /. 1024. in
+    Printf.fprintf ppf "%3.*f GB" (if n < 10. then 1 else 0) n
+  | n ->
+    let n = n /. 1024. /. 1024. /. 1024. /. 1024. in
+    Printf.fprintf ppf "%3.*f TB" (if n < 10. then 1 else 0) n
+;;
+
+let identify filename =
+  let trace = Reader.open_ ~filename in
+  let info = Reader.info trace in
+  Printf.printf
+    "Trace file %s (%a)\n"
+    filename
+    print_bytes
+    (Int64.to_float (Reader.size_bytes trace));
+  let start_time = Timestamp.to_int64 info.start_time in
+  let tm : Unix.tm = Unix.gmtime (Int64.to_float start_time *. 1e-6) in
+  let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] in
+  let months =
+    [| "Jan"
+     ; "Feb"
+     ; "Mar"
+     ; "Apr"
+     ; "May"
+     ; "Jun"
+     ; "Jul"
+     ; "Aug"
+     ; "Sep"
+     ; "Oct"
+     ; "Nov"
+     ; "Dec"
+    |]
+  in
+  Printf.printf "   of %s\n" info.executable_name;
+  Printf.printf
+    "   at %s %s %d %02d:%02d:%02d %d UTC\n"
+    days.(tm.tm_wday)
+    months.(tm.tm_mon)
+    tm.tm_mday
+    tm.tm_hour
+    tm.tm_min
+    tm.tm_sec
+    (tm.tm_year + 1900);
+  Printf.printf
+    "   on host %s (%d-bit), pid %Ld, sample rate %.1e\n"
+    info.host_name
+    info.word_size
+    info.pid
+    info.sample_rate;
+  Printf.printf "   with OCaml GC params %s\n" info.ocaml_runtime_params;
+  (match info.context with
+   | None -> ()
+   | Some c -> Printf.printf "   with context: %s\n" c);
+  Printf.printf "Trace statistics:\n%!";
+  let tmax = ref 0L in
+  let minor_live = Obj_id.Tbl.create 100 in
+  (* As an optimisation, only store allocations with nsamples > 1 *)
+  let major_live_multisampled = Obj_id.Tbl.create 100 in
+  let minor_alloc = ref 0
+  and minor_collect = ref 0
+  and promote = ref 0 in
+  let major_alloc = ref 0
+  and major_collect = ref 0 in
+  let dist4 = ref 0
+  and dist16 = ref 0
+  and dist256 = ref 0
+  and szmax = ref 0 in
+  Reader.iter ~parse_backtraces:false trace (fun t ev ->
+    tmax := Timedelta.to_int64 t;
+    match ev with
+    | Alloc { obj_id; length; nsamples; source; _ } ->
+      if source <> Minor
+      then (
+        major_alloc := !major_alloc + nsamples;
+        if nsamples > 1 then Obj_id.Tbl.add major_live_multisampled obj_id nsamples)
+      else (
+        minor_alloc := !minor_alloc + nsamples;
+        Obj_id.Tbl.add minor_live obj_id nsamples);
+      if length <= 4 then dist4 := !dist4 + nsamples;
+      if length <= 16 then dist16 := !dist16 + nsamples;
+      if length <= 256 then dist256 := !dist256 + nsamples;
+      if length > !szmax then szmax := length
+    | Promote (id, _) ->
+      assert (Obj_id.Tbl.mem minor_live id);
+      let nsamples = Obj_id.Tbl.find minor_live id in
+      Obj_id.Tbl.remove minor_live id;
+      promote := !promote + nsamples;
+      if nsamples > 1 then Obj_id.Tbl.add major_live_multisampled id nsamples
+    | Collect (id, _) ->
+      if Obj_id.Tbl.mem minor_live id
+      then (
+        let nsamples = Obj_id.Tbl.find minor_live id in
+        Obj_id.Tbl.remove minor_live id;
+        minor_collect := !minor_collect + nsamples)
+      else (
+        let nsamples =
+          match Obj_id.Tbl.find major_live_multisampled id with
+          | n ->
+            Obj_id.Tbl.remove major_live_multisampled id;
+            n
+          | exception Not_found -> 1
+        in
+        major_collect := !major_collect + nsamples));
+  let duration = Int64.to_float !tmax *. 1e-6 in
+  let bytes nsamples =
+    float_of_int nsamples /. info.sample_rate *. float_of_int (info.word_size / 8)
+  in
+  let minor_alloc = bytes !minor_alloc
+  and _minor_collect = bytes !minor_collect
+  and promote = bytes !promote in
+  let major_alloc = bytes !major_alloc
+  and major_collect = bytes !major_collect in
+  let total_alloc = minor_alloc +. major_alloc in
+  let dist4 = bytes !dist4
+  and dist16 = bytes !dist16
+  and dist256 = bytes !dist256 in
+  Printf.printf
+    "   Minor: %a/s allocations, %.1f%% promoted\n"
+    print_bytes
+    (minor_alloc /. duration)
+    (100. *. promote /. minor_alloc);
+  Printf.printf
+    "   Major: %a/s allocations (%a/s direct), %a/s collections\n"
+    print_bytes
+    ((major_alloc +. promote) /. duration)
+    print_bytes
+    (major_alloc /. duration)
+    print_bytes
+    (major_collect /. duration);
+  Printf.printf
+    "   Sizes (by word): %.0f%% <= 4w, %.0f%% <= 16w, %.0f%% <= 256w. Max: %a\n"
+    (100. *. dist4 /. total_alloc)
+    (100. *. dist16 /. total_alloc)
+    (100. *. dist256 /. total_alloc)
+    print_bytes
+    (float_of_int (!szmax * info.word_size / 8));
+  Printf.printf "   Runtime: %a\n" print_duration duration;
+  Reader.close trace
+;;
+
+let () =
+  if Array.length Sys.argv <> 2
+  then Printf.fprintf stderr "Usage: %s <trace file>\n" Sys.executable_name
+  else identify Sys.argv.(1)
+;;

bin/strip_names.ml

···
+module Anon_trace = struct
+  type obj_id = Memtrace.Trace.Obj_id.t
+  type dom_id = Memtrace.Trace.Domain_id.t
+  type timestamp = Memtrace.Trace.Timestamp.t
+  type timedelta = Memtrace.Trace.Timedelta.t
+
+  type allocation_source = Memtrace.Trace.Allocation_source.t =
+    | Minor
+    | Major
+    | External
+
+  type event =
+    | Alloc of
+        { obj_id : obj_id
+        ; domain : dom_id
+        ; length : int
+        ; nsamples : int
+        ; source : allocation_source
+        }
+    | Promote of obj_id * dom_id
+    | Collect of obj_id * dom_id
+
+  type trace_info =
+    { sample_rate : float
+    ; word_size : int
+    ; ocaml_runtime_params : string
+    }
+end
+
+module Anon_writer : sig
+  type t
+
+  val create : Unix.file_descr -> Anon_trace.trace_info -> t
+  val put_event : t -> Anon_trace.timedelta -> Anon_trace.event -> unit
+  val flush : t -> unit
+end = struct
+  open Anon_trace
+  module Trace = Memtrace.Trace
+  module Writer = Trace.Writer.Multiplexed_domains
+
+  type t = Writer.t
+
+  let start_time = Trace.Timestamp.of_int64 0L
+
+  let create fd info =
+    let { sample_rate; word_size; ocaml_runtime_params } = info in
+    let info : Trace.Info.t =
+      { sample_rate
+      ; word_size
+      ; ocaml_runtime_params
+      ; executable_name = "<anonymous>"
+      ; host_name = "<anonymous>"
+      ; pid = 0L
+      ; initial_domain = Trace.Domain_id.main_domain
+      ; start_time
+      ; context = None
+      }
+    in
+    Writer.create fd ~getpid:(fun () -> 0L) info
+  ;;
+
+  let put_event w time ev =
+    let ev : Trace.Event.t =
+      match ev with
+      | Alloc { obj_id; length; domain; nsamples; source } ->
+        Alloc
+          { obj_id
+          ; length
+          ; domain
+          ; nsamples
+          ; source
+          ; backtrace_buffer = [||]
+          ; backtrace_length = 0
+          ; common_prefix = 0
+          }
+      | Promote (id, dom) -> Promote (id, dom)
+      | Collect (id, dom) -> Collect (id, dom)
+    in
+    Writer.put_event
+      w
+      (Trace.Timedelta.offset start_time time)
+      ev
+      ~decode_callstack_entry:(fun _ -> assert false)
+  ;;
+
+  let flush = Writer.flush
+end
+
+module Anon_reader : sig
+  type t
+
+  val open_ : filename:string -> t
+  val info : t -> Anon_trace.trace_info
+  val iter : t -> (Anon_trace.timedelta -> Anon_trace.event -> unit) -> unit
+  val close : t -> unit
+end = struct
+  open Anon_trace
+  module Trace = Memtrace.Trace
+  module Reader = Trace.Reader
+
+  type t = Reader.t
+
+  let open_ = Reader.open_
+
+  let info r =
+    let { sample_rate; word_size; ocaml_runtime_params; _ } : Trace.Info.t =
+      Reader.info r
+    in
+    { sample_rate; word_size; ocaml_runtime_params }
+  ;;
+
+  let iter r f =
+    Reader.iter r (fun time (ev : Trace.Event.t) ->
+      let ev =
+        match ev with
+        | Alloc { obj_id; length; domain; nsamples; source; _ } ->
+          Alloc { obj_id; length; domain; nsamples; source }
+        | Promote (id, dom) -> Promote (id, dom)
+        | Collect (id, dom) -> Collect (id, dom)
+      in
+      f time ev)
+  ;;
+
+  let close = Reader.close
+end
+
+let strip_names infile outfile =
+  let r = Anon_reader.open_ ~filename:infile in
+  let wfd = Unix.openfile outfile [ O_CREAT; O_WRONLY; O_TRUNC ] 0o600 in
+  let w = Anon_writer.create wfd (Anon_reader.info r) in
+  Anon_reader.iter r (Anon_writer.put_event w);
+  Anon_writer.flush w;
+  Unix.close wfd;
+  Anon_reader.close r
+;;
+
+let () =
+  if Array.length Sys.argv <> 3
+  then Printf.fprintf stderr "Usage: %s <input> <output>\n" Sys.executable_name
+  else strip_names Sys.argv.(1) Sys.argv.(2)
+;;

bin/subsample.ml

···
+open Memtrace.Trace
+
+let copy inf outf fact tstart tend =
+  let id_remap = Obj_id.Tbl.create 20 in
+  let r = Reader.open_ ~filename:inf in
+  let wfd = Unix.openfile outf [ O_CREAT; O_WRONLY; O_TRUNC ] 0o600 in
+  let info = Reader.info r in
+  let info = { info with sample_rate = info.sample_rate /. float_of_int fact } in
+  let pid = info.pid in
+  let w = Writer.Multiplexed_domains.create wfd ~getpid:(fun () -> pid) info in
+  Reader.iter r (fun now ev ->
+    let ev : Event.t option =
+      match ev with
+      | Alloc ({ obj_id; _ } as e) ->
+        let now_i = Int64.to_int (Int64.div (Timedelta.to_int64 now) 1_000_000L) in
+        if tstart <= now_i && now_i < tend
+        then (
+          let samples = ref 0 in
+          for _i = 1 to e.nsamples do
+            if Random.int fact = 0 then incr samples
+          done;
+          if !samples > 0
+          then (
+            let id = Writer.Multiplexed_domains.next_alloc_id w ~domain:e.domain in
+            let ev = Event.Alloc { e with obj_id = id; nsamples = !samples } in
+            Obj_id.Tbl.add id_remap obj_id id;
+            Some ev)
+          else None)
+        else None
+      | Promote (id, dom) ->
+        if Obj_id.Tbl.mem id_remap id
+        then Some (Promote (Obj_id.Tbl.find id_remap id, dom))
+        else None
+      | Collect (id, dom) ->
+        if Obj_id.Tbl.mem id_remap id
+        then (
+          let id' = Obj_id.Tbl.find id_remap id in
+          Obj_id.Tbl.remove id_remap id;
+          Some (Event.Collect (id', dom)))
+        else None
+    in
+    match ev with
+    | None -> ()
+    | Some ev ->
+      Writer.Multiplexed_domains.put_event
+        w
+        ~decode_callstack_entry:(fun loc -> Reader.lookup_location_code r loc)
+        (Timedelta.offset info.start_time now)
+        ev);
+  Reader.close r;
+  Writer.Multiplexed_domains.flush w;
+  Unix.close wfd
+;;
+
+let parseint f =
+  match int_of_string f with
+  | n -> n
+  | exception _ ->
+    Printf.fprintf stderr "argument must be an integer (got %s)\n" f;
+    exit 1
+;;
+
+let () =
+  match Sys.argv with
+  | [| _; inf; outf; fact |] ->
+    let fact = parseint fact in
+    copy inf outf fact min_int max_int
+  | [| _; inf; outf; fact; tstart; tend |] ->
+    let fact = parseint fact in
+    let tstart = parseint tstart in
+    let tend = parseint tend in
+    copy inf outf fact tstart tend
+  | _ ->
+    Printf.fprintf
+      stderr
+      "usage: subsample <in> <out> <subsampling factor> [<start time> <end time>]\n%!";
+    exit 1
+;;

docs/internal.md

···
+# The enthusiast's guide to Memtrace
+
+Memtrace is a tracing system for profiling the memory usage and
+allocation patterns of OCaml programs. This guide explains how it
+works internally, and describes some of the efficiency tricks it
+uses. (If your goal is learning to use Memtrace rather than learning
+how it works, this is not the document for you).
+
+Memtrace files consist of a sequence of timestamped GC events:
+allocations, promotions and collections. Each allocation event carries
+a backtrace, captured at the time of the allocation. Each promotion
+or collection event is associated with a specific allocation, allowing
+analysis of object lifetimes.
+
+A common source of trouble with tracing systems is that the resulting
+trace files can grow large, making them annoying to transport and slow
+to process. Traces can also be fragile, requiring the exact original
+binary (and any loaded shared libraries or plugins) to interpret
+correctly.
+
+Memtrace was specifically designed to avoid these issues, producing
+compact self-contained traces. It's instructive to compare the trace
+sizes with those produced by `perf record`. Perf is a very different
+system from memtrace, sampling based on time rather than GC
+behaviour. However, the resulting trace files are similar, as they
+also consist of a sequence of timestamped events with associated
+backtraces.
+
+The graph below shows the trace sizes in average bytes / sample,
+across several runs of a benchmark with
+different sample rates. The comparison is a little unfair to memtrace:
+first, memtrace stores more information per sample than perf
+(e.g. object length, whether an allocation was in the major heap).
+Second, each sample in memtrace may produce up to three concrete
+timestamped events (allocation + promotion + collection), and the
+sizes shown below are the sum of the three, compared to perf's single
+event per sample.
+
+![Sizes of memtrace vs. perf traces](memtrace-vs-perf-sizes.png)
+
+As we can see, at the same sample rate memtrace traces are more than
+an order of magnitude smaller than perf's, no matter which of perf's
+three backtrace mechanisms (`lbr`, `fp` or `dwarf`) is in use. When
+perf's backtraces are disabled entirely (`perf-none` above), perf
+still produces somewhat larger files than memtrace, due to a less
+efficient binary format.
+
+To analyse these traces, perf requires access to the original 167 MB
+binary. Memtrace, on the other hand, stores enough debug info inline
+in the trace to recover full location information without needing the
+binary. In the benchmarks above, the total size of this debug info
+ranges from 10 KB to 70 KB (and is not shown in the graph above).
+
+There are two aspects to tracing with Memtrace: sampling allocations,
+and efficiently encoding the sampled data.
+
+
+## Sampling allocations with Gc.Memprof
+
+The sampling engine behind memtrace is OCaml's new `Gc.Memprof`
+module.
+
+`Gc.Memprof` accepts a *sampling rate* and a set of callbacks. The
+sampling rate is in units of probability: at rate `1e-5`, each
+allocated word has a one in 10^5 chance of being sampled. Since the
+sampling rate is per word rather than per allocation, larger
+allocations are more likely to be sampled.
+
+Since each word allocated has an independent chance of being
+sampled, the number of words until the next sample is distributed
+according to a geometric distribution. `Gc.Memprof` draws from this
+geometric distribution, and takes a sample after that much memory has
+been allocated.
+
+OCaml uses a *bump-pointer* allocator on its minor heap: allocations
+work by subtracting the desired amount of memory from the minor heap
+pointer, and comparing to the minor heap limit. Rather than
+introducing an extra branch, `Gc.Memprof` works by changing the minor
+heap limit to the position of the next sample, as though the minor
+heap ended at that point.
+
+Eventually, an allocation will fail when it hits this limit, using
+OCaml's existing heap-limit check. `Gc.Memprof` then invokes a callback,
+and resets the minor heap limit by re-drawing from the geometric
+distribution. This minimises overhead: the only branch needed is the
+heap-limit check that's already present.
+
+When an allocation is sampled, it's added to an internal GC data
+structure so that `Gc.Memprof` can invoke callbacks when it is
+promoted to the major heap and/or collected. This way, the entire
+lifetime of a sampled object is visible.
+
+
+### Comballoc
+
+OCaml's `comballoc` optimisation introduces a major complication to
+this scheme. Multiple consecutive allocations can be combined into a
+single allocation, with a single heap-limit test. Although these are
+allocated simultaneously, these allocations may not have the same
+lifetime. They may not even have the same backtrace, as they can be
+the result of different levels of inlining.
+
+The debug information used to convert backtraces to readable form was
+extended to deal with this case, maintaining multiple debug entries
+for a single allocation instruction when allocations are combined.
+This means that if an allocation of 2 words is combined with an
+adjacent allocation of 3 words, about 40% of the samples will be
+associated with the smaller object and about 60% with the larger.
+
+
+### Collecting backtraces efficiently
+
+`Gc.Memprof` collects a backtrace on each sampled allocation, which is
+something that needs to be efficient.
+
+Collecting a backtrace efficiently at an arbitrary point in an
+arbitrary program is hard. There are three standard approaches,
+available as options in `perf record`:
+
+  - `--call-graph=dwarf` uses the DWARF debugging information
+    
+  - `--call-graph=fp` follows a chain of frame pointers
+  
+  - `--call-graph=lbr` uses the Last Branch Record hardware support
+
+However, all of these have disadvantages:
+
+  - DWARF exists to support debuggers, and so is designed for
+    flexibility rather than speed.
+    
+    This flexibility is necessary to handle the hard cases of C stack
+    frames: for instance, a C program can define a variable-length
+    array of ints on the stack, and store its length (in ints, not
+    bytes) in a callee-save register that later gets spilled. So, in
+    order to work out the length of a C stack frame, you may need to
+    walk several *other* frames to find the register and do some
+    arbitrary arithmetic to compute the length.
+    
+    So, the DWARF format allows stack frames to attach an arbitrary
+    program in the DWARF bytecode language to express how to find the
+    next frame. Decoding these is slow and complicated, and perf
+    doesn't try: when sampling, it simply copies a chunk of stack (8KB
+    by default) to the trace, to decode offline. This results in very
+    large traces, which can still be incomplete as OCaml programs often
+    use more than 8KB of stack.
+    
+  - Frame pointers change the function calling convention to
+    continually maintain a linked list of stack frames so that it's
+    available should a backtrace be taken. This adds a small, but
+    nonzero overhead to every function call and return, and reserves a
+    register. It also requires a special build, as OCaml does not use
+    frame pointers by default.
+    
+  - LBR is generally the best option, but has a couple of limitations:
+    First, it requires hardware support which is not currently available on
+    UID boxes, and second, where available it is implemented with a fixed-size
+    hardware ring buffer (32 entries on Skylake). Should the ring
+    buffer overflow, entries are dropped, so deep stacks cannot be
+    accurately recorded. (However, there is some very recent
+    experimental support in perf for [heuristically stitching together
+    LBR stacks from different
+    samples](https://lwn.net/Articles/802821/), which may help).
+
+Happily, `Gc.Memprof` doesn't have to collect a backtrace at an
+arbitrary point in an arbitrary program, but only a backtrace at an
+allocation site in an OCaml program.  Because OCaml is a
+garbage-collected language with precise marking, it already needs to
+be able to traverse the stack at allocation sites. This traversal needs
+to be accurate and efficient, because it's done at every GC. It's
+implemented with a large hashtable, which maps every return address
+and allocation site to a `frame_descr`, which contains the length of
+the stack frame (amongst other information). Traversing the stack
+using this hashtable is almost as efficient as following frame
+pointers, but without the runtime overhead.
+
+
+## Compressing traces with memtrace
+
+The job of the memtrace library is to take the information collected
+by `Gc.Memprof` and stream it efficiently to a file. The largest
+portion of this data by far is the backtraces associated with each
+allocation.
+
+Backtraces arrive as a sequence of entries (opaque 64-bit integers),
+which you can think of as return addresses. (They're actually pointers
+to a static structure generated by the OCaml compiler, which includes
+the return address and a couple of other bits of information). Each of
+these entries can be *decoded* into locations, which contain a source
+filename, line/column position, and function name. Note that a single
+entry may yield several locations, due to inlining.
+
+Naively encoding these backtraces would be expensive. OCaml programs
+often have deep stacks, with dozens or hundreds of entries in a
+backtrace. Even though the entries themselves are only 8 bytes long,
+the location information can be much larger. (Remember, it is a design
+goal of memtrace to include all relevant location information in the
+trace, rather than relying on the user to hold onto the original binary)
+
+Instead, memtrace uses a series of optimisations to encode backtraces
+efficiently.
+
+### Common prefixes
+
+The first optimisation is to observe that the backtraces from
+consecutive samples often have a common prefix. There are two reasons
+for this:
+
+  - Consecutive samples are close together in time. Whatever the
+    program was doing during the last sample, there's a good chance
+    it's still doing it.
+
+  - Many programs have some driver structure wrapping the main
+    function, causing there to be the same few entries at
+    the start of nearly every single backtrace.
+
+So, the first thing memtrace does is compare the start of each
+backtrace to the start of the last. The number of common entries is
+written to the trace file, and those entries are skipped entirely,
+saving space.
+
+
+### Location information and caching
+
+Since the location information is much larger than the 8-byte
+backtrace entry, it's important to avoid encoding it redundantly.
+Memtrace keeps a cache of previously-seen backtrace entries, and
+location information is only decoded and written to the trace file on
+cache misses. In other words, location information need only be
+written to a trace file the first time a given location is seen. Since
+most backtraces hit a relatively small set of locations, this cache
+has an extremely high hit rate.
+
+There are also some minor optimisations in writing the location
+information: first, the line and column numbers are written in the
+same bit-packed format that OCaml uses internally, and second, file
+and function names use a simple 31-element move-to-front coder, so
+that file and function names need not be written if they are among the
+31 most recently used names.
+
+
+### Cache design
+
+In order to ensure good performance and to bound memory use, memtrace
+uses a fixed-size cache rather than letting it grow without bound.
+This does mean that it's possible for the location information about
+an entry to be written redundantly: if an entry is evicted from the
+cache then its locations will have to be written again the next time
+it's seen. However, this does not happen much in practice.
+
+For speed, the cache is a not a full LRU cache, but rather a two-way
+skewed-associative cache. In this cache design, each entry is hashed
+twice, giving two cache buckets. If either contains the entry, it's a
+hit, otherwise the older of the two is evicted.
+
+
+### Encoding cache indices
+
+The fixed-size cache has 16384 (i.e. `2^14`) entries. In the
+overwhelmingly common case of a cache hit, memtrace writes the bucket
+index rather than the entry to the trace file. This means that the
+64-bit backtrace entry is instead encoded in 14 bits.
+
+The full 64-bit backtrace entries need only be written during cache
+misses, along with the cache bucket index into which they're being
+inserted. This ensures there's enough information in the trace for the
+trace reader to reconstruct the cache state and know which buckets
+map to which backtrace entries.
+
+The 14-bit cach bucket index word is written in two bytes, leaving a
+two-bit tag having four possible states. One of these states is used
+for cache misses, but the other three are used for a further
+optimisation: prediction.
+
+
+### Prediction
+
+It is often possible to predict the next entry in a backtrace: most of
+the time, the target of a function call is the same as it was last
+time.  So, memtrace maintains an extra field in its cache: in each
+cache bucket, we also store the cache bucket of the entry that
+previously followed this one. This is used as a prediction: if
+correct, we can encode backtraces more compactly.
+
+Specifically, after every cache hit, we follow the chain of
+predictions until it mispredicts something. The cache is then encoded
+as one of three cases: 0 correct predictions, 1 correct prediction, or
+up to 256 correct predictions as specified by a supplemental byte.
+
+This encoding is extremely effective for long chains of
+non-tail-recursive functions. For instance, suppose we are encoding a
+backtrace that's using the OCaml stdlib's non-tail-recursive
+`List.map`, where the backtrace consists of 200 frames of `List.map`
+followed by one frame of some other function doing an allocation.
+
+This backtrace gets encoded in 7 bytes:
+
+  - 2 bytes: the first `List.map` frame and 0 correct predictions.
+    (assuming we get unlucky with the prediction here)
+    
+  - 2 bytes: the next `List.map` frame. The prediction for `List.map`
+    was updated by the previous frame, so now predicts correctly.
+    
+  - 1 byte: the number 198, indicating 198 correct predictions
+    following the previous frame.
+    
+  - 2 bytes: the actual function doing the allocation.
+  
+(Of course, it's possible that we get lucky on the first frame, and
+encode this backtrace in 5 bytes)
+
+
+### More tricks?
+
+There is a lot more that could be done here. The prediction model is
+very simplistic, always predicting whichever way it went last time.
+There is much room for improvement:
+
+  - we could allow multiple possible predictions, allowing more than 
+    one possibility to be encoded efficiently (eventually leading to
+    PPM-style compressors)
+
+  - we could use more than one previous frame as context for the next,
+    or do LZ77-style substring matches.
+    
+  - we could allow weak/strong predictions as used in CPU branch
+    predictors, where a prediction that's worked in the past must be
+    wrong more than once to be replaced.
+
+However, even the relatively simple caching / prediction model
+currently in use is highly effective: the average encoded size is
+on the order of 10 bytes for an entire backtrace.
+
+
+### Other optimisations
+
+In fact, with the optimisations above backtraces became sufficiently
+short that the fixed-size fields of the trace (timestamps, etc.)
+started to become a significant fraction of the total file size. So,
+memtrace currently does a number of packing tricks to keep size down
+there too:
+
+
+  - Integers that are usually small use a variable-length encoding,
+    meaning most of them fit in one byte.
+  
+  - Allocation IDs are used in promotion and collection events to
+    specify which block was collected. They have a relative encoding:
+    instead of "collect allocation N", they encode "collect the Nth
+    most recent allocation". This means that N is usually small and
+    profits from the variable-length integer encoding.
+  
+  - The most common cases (small allocations on the minor heap, with
+    only one sample, and <= 256 backtrace entries) are given special
+    event codes to save space.
+
+  - Timestamps are truncated, allowing the timestamp and the event
+    type field to fit in the same 32-bit word. Short timestamps
+    overflow after just over 30 seconds, but the format ensures there
+    is at least one full 64-bit timestamp every 30 seconds (in a CTF
+    packet header), so all timestamps can be decoded unambiguously.
+
+
+### For more
+
+If you're curious about the exact format, go look at
+`src/memtrace.tsdl` in the memtrace sources, which specifies the whole
+format in CTF's TSDL language.

dune-project

···
+(lang dune 3.17)

memtrace.opam

···
+opam-version: "2.0"
+maintainer: "Jane Street developers"
+authors: ["Jane Street Group, LLC"]
+homepage: "https://github.com/janestreet/memtrace"
+bug-reports: "https://github.com/janestreet/memtrace/issues"
+dev-repo: "git+https://github.com/janestreet/memtrace.git"
+doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/memtrace/index.html"
+license: "MIT"
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+]
+depends: [
+  "ocaml" {>= "4.11.0"}
+  "base-threads"
+  "dune"         {>= "3.17.0"}
+]
+available: arch != "arm32" & arch != "x86_32"
+synopsis: "Streaming client for Memprof"
+description: "
+Generates compact traces of a program's memory use.
+"

src/backtrace_codec.ml

···
+let cache_size = 1 lsl 14
+
+type cache_bucket = int (* 0 to cache_size - 1 *)
+
+module Writer = struct
+  open Buf.Write
+
+  (* The writer cache carries slightly more state than the reader cache,
+     since the writer must make decisions about which slot to use.
+     (The reader just follows the choices made by the writer) *)
+  type t =
+    { cache : int array
+    ; cache_date : int array
+    ; (* when an entry was added to the cache (used for eviction) *)
+      cache_next : cache_bucket array
+    ; (* last time we saw this entry, which entry followed it? *)
+      mutable next_verify_ix : int
+    }
+
+  let create () =
+    { cache = Array.make cache_size 0
+    ; cache_date = Array.make cache_size 0
+    ; cache_next = Array.make cache_size 0
+    ; next_verify_ix = 4242
+    }
+  ;;
+
+  let max_length = 4096
+
+  let put_backtrace
+    cache
+    b
+    ~alloc_id
+    ~callstack
+    ~callstack_pos
+    ~callstack_len
+    ~log_new_location
+    =
+    let max_entry = 2 + 8 in
+    let limit = b.pos + max_length - max_entry in
+    let put_hit b bucket ncorrect =
+      match ncorrect with
+      | 0 -> put_16 b (bucket lsl 2)
+      | 1 -> put_16 b ((bucket lsl 2) lor 1)
+      | n ->
+        put_16 b ((bucket lsl 2) lor 2);
+        put_8 b n
+    in
+    let rec code_no_prediction predictor pos ncodes =
+      if pos < callstack_pos || b.pos > limit
+      then ncodes
+      else (
+        let mask = cache_size - 1 in
+        let slot = callstack.(pos) in
+        (* Pick the least recently used of two slots, selected by two
+           different hashes. *)
+        let hash1 = ((slot * 0x4983723) lsr 11) land mask in
+        let hash2 = ((slot * 0xfdea731) lsr 21) land mask in
+        if cache.cache.(hash1) = slot
+        then code_cache_hit predictor hash1 pos ncodes
+        else if cache.cache.(hash2) = slot
+        then code_cache_hit predictor hash2 pos ncodes
+        else (
+          (* cache miss *)
+          log_new_location ~index:pos;
+          let bucket =
+            if cache.cache_date.(hash1) < cache.cache_date.(hash2) then hash1 else hash2
+          in
+          (* Printf.printf "miss %05d %016x\n%!"
+               bucket slot; (*" %016x\n%!" bucket slot;*) *)
+          cache.cache.(bucket) <- slot;
+          cache.cache_date.(bucket) <- alloc_id;
+          cache.cache_next.(predictor) <- bucket;
+          put_16 b ((bucket lsl 2) lor 3);
+          put_64 b (Int64.of_int slot);
+          code_no_prediction bucket (pos - 1) (ncodes + 1)))
+    and code_cache_hit predictor hit pos ncodes =
+      (* Printf.printf "hit %d\n" hit; *)
+      cache.cache_date.(hit) <- alloc_id;
+      cache.cache_next.(predictor) <- hit;
+      code_with_prediction hit hit 0 (pos - 1) (ncodes + 1)
+    and code_with_prediction orig_hit predictor ncorrect pos ncodes =
+      assert (ncorrect < 256);
+      if pos < callstack_pos || b.pos + 2 > limit
+      then (
+        put_hit b orig_hit ncorrect;
+        ncodes)
+      else (
+        let slot = callstack.(pos) in
+        let pred_bucket = cache.cache_next.(predictor) in
+        if cache.cache.(pred_bucket) = slot
+        then
+          (* correct prediction *)
+          (* Printf.printf "pred %d %d\n" pred_bucket ncorrect; *)
+          if ncorrect = 255
+          then (
+            (* overflow: code a new prediction block *)
+            put_hit b orig_hit ncorrect;
+            code_cache_hit predictor pred_bucket pos ncodes)
+          else code_with_prediction orig_hit pred_bucket (ncorrect + 1) (pos - 1) ncodes
+        else (
+          (* incorrect prediction *)
+          put_hit b orig_hit ncorrect;
+          code_no_prediction predictor pos ncodes))
+    in
+    code_no_prediction 0 (callstack_len - 1) 0
+  ;;
+
+  let put_cache_verifier cache b =
+    let ix = cache.next_verify_ix in
+    cache.next_verify_ix <- (cache.next_verify_ix + 5413) land (cache_size - 1);
+    put_16 b ix;
+    put_16 b cache.cache_next.(ix);
+    put_64 b (Int64.of_int cache.cache.(ix))
+  ;;
+
+  let put_dummy_verifier b =
+    put_16 b 0xffff;
+    put_16 b 0;
+    put_64 b 0L
+  ;;
+end
+
+module Reader = struct
+  open Buf.Read
+
+  type t =
+    { cache_loc : int array
+    ; cache_pred : int array
+    ; mutable last_backtrace : int array
+    ; mutable last_backtrace_len : int
+    }
+
+  let create () =
+    { cache_loc = Array.make cache_size 0
+    ; cache_pred = Array.make cache_size 0
+    ; last_backtrace = [||]
+    ; last_backtrace_len = 0
+    }
+  ;;
+
+  let[@inline never] realloc_bbuf bbuf pos (x : int) =
+    assert (pos = Array.length bbuf);
+    let new_size = Array.length bbuf * 2 in
+    let new_size = if new_size < 32 then 32 else new_size in
+    let new_bbuf = Array.make new_size x in
+    Array.blit bbuf 0 new_bbuf 0 pos;
+    new_bbuf
+  ;;
+
+  let[@inline] put_bbuf bbuf pos (x : int) =
+    if pos < Array.length bbuf
+    then (
+      Array.unsafe_set bbuf pos x;
+      bbuf)
+    else realloc_bbuf bbuf pos x
+  ;;
+
+  let get_backtrace ({ cache_loc; cache_pred; _ } as cache) b ~nencoded ~common_pfx_len =
+    let rec decode pred bbuf pos = function
+      | 0 -> bbuf, pos
+      | i ->
+        let codeword = get_16 b in
+        let bucket = codeword lsr 2
+        and tag = codeword land 3 in
+        cache_pred.(pred) <- bucket;
+        (match tag with
+         | 0 ->
+           (* cache hit, 0 prediction *)
+           let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
+           predict bucket bbuf (pos + 1) (i - 1) 0
+         | 1 ->
+           (* cache hit, 1 prediction *)
+           let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
+           predict bucket bbuf (pos + 1) (i - 1) 1
+         | 2 ->
+           (* cache hit, N prediction *)
+           let ncorrect = get_8 b in
+           let bbuf = put_bbuf bbuf pos cache_loc.(bucket) in
+           predict bucket bbuf (pos + 1) (i - 1) ncorrect
+         | _ ->
+           (* cache miss *)
+           let lit = Int64.to_int (get_64 b) in
+           cache_loc.(bucket) <- lit;
+           let bbuf = put_bbuf bbuf pos lit in
+           decode bucket bbuf (pos + 1) (i - 1))
+    and predict pred bbuf pos i = function
+      | 0 -> decode pred bbuf pos i
+      | n ->
+        let pred' = cache_pred.(pred) in
+        let bbuf = put_bbuf bbuf pos cache_loc.(pred') in
+        predict pred' bbuf (pos + 1) i (n - 1)
+    in
+    if common_pfx_len <= cache.last_backtrace_len
+    then (
+      let bbuf, pos = decode 0 cache.last_backtrace common_pfx_len nencoded in
+      cache.last_backtrace <- bbuf;
+      cache.last_backtrace_len <- pos;
+      bbuf, pos)
+    else (
+      (* This can occur if the last backtrace was truncated, and the current
+         backtrace shares a long prefix with it. Return the amount of backtrace
+         that we have. (We still go through the motions of decoding to ensure
+         that the location cache is updated correctly) *)
+      let _bbuf, _pos = decode 0 [||] 0 nencoded in
+      cache.last_backtrace, cache.last_backtrace_len)
+  ;;
+
+  let skip_backtrace _cache b ~nencoded ~common_pfx_len:_ =
+    for _ = 1 to nencoded do
+      let codeword = get_16 b in
+      if codeword land 3 = 2
+      then ignore (get_8 b) (* hitN *)
+      else if codeword land 3 = 3
+      then ignore (get_64 b)
+      (* miss *)
+    done
+  ;;
+
+  type cache_verifier =
+    { ix : int
+    ; pred : int
+    ; value : Int64.t
+    }
+
+  let get_cache_verifier b =
+    let ix = get_16 b in
+    let pred = get_16 b in
+    let value = get_64 b in
+    { ix; pred; value }
+  ;;
+
+  let check_cache_verifier cache { ix; pred; value } =
+    if ix <> 0xffff
+    then
+      0 <= ix
+      && ix < Array.length cache.cache_loc
+      && cache.cache_pred.(ix) = pred
+      && cache.cache_loc.(ix) = Int64.to_int value
+    else true
+  ;;
+end

src/backtrace_codec.mli

···
+module Writer : sig
+  type t
+
+  val create : unit -> t
+
+  (* Maximum number of bytes written by put_backtrace *)
+  val max_length : int
+
+  val put_backtrace
+    :  t
+    -> Buf.Write.t
+    -> alloc_id:int
+    -> callstack:int array
+    -> callstack_pos:int
+    -> callstack_len:int
+    -> log_new_location:(index:int -> unit)
+    -> int (* number of encoded slots *)
+
+  val put_cache_verifier : t -> Buf.Write.t -> unit
+  val put_dummy_verifier : Buf.Write.t -> unit
+end
+
+module Reader : sig
+  type t
+
+  val create : unit -> t
+
+  val get_backtrace
+    :  t
+    -> Buf.Read.t
+    -> nencoded:int
+    -> common_pfx_len:int
+    -> int array * int
+
+  val skip_backtrace : t -> Buf.Read.t -> nencoded:int -> common_pfx_len:int -> unit
+
+  type cache_verifier
+
+  val get_cache_verifier : Buf.Read.t -> cache_verifier
+  val check_cache_verifier : t -> cache_verifier -> bool
+end

src/buf.ml

···
+module Shared_writer_fd = struct
+  type t =
+    { lock : Mutex.t
+    ; closed : bool Atomic.t
+    ; fd : Unix.file_descr
+    }
+
+  let make fd = { lock = Mutex.create (); closed = Atomic.make false; fd }
+
+  exception Closed
+
+  let rec write_fully fd buf ~pos ~len =
+    if len = 0
+    then ()
+    else (
+      let written = Unix.write fd buf pos len in
+      write_fully fd buf ~pos:(pos + written) ~len:(len - written))
+  ;;
+
+  let write_fully t buf ~pos ~len =
+    Mutex.lock t.lock;
+    Fun.protect
+      (fun () ->
+        if Atomic.get t.closed then raise Closed;
+        write_fully t.fd buf ~pos ~len)
+      ~finally:(fun () -> Mutex.unlock t.lock)
+  ;;
+
+  let close t =
+    Mutex.lock t.lock;
+    Atomic.set t.closed true;
+    Mutex.unlock t.lock
+  ;;
+end
+
+module Shared = struct
+  type t =
+    { buf : Bytes.t
+    ; mutable pos : int
+    ; pos_end : int
+    }
+
+  let of_bytes buf = { buf; pos = 0; pos_end = Bytes.length buf }
+  let of_bytes_sub buf ~pos ~pos_end = { buf; pos; pos_end }
+  let remaining b = b.pos_end - b.pos
+
+  external bswap_16 : int -> int = "%bswap16"
+  external bswap_32 : int32 -> int32 = "%bswap_int32"
+  external bswap_64 : int64 -> int64 = "%bswap_int64"
+end
+
+module Write = struct
+  include Shared
+
+  let write_fd fd b = Shared_writer_fd.write_fully fd b.buf ~pos:0 ~len:b.pos
+  let put_raw_8 b i v = Bytes.unsafe_set b i (Char.unsafe_chr v)
+
+  external put_raw_16 : Bytes.t -> int -> int -> unit = "%caml_bytes_set16u"
+  external put_raw_32 : Bytes.t -> int -> int32 -> unit = "%caml_bytes_set32u"
+  external put_raw_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64u"
+
+  exception Overflow of int
+
+  let[@inline never] overflow b = Overflow b.pos
+
+  let[@inline always] put_8 b v =
+    let pos = b.pos in
+    let pos' = b.pos + 1 in
+    if pos' > b.pos_end
+    then raise (overflow b)
+    else (
+      put_raw_8 b.buf pos v;
+      b.pos <- pos')
+  ;;
+
+  let[@inline always] put_16 b v =
+    let pos = b.pos in
+    let pos' = b.pos + 2 in
+    if pos' > b.pos_end
+    then raise (overflow b)
+    else (
+      put_raw_16 b.buf pos (if Sys.big_endian then bswap_16 v else v);
+      b.pos <- pos')
+  ;;
+
+  let[@inline always] put_32 b v =
+    let pos = b.pos in
+    let pos' = b.pos + 4 in
+    if pos' > b.pos_end
+    then raise (overflow b)
+    else (
+      put_raw_32 b.buf pos (if Sys.big_endian then bswap_32 v else v);
+      b.pos <- pos')
+  ;;
+
+  let[@inline always] put_64 b v =
+    let pos = b.pos in
+    let pos' = b.pos + 8 in
+    if pos' > b.pos_end
+    then raise (overflow b)
+    else (
+      put_raw_64 b.buf pos (if Sys.big_endian then bswap_64 v else v);
+      b.pos <- pos')
+  ;;
+
+  let[@inline always] put_float b f = put_64 b (Int64.bits_of_float f)
+
+  let put_string b s =
+    let slen =
+      match String.index_opt s '\000' with
+      | Some i -> i
+      | None -> String.length s
+    in
+    if b.pos + slen + 1 > b.pos_end then raise (overflow b);
+    Bytes.blit_string s 0 b.buf b.pos slen;
+    Bytes.unsafe_set b.buf (b.pos + slen) '\000';
+    b.pos <- b.pos + slen + 1
+  ;;
+
+  let[@inline never] put_vint_big b v =
+    if v = v land 0xffff
+    then (
+      put_8 b 253;
+      put_16 b v)
+    else if v = Int32.to_int (Int32.of_int v)
+    then (
+      put_8 b 254;
+      put_32 b (Int32.of_int v))
+    else (
+      put_8 b 255;
+      put_64 b (Int64.of_int v))
+  ;;
+
+  let[@inline always] put_vint b v =
+    if 0 <= v && v <= 252 then put_8 b v else put_vint_big b v
+  ;;
+
+  type position_8 = int
+  type position_16 = int
+  type position_32 = int
+  type position_64 = int
+  type position_float = int
+
+  let[@inline always] skip_8 b =
+    let pos = b.pos in
+    let pos' = b.pos + 1 in
+    if pos' > b.pos_end then raise (overflow b);
+    b.pos <- pos';
+    pos
+  ;;
+
+  let[@inline always] skip_16 b =
+    let pos = b.pos in
+    let pos' = b.pos + 2 in
+    if pos' > b.pos_end then raise (overflow b);
+    b.pos <- pos';
+    pos
+  ;;
+
+  let[@inline always] skip_32 b =
+    let pos = b.pos in
+    let pos' = b.pos + 4 in
+    if pos' > b.pos_end then raise (overflow b);
+    b.pos <- pos';
+    pos
+  ;;
+
+  let[@inline always] skip_64 b =
+    let pos = b.pos in
+    let pos' = b.pos + 8 in
+    if pos' > b.pos_end then raise (overflow b);
+    b.pos <- pos';
+    pos
+  ;;
+
+  let skip_float = skip_64
+
+  let update_8 b pos v =
+    assert (pos + 1 <= b.pos_end);
+    put_raw_8 b.buf pos v
+  ;;
+
+  let update_16 b pos v =
+    assert (pos + 2 <= b.pos_end);
+    put_raw_16 b.buf pos v
+  ;;
+
+  let update_32 b pos v =
+    assert (pos + 4 <= b.pos_end);
+    put_raw_32 b.buf pos v
+  ;;
+
+  let update_64 b pos v =
+    assert (pos + 8 <= b.pos_end);
+    put_raw_64 b.buf pos v
+  ;;
+
+  let update_float b pos f = update_64 b pos (Int64.bits_of_float f)
+end
+
+module Read = struct
+  include Shared
+
+  let rec read_into fd buf off =
+    if off = Bytes.length buf
+    then { buf; pos = 0; pos_end = off }
+    else (
+      assert (0 <= off && off <= Bytes.length buf);
+      let n = Unix.read fd buf off (Bytes.length buf - off) in
+      if n = 0
+      then (* EOF *)
+        { buf; pos = 0; pos_end = off }
+      else (* Short read *)
+        read_into fd buf (off + n))
+  ;;
+
+  let read_fd fd buf = read_into fd buf 0
+
+  let refill_fd fd b =
+    let len = remaining b in
+    Bytes.blit b.buf b.pos b.buf 0 len;
+    read_into fd b.buf len
+  ;;
+
+  let split b len =
+    let len = min (remaining b) len in
+    { b with pos_end = b.pos + len }, { b with pos = b.pos + len }
+  ;;
+
+  let empty = { buf = Bytes.make 0 '?'; pos = 0; pos_end = 0 }
+
+  external get_raw_16 : Bytes.t -> int -> int = "%caml_bytes_get16u"
+  external get_raw_32 : Bytes.t -> int -> int32 = "%caml_bytes_get32u"
+  external get_raw_64 : Bytes.t -> int -> int64 = "%caml_bytes_get64u"
+
+  exception Underflow of int
+
+  let[@inline never] underflow b = Underflow b.pos
+
+  let[@inline always] get_8 b =
+    let pos = b.pos in
+    let pos' = b.pos + 1 in
+    if pos' > b.pos_end then raise (underflow b);
+    b.pos <- pos';
+    Char.code (Bytes.unsafe_get b.buf pos)
+  ;;
+
+  let[@inline always] get_16 b =
+    let pos = b.pos in
+    let pos' = b.pos + 2 in
+    if pos' > b.pos_end then raise (underflow b);
+    b.pos <- pos';
+    if Sys.big_endian then bswap_16 (get_raw_16 b.buf pos) else get_raw_16 b.buf pos
+  ;;
+
+  let[@inline always] get_32 b =
+    let pos = b.pos in
+    let pos' = b.pos + 4 in
+    if pos' > b.pos_end then raise (underflow b);
+    b.pos <- pos';
+    if Sys.big_endian then bswap_32 (get_raw_32 b.buf pos) else get_raw_32 b.buf pos
+  ;;
+
+  let[@inline always] get_64 b =
+    let pos = b.pos in
+    let pos' = b.pos + 8 in
+    if pos' > b.pos_end then raise (underflow b);
+    b.pos <- pos';
+    if Sys.big_endian then bswap_64 (get_raw_64 b.buf pos) else get_raw_64 b.buf pos
+  ;;
+
+  let[@inline always] get_float b = Int64.float_of_bits (get_64 b)
+
+  let get_string b =
+    let start = b.pos in
+    while get_8 b <> 0 do
+      ()
+    done;
+    let len = b.pos - 1 - start in
+    Bytes.sub_string b.buf start len
+  ;;
+
+  let[@inline never] get_vint_big b c =
+    match c with
+    | 253 -> get_16 b
+    | 254 -> Int32.to_int (get_32 b)
+    | 255 -> Int64.to_int (get_64 b)
+    | _ -> assert false
+  ;;
+
+  let[@inline always] get_vint b =
+    match get_8 b with
+    | c when c < 253 -> c
+    | c -> get_vint_big b c
+  ;;
+end
+
+let () =
+  (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function
+    | Write.Overflow n -> Some ("Buffer overflow at position " ^ string_of_int n)
+    | Read.Underflow n -> Some ("Buffer underflow at position " ^ string_of_int n)
+    | _ -> None)
+;;

src/buf.mli

···
+module Shared_writer_fd : sig
+  (** A Unix file descriptor, shared between multiple writers *)
+  type t
+
+  exception Closed
+
+  val make : Unix.file_descr -> t
+
+  (** Writes the specified range of a buffer to the file descriptor, raising Closed if
+      [close] has been called *)
+  val write_fully : t -> bytes -> pos:int -> len:int -> unit
+
+  val close : t -> unit
+end
+
+module Write : sig
+  (** A [t] is a subsequence of a Bytes.t, to be written sequentially.
+
+      None of the operations below allocate or resize the underlying byte buffer - the
+      underlying Bytes.t is managed by the caller, and may be shared between mutiple [t]s *)
+  type t = private
+    { buf : Bytes.t
+    ; mutable pos : int
+    ; pos_end : int
+    }
+
+  val of_bytes : Bytes.t -> t
+  val of_bytes_sub : Bytes.t -> pos:int -> pos_end:int -> t
+  val remaining : t -> int
+
+  (** [write_fd fd b] writes the bytes written to b to the fd.
+
+      No bufs are invalidated *)
+  val write_fd : Shared_writer_fd.t -> t -> unit
+
+  (** Writing to a buf. All types are written little-endian. All functions raise Overflow
+      if there is insufficient space remaining *)
+
+  exception Overflow of int
+
+  val put_8 : t -> int -> unit
+  val put_16 : t -> int -> unit
+  val put_32 : t -> int32 -> unit
+  val put_64 : t -> int64 -> unit
+  val put_float : t -> float -> unit
+  val put_string : t -> string -> unit
+  val put_vint : t -> int -> unit
+
+  (** The skip_t functions reserve space to be filled by a later update_t. (for e.g.
+      length fields that are only known when writing is finished) *)
+
+  type position_8 = private int
+
+  val skip_8 : t -> position_8
+  val update_8 : t -> position_8 -> int -> unit
+
+  type position_16 = private int
+
+  val skip_16 : t -> position_16
+  val update_16 : t -> position_16 -> int -> unit
+
+  type position_32 = private int
+
+  val skip_32 : t -> position_32
+  val update_32 : t -> position_32 -> int32 -> unit
+
+  type position_64 = private int
+
+  val skip_64 : t -> position_64
+  val update_64 : t -> position_64 -> int64 -> unit
+
+  type position_float = private int
+
+  val skip_float : t -> position_float
+  val update_float : t -> position_float -> float -> unit
+end
+
+module Read : sig
+  (** A [t] is a subsequence of a Bytes.t, to be read sequentially.
+
+      None of the operations below allocate or resize the underlying byte buffer - the
+      underlying Bytes.t is managed by the caller, and may be shared between mutiple [t]s *)
+  type t = private
+    { buf : Bytes.t
+    ; mutable pos : int
+    ; pos_end : int
+    }
+
+  val of_bytes : Bytes.t -> t
+  val of_bytes_sub : Bytes.t -> pos:int -> pos_end:int -> t
+  val remaining : t -> int
+
+  (** [split_buf b len] splits b into (a, b), where a contains at most len bytes and b
+      contains the rest, if any.
+
+      The two returned parts share the same underlying Bytes.t *)
+  val split : t -> int -> t * t
+
+  (** [read_fd fd byt] returns a buf containing bytes read from fd, whose underlying
+      buffer is byt.
+
+      All [t]s sharing this underlying buffer are invalidated *)
+  val read_fd : Unix.file_descr -> Bytes.t -> t
+
+  (** [refill_fd fd b] returns a buf containing the contents of b followed by bytes read
+      from fd, whose underlying buffer is that of b.
+
+      All bufs sharing this underlying buffer (including b) are invalidated *)
+  val refill_fd : Unix.file_descr -> t -> t
+
+  val empty : t
+
+  (** Reading from a buf. All types are read little-endian. All functions raise Underflow
+      if there are insufficient bytes remaining. *)
+
+  exception Underflow of int
+
+  val get_8 : t -> int
+  val get_16 : t -> int
+  val get_32 : t -> int32
+  val get_64 : t -> int64
+  val get_float : t -> float
+  val get_string : t -> string
+  val get_vint : t -> int (* NB: may overflow if read on 32-bit machines *)
+end

src/dune

···
+(library
+ (name memtrace)
+ (public_name memtrace)
+ (libraries unix threads)
+ (preprocess no_preprocessing))

src/geometric_sampler.ml

···
+type t =
+  { rand : Random.State.t
+  ; one_log1m_lambda : float
+  }
+
+let default_rand () =
+  Random.State.make [| 0x52b87efb; 0x332235ea; 0x5f813723; 0x057b9dff |]
+;;
+
+let make ?(rand = default_rand ()) ~sampling_rate () =
+  let one_log1m_lambda =
+    if sampling_rate >= 1. then 0. else 1. /. log1p (-.sampling_rate)
+  in
+  { rand; one_log1m_lambda }
+;;
+
+let copy ?(rand = default_rand ()) t = { rand; one_log1m_lambda = t.one_log1m_lambda }
+
+(* port of log_approx in runtime/memprof.c to OCaml
+   see https://github.com/ocaml/ocaml/pull/9466
+
+   slightly different results because of double precision,
+   however, this difference is ~100x smaller than the
+   error introduced by the original approximation *)
+
+let log_approx n =
+  let f = Int64.bits_of_float Int32.(to_float (add one (shift_left n 1))) in
+  let exp = Int64.(to_int (shift_right f 52)) in
+  let exp = float_of_int (exp + (127 - 1023 + 1)) in
+  let x = Int64.(float_of_bits (logor (logand f 0xfffffffffffffL) 0x3ff0000000000000L)) in
+  (x *. (2.104659476859 +. (x *. (-0.720478916626 +. (x *. 0.107132064797)))))
+  +. (-111.701724334061 +. (0.6931471805 *. exp))
+;;
+
+(* Draw from the geometric distribution by:
+   (1) Draw a uniform random number (via Random.State.bits)
+   (2) Construct an exponentially-distributed random variable as the log of (1)
+   (3) Scale the distribution of (2) to have the correct mean by multiplying
+   (4) Convert to a geometric distribution by taking the floor + 1 *)
+let draw s =
+  let uniform_rand = Int32.of_int (Random.State.bits s.rand) in
+  let exp_rand = log_approx uniform_rand in
+  1 + int_of_float (exp_rand *. s.one_log1m_lambda)
+;;

src/geometric_sampler.mli

···
+(** An efficient sampler for geometrically distributed random variables. (Port to OCaml of
+    the statmemprof sampler used in the OCaml runtime)
+
+    A sampler is parameterised by a sampling_rate λ, and simulates a long sequence of
+    flips of a biased coin that has probability λ of coming up heads.
+
+    The result of [draw] is an integer distributed as the length of the gaps between two
+    successive heads. This is a geometrically distributed random variable: the expected
+    value is 1/λ, and the probability that draw returns k is (1-λ)^(k-1) * λ (that is, the
+    probability of (k-1) tails followed by a heads).
+
+    NB: Note that here, we're adopting the convention that two consecutive heads counts as
+    a gap of length 1. In other words, this distribution is the number of times you need
+    to flip the coin to see heads, rather than the number of tails you'll see while doing
+    so (which is one less). This means that the result is never zero. This convention is
+    not universal, and some authers use "geometrically distributed" for the zero-based
+    distribution. *)
+type t
+
+(** Create a sampler with a given sampling rate and randomness source. The default for
+    [rand] uses a constant seed, giving deterministic results *)
+val make : ?rand:Random.State.t -> sampling_rate:float -> unit -> t
+
+val copy : ?rand:Random.State.t -> t -> t
+
+(** Returns a geometrically-distributed random integer in the range [1..inf)
+    with mean 1/sampling_rate *)
+val draw : t -> int

src/location_codec.ml

···
+open Buf
+
+(* Move-to-front codec *)
+module Mtf_table : sig
+  type 'a t
+
+  val create : unit -> 'a t
+
+  type index = int
+
+  val not_found : index
+  val encode : 'a t -> if_absent:(unit -> 'a) -> string -> index * 'a
+  val decode : 'a t -> if_absent:(unit -> string * 'a) -> index -> string * 'a
+  val last : 'a t -> 'a option
+end = struct
+  type 'a entry =
+    | Empty
+    | Full of string * 'a
+
+  type 'a t = 'a entry array
+
+  let length = 31
+  let create () = Array.make length Empty
+
+  type index = int
+
+  let not_found = length
+
+  let swap mtf i =
+    assert (i <> not_found);
+    let e =
+      match mtf.(i) with
+      | Empty -> assert false
+      | Full _ as e -> e
+    in
+    Array.blit mtf 0 mtf 1 i;
+    mtf.(0) <- e
+  ;;
+
+  let push mtf k v =
+    Array.blit mtf 0 mtf 1 (length - 1);
+    mtf.(0) <- Full (k, v)
+  ;;
+
+  let encode mtf ~if_absent x =
+    let rec go mtf x i =
+      if i = length
+      then (
+        let v = if_absent () in
+        push mtf x v;
+        not_found, v)
+      else (
+        match mtf.(i) with
+        | Empty ->
+          let v = if_absent () in
+          push mtf x v;
+          not_found, v
+        | Full (k, v) when String.equal k x ->
+          swap mtf i;
+          i, v
+        | Full _ -> go mtf x (i + 1))
+    in
+    go mtf x 0
+  ;;
+
+  let decode mtf ~if_absent i =
+    if i = not_found
+    then (
+      let ((k, v) as kv) = if_absent () in
+      push mtf k v;
+      kv)
+    else (
+      swap mtf i;
+      match mtf.(0) with
+      | Empty -> assert false
+      | Full (k, v) -> k, v)
+  ;;
+
+  let last mtf =
+    match mtf.(length - 1) with
+    | Empty -> None
+    | Full (_, v) -> Some v
+  ;;
+end
+
+(** Source locations *)
+module Location = struct
+  type t =
+    { filename : string
+    ; line : int
+    ; start_char : int
+    ; end_char : int
+    ; defname : string
+    }
+
+  let to_string { filename; line; start_char; end_char; defname } =
+    Printf.sprintf "%s@%s:%d:%d-%d" defname filename line start_char end_char
+  ;;
+
+  let unknown =
+    { filename = "<unknown>"; line = 1; start_char = 1; end_char = 1; defname = "??" }
+  ;;
+end
+
+type state = unit Mtf_table.t Mtf_table.t
+
+module Writer = struct
+  open Buf.Write
+
+  type t = state
+
+  let create () = Mtf_table.create ()
+  let max_length = 4 * 1024
+
+  let put_location (file_mtf : t) b (id, locs) =
+    let total_size_max =
+      (* Worst-case size, assuming no MTF hits *)
+      List.fold_left
+        (fun sz (loc : Location.t) ->
+          sz + 6 + (String.length loc.filename + 1) + (String.length loc.defname + 1))
+        (8 + 1)
+        locs
+    in
+    let no_truncation = List.length locs <= 255 && total_size_max <= max_length in
+    let locs = if no_truncation then locs else [ Location.unknown ] in
+    let start_pos = b.Write.pos in
+    put_64 b (Int64.of_int id);
+    put_8 b (List.length locs);
+    locs
+    |> List.iter (fun (loc : Location.t) ->
+      let clamp n lim = if n < 0 || n > lim then lim else n in
+      let line_number =
+        (* 20 bits *)
+        clamp loc.line 0xfffff
+      in
+      let start_char =
+        (* 8 bits *)
+        clamp loc.start_char 0xff
+      in
+      let end_char =
+        (* 10 bits *)
+        clamp loc.end_char 0x3ff
+      in
+      let filename_code, defn_mtf =
+        Mtf_table.encode file_mtf ~if_absent:Mtf_table.create loc.filename
+      in
+      let defname_code, () =
+        Mtf_table.encode defn_mtf ~if_absent:(fun () -> ()) loc.defname
+      in
+      let encoded =
+        Int64.(
+          logor
+            (of_int line_number)
+            (logor
+               (shift_left (of_int start_char) 20)
+               (logor
+                  (shift_left (of_int end_char) (20 + 8))
+                  (logor
+                     (shift_left (of_int (filename_code :> int)) (20 + 8 + 10))
+                     (shift_left (of_int (defname_code :> int)) (20 + 8 + 10 + 5))))))
+      in
+      put_32 b (Int64.to_int32 encoded);
+      put_16 b Int64.(to_int (shift_right encoded 32));
+      if filename_code = Mtf_table.not_found then put_string b loc.filename;
+      if defname_code = Mtf_table.not_found then put_string b loc.defname);
+    if no_truncation then assert (b.pos - start_pos <= total_size_max)
+  ;;
+end
+
+module Reader = struct
+  open Buf.Read
+
+  type t = state
+
+  let create () = Mtf_table.create ()
+
+  let get_location (file_mtf : t) b =
+    let id = Int64.to_int (get_64 b) in
+    let nlocs = get_8 b in
+    let locs =
+      List.init nlocs (fun _ ->
+        let low = get_32 b in
+        let high = get_16 b in
+        let encoded =
+          Int64.(logor (shift_left (of_int high) 32) (logand (of_int32 low) 0xffffffffL))
+        in
+        let line, start_char, end_char, filename_code, defname_code =
+          Int64.(
+            ( to_int (logand 0xfffffL encoded)
+            , to_int (logand 0xffL (shift_right encoded 20))
+            , to_int (logand 0x3ffL (shift_right encoded (20 + 8)))
+            , to_int (logand 0x1fL (shift_right encoded (20 + 8 + 10)))
+            , to_int (logand 0x1fL (shift_right encoded (20 + 8 + 10 + 5))) ))
+        in
+        let filename, defn_mtf =
+          Mtf_table.decode
+            file_mtf
+            ~if_absent:(fun () ->
+              let s = get_string b in
+              (* Reuse the defname MTF table that's about to be pushed off.
+               This is only present to match a bug in the v001 encoder,
+               which sometimes generated traces relying on this behaviour.
+               The current encoder never relies on this, so once v001
+               trace files stop mattering, this match can be deleted *)
+              let d =
+                match Mtf_table.last file_mtf with
+                | Some v -> v
+                | None -> Mtf_table.create ()
+              in
+              s, d)
+            filename_code
+        in
+        let defname, () =
+          Mtf_table.decode
+            defn_mtf
+            ~if_absent:(fun () ->
+              let s = get_string b in
+              s, ())
+            defname_code
+        in
+        { Location.line; start_char; end_char; filename; defname })
+    in
+    id, locs
+  ;;
+end

src/location_codec.mli

···
+module Location : sig
+  type t =
+    { filename : string
+    ; line : int
+    ; start_char : int
+    ; end_char : int
+    ; defname : string
+    }
+
+  val to_string : t -> string
+  val unknown : t
+end
+
+module Writer : sig
+  type t
+
+  val create : unit -> t
+  val max_length : int
+
+  (* put_location never writes more than max_length bytes *)
+  val put_location : t -> Buf.Write.t -> int * Location.t list -> unit
+end
+
+module Reader : sig
+  type t
+
+  val create : unit -> t
+  val get_location : t -> Buf.Read.t -> int * Location.t list
+end

src/memprof_tracer.ml

···
+open Stdlib_shim
+
+(* The tracer requires some tricky locking.
+
+   It can be used both synchronously from user code (e.g. in calls to ext_alloc)
+   and asynchronously from Gc.Memprof callbacks. Locks in async callbacks cannot
+   block, as they might interrupt code which synchronously holds the lock, and
+   so would deadlock if they blocked.
+
+   Instead, users of lock_async must handle the case where the lock is already held
+   synchronously by the current thread. In this case, the lock can't be taken, and
+   instead the user must defer some work to be processed when the synchronous holder
+   later releases the lock.
+
+   In other words, the lock is nonreentrant: you can't take a lock you already hold.
+
+   This module is implemented with nonatomic references, and should only be used on
+   the main domain (that is, when [Domain.is_main_domain ()]). *)
+module Lock = struct
+  type 'a t =
+    { mutable locked : bool
+    ; mutable locked_sync : bool
+    ; mutable locked_sync_thread_id : int
+    ; mutable stopped : bool
+    ; mutable deferred : 'a list
+    }
+
+  let create () =
+    { locked = false
+    ; locked_sync = false
+    ; locked_sync_thread_id = -1
+    ; stopped = false
+    ; deferred = []
+    }
+  ;;
+
+  let self_id () = Thread.id (Thread.self ())
+
+  (* lock_sync and unlock_sync form a spinlock with two extra features:
+     - Work may be 'deferred' (see defer and lock_async below), to run at unlock time
+     - There is a 'stopped' state (see unlock_and_stop), in which locking always fails *)
+
+  type lock_sync_result =
+    | Success
+    | Is_stopped
+
+  let[@inline never] rec lock_sync s : lock_sync_result =
+    if s.stopped
+    then Is_stopped
+    else if s.locked
+    then (
+      if s.locked_sync && s.locked_sync_thread_id = self_id ()
+      then failwith "Memprof_tracer.Lock.lock_sync: Attempted to lock recursively";
+      Thread.yield ();
+      lock_sync s)
+    else (
+      s.locked <- true;
+      s.locked_sync <- true;
+      s.locked_sync_thread_id <- self_id ();
+      Success)
+  ;;
+
+  let[@inline never] defer s t =
+    assert (
+      (not s.stopped) && s.locked && s.locked_sync && s.locked_sync_thread_id = self_id ());
+    s.deferred <- t :: s.deferred
+  ;;
+
+  let[@inline never] unlock_and_stop s =
+    s.stopped <- true;
+    s.deferred <- [];
+    s.locked <- false;
+    s.locked_sync <- false
+  ;;
+
+  let[@inline never] rec unlock_sync ~report_exn ~handle_deferred s =
+    assert (
+      (not s.stopped) && s.locked && s.locked_sync && s.locked_sync_thread_id = self_id ());
+    match s.deferred with
+    | [] ->
+      s.locked_sync <- false;
+      s.locked_sync_thread_id <- -1;
+      s.locked <- false
+    | deferred ->
+      s.deferred <- [];
+      (match List.iter handle_deferred (List.rev deferred) with
+       | () -> unlock_sync ~report_exn ~handle_deferred s
+       | exception e ->
+         unlock_and_stop s;
+         report_exn e)
+  ;;
+
+  (* Normally, taking a lock during an asynchronous callback can cause deadlocks, as the
+     lock may already be held by the thread that is currently running the asynchronous
+     handler. So, it is incorrect to use [lock_sync] / [unlock_sync] from a handler.
+
+     Instead, [lock_async] and [unlock_async] may be used from asynchronous
+     handlers. Taking a lock asynchronously can return a [Is_sync_locked_by_this_thread],
+     indicating that the lock is already held by this thread and so cannot be waited for.
+
+     In this state, it is not in general safe to manipulate the state protected by the lock
+     (since you don't know what the interrupted thread is doing with it), but you can use
+     [defer] to schedule work for when the interrupted thread releases the lock. *)
+
+  type lock_async_result =
+    | Success
+    | Is_sync_locked_by_this_thread
+    | Is_stopped
+
+  let[@inline never] rec lock_async s : lock_async_result =
+    if s.stopped
+    then Is_stopped
+    else if s.locked_sync && s.locked_sync_thread_id = self_id ()
+    then Is_sync_locked_by_this_thread
+    else if s.locked
+    then (
+      Thread.yield ();
+      lock_async s)
+    else (
+      s.locked <- true;
+      Success)
+  ;;
+
+  let[@inline never] unlock_async s =
+    assert ((not s.stopped) && s.locked && not s.locked_sync);
+    s.locked <- false
+  ;;
+end
+
+type deferred_event =
+  | Deferred_promote of Trace.Writer.t * Trace.Obj_id.t
+  | Deferred_collect of Trace.Writer.t * Trace.Obj_id.t
+
+let handle_deferred_event = function
+  | Deferred_promote (t, id) -> Trace.Writer.put_promote t (Trace.Timestamp.now ()) id
+  | Deferred_collect (t, id) -> Trace.Writer.put_collect t (Trace.Timestamp.now ()) id
+;;
+
+type t =
+  { lock : deferred_event Lock.t
+  ; report_exn : exn -> unit
+  ; trace : Trace.Writer.t
+  ; ext_sampler : Geometric_sampler.t
+  }
+
+let curr_active_tracer : t option ref = ref None
+let active_tracer () = !curr_active_tracer
+
+let current_domain () =
+  let id = (Stdlib.Domain.self () :> int) in
+  Trace.Domain_id.Expert.of_int id
+;;
+
+let bytes_before_ext_sample = ref max_int
+let draw_sampler_bytes t = Geometric_sampler.draw t.ext_sampler * (Sys.word_size / 8)
+
+let[@inline never] mark_failed s e =
+  Lock.unlock_and_stop s.lock;
+  s.report_exn e
+;;
+
+let default_report_exn e =
+  match e with
+  | Trace.Writer.Pid_changed ->
+    (* This error is silently ignored, so that if Memtrace is active across
+        Unix.fork () then the child process silently stops tracing *)
+    ()
+  | e ->
+    let msg = Printf.sprintf "Memtrace failure: %s\n" (Printexc.to_string e) in
+    output_string stderr msg;
+    Printexc.print_backtrace stderr;
+    flush stderr
+;;
+
+let assert_main_domain () =
+  if not (Domain.is_main_domain ())
+  then failwith "Memtrace can currently only be used from the main domain"
+;;
+
+let start ?(report_exn = default_report_exn) ~sampling_rate trace =
+  assert_main_domain ();
+  let ext_sampler = Geometric_sampler.make ~sampling_rate () in
+  let s = { trace; lock = Lock.create (); report_exn; ext_sampler } in
+  let allocate ~(info : Gc.Memprof.allocation) ~source : Trace.Obj_id.t option =
+    if not (Domain.is_main_domain ())
+    then None
+    else (
+      match Lock.lock_async s.lock with
+      | Is_stopped -> None
+      | Is_sync_locked_by_this_thread ->
+        None (* Ignore allocations during e.g. ext_alloc *)
+      | Success ->
+        (match
+           Trace.Writer.put_alloc_with_raw_backtrace
+             trace
+             (Trace.Timestamp.now ())
+             ~length:info.size
+             ~nsamples:info.n_samples
+             ~source
+             ~callstack:info.callstack
+         with
+         | r ->
+           Lock.unlock_async s.lock;
+           Some r
+         | exception e ->
+           mark_failed s e;
+           None))
+  in
+  let promote id : Trace.Obj_id.t option =
+    if not (Domain.is_main_domain ())
+    then None
+    else (
+      match Lock.lock_async s.lock with
+      | Is_stopped -> None
+      | Is_sync_locked_by_this_thread ->
+        Lock.defer s.lock (Deferred_promote (trace, id));
+        Some id
+      | Success ->
+        (match Trace.Writer.put_promote trace (Trace.Timestamp.now ()) id with
+         | () ->
+           Lock.unlock_async s.lock;
+           Some id
+         | exception e ->
+           mark_failed s e;
+           None))
+  in
+  let dealloc id =
+    if not (Domain.is_main_domain ())
+    then ()
+    else (
+      match Lock.lock_async s.lock with
+      | Is_stopped -> ()
+      | Is_sync_locked_by_this_thread -> Lock.defer s.lock (Deferred_collect (trace, id))
+      | Success ->
+        (match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with
+         | () -> Lock.unlock_async s.lock
+         | exception e -> mark_failed s e))
+  in
+  let tracker : (_, _) Gc.Memprof.tracker =
+    { alloc_minor = (fun info -> allocate ~info ~source:Minor)
+    ; alloc_major = (fun info -> allocate ~info ~source:Major)
+    ; promote
+    ; dealloc_minor = dealloc
+    ; dealloc_major = dealloc
+    }
+  in
+  (* Pre-allocate these so that they don't get included in the trace (and use
+     [Sys.opaque_identity] so the allocations don't get moved *)
+  let active_tracer, sampler_bytes = Sys.opaque_identity (Some s, draw_sampler_bytes s) in
+  ignore (Gc.Memprof.start ~sampling_rate ~callstack_size:max_int tracker : Gc.Memprof.t);
+  curr_active_tracer := active_tracer;
+  bytes_before_ext_sample := sampler_bytes;
+  s
+;;
+
+let stop s =
+  assert_main_domain ();
+  match Lock.lock_sync s.lock with
+  | Is_stopped -> ()
+  | Success ->
+    Lock.unlock_and_stop s.lock;
+    (match !curr_active_tracer with
+     | None -> ()
+     | Some _ ->
+       Gc.Memprof.stop ();
+       (try Trace.Writer.close s.trace with
+        | e -> s.report_exn e);
+       curr_active_tracer := None)
+;;
+
+let[@inline never] ext_alloc_slowpath ~bytes : Trace.Obj_id.t or_null =
+  match !curr_active_tracer with
+  | None ->
+    bytes_before_ext_sample := max_int;
+    Null
+  | Some s ->
+    (match Lock.lock_sync s.lock with
+     | Is_stopped -> Null
+     | Success ->
+       (match
+          let bytes_per_word = Sys.word_size / 8 in
+          (* round up to an integer number of words *)
+          let size_words = (bytes + bytes_per_word - 1) / bytes_per_word in
+          let samples = ref 0 in
+          while !bytes_before_ext_sample <= 0 do
+            bytes_before_ext_sample := !bytes_before_ext_sample + draw_sampler_bytes s;
+            incr samples
+          done;
+          assert (!samples > 0);
+          let callstack = Printexc.get_callstack max_int in
+          let drop_slots =
+            (* The last callstack slot will be exactly this function, since it's
+             never inlined. We don't want to see it in the backtrace, so drop it
+             here. *)
+            1
+          in
+          (* Sys.opaque_identity ensures that flambda2 doesn't move the
+           allocation past the [unlock_tracer_ext] call *)
+          This
+            (Trace.Writer.put_alloc_with_suffix_of_raw_backtrace
+               s.trace
+               (Trace.Timestamp.now ())
+               ~length:size_words
+               ~nsamples:!samples
+               ~source:External
+               ~callstack
+               ~drop_slots)
+          |> Sys.opaque_identity
+        with
+        | r ->
+          Lock.unlock_sync
+            ~report_exn:s.report_exn
+            ~handle_deferred:handle_deferred_event
+            s.lock;
+          r
+        | exception e ->
+          mark_failed s e;
+          Null))
+;;
+
+type ext_token = Trace.Obj_id.t
+
+let ext_alloc ~bytes =
+  let next_sample = !bytes_before_ext_sample in
+  if next_sample = max_int
+  then Null
+  else if not (Domain.is_main_domain ())
+  then Null
+  else (
+    let n = next_sample - bytes in
+    bytes_before_ext_sample := n;
+    if n <= 0
+    then
+      (* This has [@tail] to make sure this function won't appear in any backtraces (unless
+         it's inlined into another function, in which case we have to filter it out after
+         the fact). *)
+      ext_alloc_slowpath ~bytes [@tail]
+    else Null)
+;;
+
+let ext_free id =
+  match !curr_active_tracer with
+  | None -> ()
+  | Some s ->
+    if Domain.is_main_domain ()
+    then (
+      match Lock.lock_sync s.lock with
+      | Is_stopped -> ()
+      | Success ->
+        (match Trace.Writer.put_collect s.trace (Trace.Timestamp.now ()) id with
+         | () ->
+           Lock.unlock_sync
+             ~report_exn:s.report_exn
+             ~handle_deferred:handle_deferred_event
+             s.lock;
+           ()
+         | exception e ->
+           mark_failed s e;
+           ()))
+;;
+
+let () = Trace.Private.set_name_of_memprof_tracer_module __MODULE__

src/memprof_tracer.mli

···
+open Stdlib_shim
+
+type t
+
+val start : ?report_exn:(exn -> unit) -> sampling_rate:float -> Trace.Writer.t -> t
+val stop : t -> unit
+val active_tracer : unit -> t option
+val current_domain : unit -> Trace.Domain_id.t
+
+type ext_token [@@immediate]
+
+val ext_alloc : bytes:int -> ext_token or_null
+val ext_free : ext_token -> unit

src/memprof_tracer_410.ml_

···
+type t =
+  { mutable locked : bool;
+    mutable failed : bool;
+    mutable stopped : bool;
+    report_exn : exn -> unit;
+    trace : Trace.Writer.t }
+
+let[@inline never] lock_tracer s =
+  (* This is a maximally unfair spinlock. *)
+  (* if s.locked then Printf.fprintf stderr "contention\n%!"; *)
+  while s.locked do Thread.yield () done;
+  if s.failed then
+    false
+  else
+    (s.locked <- true; true)
+
+let[@inline never] unlock_tracer s =
+  assert (s.locked && not s.failed);
+  s.locked <- false
+
+let[@inline never] mark_failed s e =
+  assert (s.locked && not s.failed);
+  s.failed <- true;
+  s.locked <- false;
+  s.report_exn e
+
+let default_report_exn e =
+  let msg = Printf.sprintf "Memtrace failure: %s\n" (Printexc.to_string e) in
+  output_string stderr msg;
+  Printexc.print_backtrace stderr;
+  flush stderr
+
+let start ?(report_exn=default_report_exn) ~sampling_rate trace =
+  let s = { trace; locked = false; stopped = false; failed = false; report_exn } in
+  Gc.Memprof.start
+    ~callstack_size:max_int
+    ~minor_alloc_callback:(fun info ->
+      if lock_tracer s then begin
+        match Trace.Writer.put_alloc_with_raw_backtrace trace (Trace.Timestamp.now ())
+                ~length:info.size
+                ~nsamples:info.n_samples
+                ~is_major:false
+                ~callstack:info.callstack
+        with
+        | r -> unlock_tracer s; Some r
+        | exception e -> mark_failed s e; None
+      end else None)
+    ~major_alloc_callback:(fun info ->
+      if lock_tracer s then begin
+        match Trace.Writer.put_alloc_with_raw_backtrace trace (Trace.Timestamp.now ())
+                ~length:info.size
+                ~nsamples:info.n_samples
+                ~is_major:true
+                ~callstack:info.callstack
+        with
+        | r -> unlock_tracer s; Some r
+        | exception e -> mark_failed s e; None
+      end else None)
+    ~promote_callback:(fun id ->
+      if lock_tracer s then
+        match Trace.Writer.put_promote trace (Trace.Timestamp.now ()) id with
+        | () -> unlock_tracer s; Some id
+        | exception e -> mark_failed s e; None
+      else None)
+    ~minor_dealloc_callback:(fun id ->
+      if lock_tracer s then
+        match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with
+        | () -> unlock_tracer s
+        | exception e -> mark_failed s e)
+    ~major_dealloc_callback:(fun id ->
+      if lock_tracer s then
+        match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with
+        | () -> unlock_tracer s
+        | exception e -> mark_failed s e)
+    ~sampling_rate
+    ();
+  s
+
+let stop s =
+  if not s.stopped then begin
+    s.stopped <- true;
+    Gc.Memprof.stop ();
+    if lock_tracer s then
+      Trace.Writer.close s.trace
+  end

src/memtrace.ml

···
+type tracer = Memprof_tracer.t
+
+let getpid64 () = Int64.of_int (Unix.getpid ())
+
+let start_tracing ~if_started ~context ~sampling_rate ~filename =
+  match Memprof_tracer.active_tracer () with
+  | Some tracer ->
+    (match if_started with
+     | `Fail -> failwith "Only one Memtrace instance may be active at a time"
+     | `Ignore -> tracer)
+  | None ->
+    let fd =
+      try Unix.openfile filename Unix.[ O_CREAT; O_WRONLY ] 0o600 with
+      | Unix.Unix_error (err, _, _) ->
+        raise
+          (Invalid_argument
+             ("Cannot open memtrace file " ^ filename ^ ": " ^ Unix.error_message err))
+    in
+    (try Unix.lockf fd F_TLOCK 0 with
+     | Unix.Unix_error ((EAGAIN | EACCES), _, _) ->
+       Unix.close fd;
+       raise
+         (Invalid_argument
+            ("Cannot lock memtrace file " ^ filename ^ ": is another process using it?")));
+    (try Unix.ftruncate fd 0 with
+     | Unix.Unix_error _ ->
+       (* On special files (e.g. /dev/null), ftruncate fails. Ignoring errors
+           here gives us the truncate-if-a-regular-file behaviour of O_TRUNC. *)
+       ());
+    let info : Trace.Info.t =
+      { sample_rate = sampling_rate
+      ; word_size = Sys.word_size
+      ; executable_name = Sys.executable_name
+      ; host_name = Unix.gethostname ()
+      ; ocaml_runtime_params = Sys.runtime_parameters ()
+      ; pid = getpid64 ()
+      ; initial_domain = Trace.Domain_id.main_domain
+      ; start_time = Trace.Timestamp.now ()
+      ; context
+      }
+    in
+    let trace = Trace.Writer.create fd ~getpid:getpid64 info in
+    Memprof_tracer.start ~sampling_rate trace
+;;
+
+let stop_tracing t = Memprof_tracer.stop t
+
+let () =
+  at_exit (fun () ->
+    match Memprof_tracer.active_tracer () with
+    | Some s -> stop_tracing s
+    | None -> ())
+;;
+
+let currently_tracing () =
+  match Memprof_tracer.active_tracer () with
+  | Some _ -> true
+  | None -> false
+;;
+
+let default_sampling_rate = 1e-5
+
+let trace_if_requested ?(if_started = `Ignore) ?context ?sampling_rate () =
+  match Sys.getenv_opt "MEMTRACE" with
+  | None | Some "" -> ()
+  | Some filename ->
+    (* Prevent spawned OCaml programs from being traced *)
+    (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" "";
+    let check_rate = function
+      | Some rate when 0. < rate && rate <= 1. -> rate
+      | _ ->
+        raise
+          (Invalid_argument
+             ("Memtrace.trace_if_requested: " ^ "sampling_rate must be between 0 and 1"))
+    in
+    let sampling_rate =
+      match sampling_rate with
+      | Some _ -> check_rate sampling_rate
+      | None ->
+        (match Sys.getenv_opt "MEMTRACE_RATE" with
+         | None | Some "" -> default_sampling_rate
+         | Some rate -> check_rate (float_of_string_opt rate))
+    in
+    let _s = start_tracing ~if_started ~context ~sampling_rate ~filename in
+    ()
+;;
+
+let start_tracing ~context ~sampling_rate ~filename =
+  (* Default of `Fail for backward compatibility *)
+  start_tracing ~if_started:`Fail ~context ~sampling_rate ~filename
+;;
+
+module Trace = Trace
+module Memprof_tracer = Memprof_tracer
+
+module External = struct
+  type token = Memprof_tracer.ext_token
+
+  let alloc = Memprof_tracer.ext_alloc
+  let free = Memprof_tracer.ext_free
+end
+
+module Geometric_sampler = Geometric_sampler

src/memtrace.mli

···
+open Stdlib_shim
+
+(** If the MEMTRACE environment variable is set, begin tracing to the file it specifies,
+    and continue tracing until the process exits.
+
+    The context is an arbitrary string, which is logged in the trace. It may be useful to
+    identify trace files.
+
+    The sampling_rate is the proportion of allocated words that should be sampled. Values
+    larger than about 1e-4 will have some performance impact. The sampling rate can also
+    be specified with the MEMTRACE_RATE environment variable. If both means are used, the
+    env var takes precedence.
+
+    May raise Unix.Unix_error if the specified file cannot be opened, or Invalid_argument
+    if the MEMTRACE_RATE parameter is ill-formed.
+
+    May call failwith if memtrace was already started and [if_started] is `Fail. *)
+val trace_if_requested
+  :  ?if_started:[ `Fail | `Ignore ]
+  -> ?context:string
+  -> ?sampling_rate:float
+  -> unit
+  -> unit
+
+(** Tracing can also be manually started and stopped. *)
+type tracer
+
+(** Manually start tracing. *)
+val start_tracing
+  :  context:string option
+  -> sampling_rate:float
+  -> filename:string
+  -> tracer
+
+(** Manually stop tracing *)
+val stop_tracing : tracer -> unit
+
+(** Is there an active trace running at the moment? *)
+val currently_tracing : unit -> bool
+
+val default_sampling_rate : float
+
+(** Use the Trace module to read and write trace files *)
+module Trace = Trace
+
+(** Use Memprof_tracer in conjunction with Trace.Writer for more manual control over trace
+    collection *)
+module Memprof_tracer = Memprof_tracer
+
+(** Use External to track non-GC-heap allocations in a Memtrace trace *)
+module External : sig
+  type token [@@immediate]
+
+  (** [alloc ~bytes] reports an allocation of a given number of bytes.
+
+      If tracing is enabled, a small fraction of the calls to this function will return
+      [This tok], where [tok] should be passed to [free] when the object is freed.
+
+      This function is very fast in the common case where it returns [Null] *)
+  val alloc : bytes:int -> token or_null
+
+  val free : token -> unit
+end
+
+(** (For testing) *)
+module Geometric_sampler = Geometric_sampler

src/memtrace.tsdl

···
+/* CTF 1.8 */
+/* Format specification for Memtrace v002.
+
+   This specification is in CTF format (see https://diamon.org/ctf/).
+
+   The trace format consists of a sequence of packets, each containing
+   a sequence of events.
+ */
+
+/* basic type definitions */
+typealias integer {size = 8;}  := uint8;
+typealias integer {size = 16;} := uint16;
+typealias integer {size = 32;} := uint32;
+typealias integer {size = 64;} := uint64;
+typealias integer {size = 8; signed = true;}  := int8;
+typealias integer {size = 16; signed = true;} := int16;
+typealias integer {size = 32; signed = true;} := int32;
+typealias floating_point {exp_dig = 11;mant_dig = 53;align = 8;} := float64;
+
+/* vint: variable-length encoding for unsigned 64-bit integers that
+   are usually small. */
+typealias struct {
+  enum : uint8
+    { u8 = 0...252, u16 = 253, u32 = 254, u64 = 255 } tag;
+  variant <tag> {
+    struct {} u8;
+    uint16 u16;
+    uint32 u32;
+    uint64 u64;
+  } value;
+} := vint;
+
+/* timestamps: microseconds since Unix epoch */
+clock {
+  name = clk;
+  freq = 1000000; /* microsecs */
+  offset_s = 0;
+};
+
+typealias integer {
+  size = 64;
+  map = clock.clk.value;
+} := clk64;
+
+/* CTF header: CTF 1.8, with the CTF magic number */
+trace {
+  major = 1;
+  minor = 8;
+  byte_order = le;
+  packet.header := struct { uint32 magic; };
+};
+
+stream {
+  /* Packet header */
+  packet.context := struct {
+    /* Size of the packet, in bits, including header */
+    uint32 packet_size;
+
+    /* Timestamps of all events in this packet are between
+       timestamp_begin and timestamp_end (inclusive) */
+    clk64 timestamp_begin;
+    clk64 timestamp_end;
+
+    uint32 flush_duration;
+
+    /* Version number of memtrace format.
+       Same for all packets in the trace. */
+    uint16 version;
+
+    /* PID of the process that wrote the packet.
+       Since PID can change via fork(), occasionally packets with
+       the wrong PID can be found in a trace. These should be
+       silently ignored. Packets are written atomically, so these
+       bad packets can be skipped entirely. */
+    uint64 pid;
+
+    /* Domain ID of the domain that wrote this packet.
+       If version < 3, then this field is absent and assumed to be zero. */
+    uint16 domain;
+
+    /* See below. */
+    uint16 cache_verify_ix;
+    uint16 cache_verify_pred;
+    uint64 cache_verify_val;
+
+    /* Allocation IDs of allocation events in this packet are
+       between alloc_id_begin and alloc_id_end (inclusive) */
+    uint64 alloc_id_begin;
+    uint64 alloc_id_end;
+  };
+
+  /* Event header (32 bits)
+     
+     The timestamp field here is only 25 bits long, which means it
+     wraps after 2^25us (a bit over 30 seconds). So that timestamps
+     can be decoded unambiguously, no packet may contain more than 30
+     seconds worth of data. */
+  event.header := struct {
+    integer {size=25; align=1; signed=false; map=clock.clk.value;} timestamp;
+    integer {size=7; align=1; signed=false;} id;
+  };
+};
+
+
+/* Event 0: trace info.
+
+   Only one of these events is sent, in a packet by itself at the
+   start of the trace. */
+event {
+  id = 0;
+  name = "trace_info";
+  fields := struct {
+    float64 sample_rate;
+    uint8 word_size;
+    string executable_name;
+    string host_name;
+    string ocaml_runtime_params;
+    uint64 pid;
+    string context;
+  };
+};
+
+/* Event 1: source code location information.
+   
+   Location information is large, so to save space locations are
+   represented in backtraces by 64-bit opaque identifiers.
+
+   Before the first occurrence of such an identifier in a backtrace,
+   there must always be a location event explaining what that
+   identifer maps to.
+
+   The numeric fields below (line, start_char, end_char) have slightly
+   odd widths, chosen to match those in OCaml's internal debug info
+   format.
+
+   The text fields below (filename, defname) are move-to-front coded.
+   There is a 5-bit field for filename. Codes 0 to 30 refer to the
+   most recently used 31 filenames, and code 31 means that the
+   filename is not one of the most recent (Code 31 is followed by a
+   string).
+
+   Defnames (function and module names) are encoded in the same way,
+   using 31 independent MTF tables for each of the 31 most recent
+   files. */
+typealias struct {
+  integer {size=20; align=1; signed=false;} line;
+  integer {size=8; align=1; signed=false;} start_char;
+  integer {size=10; align=1; signed=false;} end_char;
+  enum : integer {size=5; align=1; signed=false;}
+    { mtf = 0...30, new = 31 } filename;
+  enum : integer {size=5; align=1; signed=false;}
+    { mtf = 0...30, new = 31 } defname;
+  variant <filename> {
+    struct {} mtf;
+    string new;
+  } opt_filename;
+  variant <defname> {
+    struct {} mtf;
+    string new;
+  } opt_defname;
+} := location;
+
+event {
+  id = 1;
+  name = "location";
+  fields := struct {
+    uint64 code;
+    /* A single code refers to a sequence of locations,
+       because of inlining */
+    uint8 nlocs;
+    location locs[nlocs];
+  };
+};
+
+
+/* Event 2: Allocations.
+
+   Most of the data in the trace is the backtrace for each allocation,
+   so the format for backtraces does quite a lot to save space.
+
+   The backtrace is a sequence of location IDs (64-bit opaque codes,
+   see above). This sequence goes from caller to callee - main is at the
+   start of the sequence, and the allocation point at the end.
+
+   First, note that two successive backtraces likely share a long
+   common prefix. These frames are not encoded at all: instead, a
+   single vint common_prefix stores their length.
+
+   The remaining suffix is a sequence of 64-bit opaque codes. A cache
+   of size 2^14 is maintained. If one of the codes is present in the
+   cache, only its 14-bit index need be encoded. If not, a cache slot
+   is allocated to it, and the 14-bit index as well as the 64-bit code
+   are encoded.
+
+   Finally, each cache slot remembers which slot followed it the last
+   time it was encoded, called its "prediction". If it's followed by
+   the same slot next time, then the correctly predicted slot need not
+   be encoded at all. Only the number of correct predictions is
+   encoded, with a special case for the common cases of 0 or 1 correct
+   predictions.
+
+   In particular, this mechanism provides very short encodings of
+   repetitive subsequences, as found in backtraces for e.g. List.map.
+
+   Correct decoding of this requires that the decoder have precisely
+   the same cache and prediction state as the encoder. As a check to
+   ensure that these are not getting out of sync, a different slot's
+   contents and current prediction are written in each packet header
+   (see cache_verify_{ix,val,pred}), so that the decoder can verify
+   that the states match what it expects. (This is not a particularly
+   good defense against data corruption, although it will detect many
+   errors eventually. It is intended mainly to detect bugs in the
+   encoder and decoder implementation). */
+
+typealias struct {
+  enum : integer {size=2; align=1; signed=false;} { hit0 = 0, hit1 = 1, hitN = 2, miss = 3 } tag;
+  integer {size=14; align=1; signed=false;} cache_bucket;
+  variant <tag> {
+    struct {} hit0;
+    struct {} hit1;
+    uint8 hitN;
+    uint64 miss;
+  } v;
+} := backtrace_code;
+
+typealias enum : uint8 { MINOR=0, MAJOR=1, EXTERNAL=2 } := allocation_source;
+
+event {
+  id = 2;
+  name = "alloc";
+  fields := struct {
+    /* Wosize of the allocation (length, in words, excluding header) */
+    vint length;
+    /* Number of samples at this allocation. 1 <= samples <= length+1 */
+    vint samples;
+    /* major/minor/external */
+    allocation_source source;
+    /* Backtrace. See above. */
+    vint common_prefix;
+    uint16 new_suffix;
+    backtrace_code backtrace[new_suffix];
+  };
+};
+
+/* Event 3: Promotion.
+
+   The only information needed for a promotion (beyond the timestamp,
+   which is part of the header) is the ID of the object promoted.
+
+   This ID must be less than or equal to the ID of the last allocation,
+   so (last_alloc_id - promoted_id) is a nonnegative number, often small.
+   This number is encoded as a vint */
+
+event {
+  id = 3;
+  name = "promote";
+  fields := struct {
+    vint obj_id_delta;
+  };
+};
+
+/* Event 4: Collection.
+
+   Same coding as promotion */
+event {
+  id = 4;
+  name = "collect";
+  fields := struct {
+    vint obj_id_delta;
+  };
+};
+
+
+/* Events 101-116. Allocations (short format)
+
+   Most allocations are small, on the minor heap, with a single sample,
+   and a small number of new backtrace slots. These are given a shorter
+   encoding, using the same format for backtraces */
+
+typealias struct {
+  vint common_prefix;
+  uint8 new_suffix;
+  backtrace_code backtrace[new_suffix];
+} := short_alloc;
+event { id = 101; name = "alloc01"; fields := short_alloc; };
+event { id = 102; name = "alloc02"; fields := short_alloc; };
+event { id = 103; name = "alloc03"; fields := short_alloc; };
+event { id = 104; name = "alloc04"; fields := short_alloc; };
+event { id = 105; name = "alloc05"; fields := short_alloc; };
+event { id = 106; name = "alloc06"; fields := short_alloc; };
+event { id = 107; name = "alloc07"; fields := short_alloc; };
+event { id = 108; name = "alloc08"; fields := short_alloc; };
+event { id = 109; name = "alloc09"; fields := short_alloc; };
+event { id = 110; name = "alloc10"; fields := short_alloc; };
+event { id = 111; name = "alloc11"; fields := short_alloc; };
+event { id = 112; name = "alloc12"; fields := short_alloc; };
+event { id = 113; name = "alloc13"; fields := short_alloc; };
+event { id = 114; name = "alloc14"; fields := short_alloc; };
+event { id = 115; name = "alloc15"; fields := short_alloc; };
+event { id = 116; name = "alloc16"; fields := short_alloc; };

src/stdlib_shim.ml

···
+(* In non-OxCaml builds, this file has stub implementations of some OxCaml stdlib features *)
+
+type 'a or_null =
+  | Null
+  | This of 'a
+
+module Obj = struct
+  include Obj
+
+  let magic_uncontended = Fun.id
+end
+
+module Hashtbl = struct
+  include Hashtbl
+  module MakeSeededPortable = MakeSeeded
+end

src/trace.ml

···
+open Stdlib_shim
+(* This is the implementation of the encoder/decoder for the memtrace
+   format. This format is quite involved, and to understand it it's
+   best to read the CTF specification and comments in memtrace.tsl
+   first. *)
+
+(* Increment this when the format changes in an incompatible way *)
+(* Version 2: added context field to trace_info event
+   Version 3: added domain field to packet header *)
+let memtrace_version = 3
+
+(* If this is true, then all backtraces are immediately decoded and
+   verified after encoding. This is slow, but helpful for debugging. *)
+let cache_enable_debug = false
+
+open Buf
+
+exception Parse_error of string
+
+let () =
+  (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function
+    | Parse_error s -> Some ("malformed trace: " ^ s)
+    | _ -> None)
+;;
+
+let[@inline never] bad_format s = raise (Parse_error s)
+let[@inline never] bad_formatf f = Printf.ksprintf (fun s -> bad_format s) f
+let check_fmt s b = if not b then bad_format s
+
+(* Utility types *)
+
+(* Time since the epoch *)
+module Timestamp = struct
+  type t = int64
+
+  let of_int64 t = t
+  let to_int64 t = t
+  let to_float t = Int64.to_float t /. 1_000_000.
+  let of_float f = f *. 1_000_000. |> Int64.of_float
+  let now () = of_float (Unix.gettimeofday ())
+end
+
+(* Time since the start of the trace *)
+module Timedelta = struct
+  type t = int64
+
+  let to_int64 t = t
+  let offset = Int64.add
+end
+
+module IntTbl = Hashtbl.MakeSeededPortable (struct
+    type t = int
+
+    let hash _seed (id : t) =
+      let h = id * 189696287 in
+      h lxor (h lsr 23)
+    ;;
+
+    (* Required for OCaml >= 5.0.0, but causes errors for older compilers
+     because it is an unused value declaration. *)
+    let[@warning "-32"] seeded_hash = hash
+    let equal (a : t) (b : t) = a = b
+  end)
+
+module Domain_id = struct
+  type t = int
+
+  module Tbl = IntTbl
+
+  module Expert = struct
+    let of_int x = x
+  end
+
+  let main_domain = Expert.of_int 0
+end
+
+(** CTF packet headers *)
+
+(* Small enough that Unix.write still does single writes.
+   (i.e. below 64k) *)
+let max_packet_size = 1 lsl 15
+
+type packet_header_info =
+  { content_size : int (* bytes, excluding header *)
+  ; time_begin : Timestamp.t
+  ; time_end : Timestamp.t
+  ; alloc_id_begin : Int64.t
+  ; alloc_id_end : Int64.t
+  ; pid : Int64.t
+  ; version : int
+  ; domain : int
+  ; cache_verifier : Backtrace_codec.Reader.cache_verifier
+  }
+
+(* When writing a packet, some fields can be filled in only once the
+   packet is complete. *)
+type ctf_header_offsets =
+  { off_packet_size : Write.position_32
+  ; off_timestamp_begin : Write.position_64
+  ; off_timestamp_end : Write.position_64
+  ; off_flush_duration : Write.position_32
+  ; off_alloc_begin : Write.position_64
+  ; off_alloc_end : Write.position_64
+  }
+
+let put_ctf_header b ~pid ~domain ~cache =
+  let open Write in
+  put_32 b 0xc1fc1fc1l;
+  let off_packet_size = skip_32 b in
+  let off_timestamp_begin = skip_64 b in
+  let off_timestamp_end = skip_64 b in
+  let off_flush_duration = skip_32 b in
+  put_16 b memtrace_version;
+  put_64 b pid;
+  put_16 b domain;
+  (match cache with
+   | Some c -> Backtrace_codec.Writer.put_cache_verifier c b
+   | None -> Backtrace_codec.Writer.put_dummy_verifier b);
+  let off_alloc_begin = skip_64 b in
+  let off_alloc_end = skip_64 b in
+  { off_packet_size
+  ; off_timestamp_begin
+  ; off_timestamp_end
+  ; off_flush_duration
+  ; off_alloc_begin
+  ; off_alloc_end
+  }
+;;
+
+let finish_ctf_header hdr b ~timestamp_begin ~timestamp_end ~alloc_id_begin ~alloc_id_end =
+  let open Write in
+  let size = b.pos in
+  update_32 b hdr.off_packet_size (Int32.mul (Int32.of_int size) 8l);
+  update_64 b hdr.off_timestamp_begin timestamp_begin;
+  update_64 b hdr.off_timestamp_end timestamp_end;
+  update_32 b hdr.off_flush_duration 0l;
+  update_64 b hdr.off_alloc_begin (Int64.of_int alloc_id_begin);
+  update_64 b hdr.off_alloc_end (Int64.of_int alloc_id_end)
+;;
+
+let get_ctf_header b =
+  let open Read in
+  let start = b.pos in
+  let magic = get_32 b in
+  let packet_size = get_32 b in
+  let time_begin = get_64 b in
+  let time_end = get_64 b in
+  let _flush_duration = get_32 b in
+  let version = get_16 b in
+  let pid = get_64 b in
+  let domain = if version >= 3 then get_16 b else 0 in
+  let cache_verifier = Backtrace_codec.Reader.get_cache_verifier b in
+  let alloc_id_begin = get_64 b in
+  let alloc_id_end = get_64 b in
+  check_fmt "Not a CTF packet" (magic = 0xc1fc1fc1l);
+  if version > memtrace_version
+  then bad_formatf "trace format v%03d, but expected v%03d" version memtrace_version;
+  check_fmt "Bad packet size" (packet_size >= 0l);
+  check_fmt "Monotone packet timestamps" (time_begin <= time_end);
+  check_fmt "Monotone alloc IDs" (alloc_id_begin <= alloc_id_end);
+  let header_size = b.pos - start in
+  { content_size = Int32.(to_int (div packet_size 8l) - header_size)
+  ; time_begin
+  ; time_end
+  ; alloc_id_begin
+  ; alloc_id_end
+  ; pid
+  ; domain
+  ; version
+  ; cache_verifier
+  }
+;;
+
+(** Event headers *)
+
+type evcode =
+  | Ev_trace_info
+  | Ev_location
+  | Ev_alloc
+  | Ev_promote
+  | Ev_collect
+  | Ev_short_alloc of int
+
+let event_code = function
+  | Ev_trace_info -> 0
+  | Ev_location -> 1
+  | Ev_alloc -> 2
+  | Ev_promote -> 3
+  | Ev_collect -> 4
+  | Ev_short_alloc n ->
+    assert (1 <= n && n <= 16);
+    100 + n
+;;
+
+let event_of_code = function
+  | 0 -> Ev_trace_info
+  | 1 -> Ev_location
+  | 2 -> Ev_alloc
+  | 3 -> Ev_promote
+  | 4 -> Ev_collect
+  | n when 101 <= n && n <= 116 -> Ev_short_alloc (n - 100)
+  | c -> bad_format ("Unknown event code " ^ string_of_int c)
+;;
+
+let event_header_time_len = 25
+let event_header_time_mask = 0x1ffffffl
+
+(* NB: packet_max_time is less than (1 lsl event_header_time_len) microsecs *)
+let packet_max_time = 30 * 1_000_000
+
+let put_event_header b ev time =
+  let open Write in
+  let code =
+    Int32.(
+      logor
+        (shift_left (of_int (event_code ev)) event_header_time_len)
+        (logand (Int64.to_int32 time) event_header_time_mask))
+  in
+  put_32 b code
+;;
+
+let[@inline] get_event_header info b =
+  let open Read in
+  let code = get_32 b in
+  let start_low = Int32.logand event_header_time_mask (Int64.to_int32 info.time_begin) in
+  let time_low = Int32.logand event_header_time_mask code in
+  let time_low =
+    if time_low < start_low
+    then (* Overflow *)
+      Int32.(add time_low (of_int (1 lsl event_header_time_len)))
+    else time_low
+  in
+  let time =
+    Int64.(
+      add
+        (logand info.time_begin (lognot (of_int32 event_header_time_mask)))
+        (of_int32 time_low))
+  in
+  check_fmt "time in packet bounds" (info.time_begin <= time && time <= info.time_end);
+  let ev =
+    event_of_code Int32.(to_int (shift_right_logical code event_header_time_len))
+  in
+  ev, time
+;;
+
+module Location = Location_codec.Location
+
+module Obj_id = struct
+  type t = int
+
+  module Tbl = IntTbl
+
+  module Allocator = struct
+    type nonrec t =
+      { global_ids : t Atomic.t
+      ; mutable start_id : t (* first object ID this packet *)
+      ; mutable next_id : t (* next object ID in this packet *)
+      ; mutable last_id : t (* object ID at which we need to reallocate *)
+      }
+
+    let has_next t = t.next_id < t.last_id
+
+    let read_next_exn t =
+      if t.next_id = t.last_id then failwith "Obj_id.Allocator.next_exn: exhausted";
+      t.next_id
+    ;;
+
+    let take_next_exn t =
+      let id = read_next_exn t in
+      t.next_id <- id + 1;
+      id
+    ;;
+
+    let ids_per_chunk = Atomic.make 10_000
+
+    let new_packet t =
+      if not (has_next t)
+      then (
+        let ids_per_chunk = Atomic.get ids_per_chunk in
+        t.next_id <- Atomic.fetch_and_add t.global_ids ids_per_chunk;
+        t.last_id <- t.next_id + ids_per_chunk);
+      t.start_id <- t.next_id
+    ;;
+
+    let of_global_ids global_ids =
+      let t = { global_ids; start_id = 0; next_id = 0; last_id = 0 } in
+      new_packet t;
+      t
+    ;;
+
+    let create () = of_global_ids (Atomic.make 0)
+    let for_new_domain { global_ids; _ } : unit -> t = fun () -> of_global_ids global_ids
+  end
+end
+
+(** Trace info *)
+
+module Info = struct
+  type t =
+    { sample_rate : float
+    ; word_size : int
+    ; executable_name : string
+    ; host_name : string
+    ; ocaml_runtime_params : string
+    ; pid : Int64.t
+    ; initial_domain : Domain_id.t
+    ; start_time : Timestamp.t
+    ; context : string option
+    }
+end
+
+let put_trace_info b (info : Info.t) =
+  let open Write in
+  put_event_header b Ev_trace_info info.start_time;
+  put_float b info.sample_rate;
+  put_8 b info.word_size;
+  put_string b info.executable_name;
+  put_string b info.host_name;
+  put_string b info.ocaml_runtime_params;
+  put_64 b info.pid;
+  let context =
+    match info.context with
+    | None -> ""
+    | Some s -> s
+  in
+  put_string b context
+;;
+
+let get_trace_info b ~packet_info =
+  let open Read in
+  let start_time = packet_info.time_begin in
+  let sample_rate = get_float b in
+  let word_size = get_8 b in
+  let executable_name = get_string b in
+  let host_name = get_string b in
+  let ocaml_runtime_params = get_string b in
+  let pid = get_64 b in
+  let context =
+    if packet_info.version >= 2
+    then (
+      match get_string b with
+      | "" -> None
+      | s -> Some s)
+    else None
+  in
+  { Info.start_time
+  ; sample_rate
+  ; word_size
+  ; executable_name
+  ; host_name
+  ; ocaml_runtime_params
+  ; pid
+  ; initial_domain = packet_info.domain
+  ; context
+  }
+;;
+
+(** Trace writer *)
+
+type writer =
+  { dest : Buf.Shared_writer_fd.t
+  ; pid : int64
+  ; getpid : unit -> int64
+  ; domain : Domain_id.t
+  ; loc_writer : Location_codec.Writer.t
+  ; cache : Backtrace_codec.Writer.t
+  ; debug_reader_cache : Backtrace_codec.Reader.t option
+  ; (* Locations that missed cache in this packet *)
+    mutable new_locs : (int * Location.t list) array
+  ; mutable new_locs_len : int
+  ; new_locs_buf : Bytes.t
+  ; (* Last allocation callstack *)
+    mutable last_callstack : int array
+  ; (* Number of slots that were dropped from the last callstack *)
+    mutable last_dropped_slots : int
+  ; obj_ids : Obj_id.Allocator.t
+  ; mutable packet_time_start : Timestamp.t
+  ; mutable packet_time_end : Timestamp.t
+  ; mutable packet_header : ctf_header_offsets
+  ; mutable packet : Write.t
+  }
+
+let writer_for_domain ~dest ~pid ~getpid ~domain ~obj_ids ~start_time : writer =
+  let packet = Write.of_bytes (Bytes.make max_packet_size '\042') in
+  let packet_header = put_ctf_header packet ~pid ~domain ~cache:None in
+  let cache = Backtrace_codec.Writer.create () in
+  let debug_reader_cache =
+    if cache_enable_debug then Some (Backtrace_codec.Reader.create ()) else None
+  in
+  let s =
+    { dest
+    ; pid
+    ; getpid
+    ; domain
+    ; loc_writer = Location_codec.Writer.create ()
+    ; new_locs = [||]
+    ; new_locs_len = 0
+    ; new_locs_buf = Bytes.make max_packet_size '\042'
+    ; cache
+    ; debug_reader_cache
+    ; last_callstack = [||]
+    ; last_dropped_slots = 0
+    ; obj_ids
+    ; packet_time_start = start_time
+    ; packet_time_end = start_time
+    ; packet_header
+    ; packet
+    }
+  in
+  s
+;;
+
+let make_writer dest ?getpid (info : Info.t) =
+  let dest = Buf.Shared_writer_fd.make dest in
+  let open Write in
+  let getpid =
+    match getpid with
+    | Some getpid -> getpid
+    | None -> fun () -> info.pid
+  in
+  let pid = getpid () in
+  let domain = info.initial_domain in
+  let packet = Write.of_bytes (Bytes.make max_packet_size '\042') in
+  let obj_ids = Obj_id.Allocator.create () in
+  (* Write the trace info packet *)
+  (let hdr = put_ctf_header packet ~pid ~domain ~cache:None in
+   put_trace_info packet info;
+   finish_ctf_header
+     hdr
+     packet
+     ~timestamp_begin:info.start_time
+     ~timestamp_end:info.start_time
+     ~alloc_id_begin:0
+     ~alloc_id_end:0;
+   write_fd dest packet);
+  writer_for_domain ~dest ~pid ~getpid ~domain ~obj_ids ~start_time:info.start_time
+;;
+
+module Location_code = struct
+  type t = int
+
+  module Tbl = IntTbl
+
+  module Expert = struct
+    let of_int t = t
+  end
+end
+
+module Allocation_source = struct
+  type t =
+    | Minor
+    | Major
+    | External
+end
+
+module Event = struct
+  type t =
+    | Alloc of
+        { obj_id : Obj_id.t
+        ; length : int
+        ; domain : Domain_id.t
+        ; nsamples : int
+        ; source : Allocation_source.t
+        ; backtrace_buffer : Location_code.t array
+        ; backtrace_length : int
+        ; common_prefix : int
+        }
+    | Promote of Obj_id.t * Domain_id.t
+    | Collect of Obj_id.t * Domain_id.t
+
+  let to_string decode_loc = function
+    | Alloc
+        { obj_id
+        ; length
+        ; domain
+        ; nsamples
+        ; source
+        ; backtrace_buffer
+        ; backtrace_length
+        ; common_prefix
+        } ->
+      let backtrace =
+        List.init backtrace_length (fun i ->
+          let s = backtrace_buffer.(i) in
+          match decode_loc s with
+          | [] -> Printf.sprintf "$%d" (s :> int)
+          | ls -> String.concat " " (List.map Location.to_string ls))
+        |> String.concat " "
+      in
+      let alloc_src =
+        match source with
+        | Minor -> "alloc"
+        | Major -> "alloc_major"
+        | External -> "alloc_ext"
+      in
+      Printf.sprintf
+        "%010d %s %d len=%d dom=%d % 4d: %s"
+        (obj_id :> int)
+        alloc_src
+        nsamples
+        length
+        (domain :> int)
+        common_prefix
+        backtrace
+    | Promote (id, _dom) -> Printf.sprintf "%010d promote" (id :> int)
+    | Collect (id, _dom) -> Printf.sprintf "%010d collect" (id :> int)
+  ;;
+
+  let domain = function
+    | Alloc { domain; _ } | Promote (_, domain) | Collect (_, domain) -> domain
+  ;;
+end
+
+let log_new_loc s loc =
+  let alen = Array.length s.new_locs in
+  assert (s.new_locs_len <= alen);
+  if s.new_locs_len = alen
+  then (
+    let new_len = if alen = 0 then 32 else alen * 2 in
+    let locs = Array.make new_len loc in
+    Array.blit s.new_locs 0 locs 0 alen;
+    s.new_locs <- locs;
+    s.new_locs_len <- alen + 1)
+  else (
+    s.new_locs.(s.new_locs_len) <- loc;
+    s.new_locs_len <- s.new_locs_len + 1)
+;;
+
+(** Flushing *)
+exception Pid_changed
+
+let flush_at s ~now =
+  (* If the PID has changed, then the process forked and we're in the subprocess.
+     Don't write anything to the file, and raise an exception to quit tracing *)
+  if s.pid <> s.getpid () then raise Pid_changed;
+  let open Write in
+  (* First, flush newly-seen locations.
+     These must be emitted before any events that might refer to them *)
+  let i = ref 0 in
+  while !i < s.new_locs_len do
+    let b = Write.of_bytes s.new_locs_buf in
+    let hdr = put_ctf_header b ~pid:s.pid ~domain:s.domain ~cache:None in
+    while !i < s.new_locs_len && remaining b > Location_codec.Writer.max_length do
+      put_event_header b Ev_location s.packet_time_start;
+      Location_codec.Writer.put_location s.loc_writer b s.new_locs.(!i);
+      incr i
+    done;
+    finish_ctf_header
+      hdr
+      b
+      ~timestamp_begin:s.packet_time_start
+      ~timestamp_end:s.packet_time_start
+      ~alloc_id_begin:s.obj_ids.start_id
+      ~alloc_id_end:s.obj_ids.start_id;
+    write_fd s.dest b
+  done;
+  (* Next, flush the actual events *)
+  finish_ctf_header
+    s.packet_header
+    s.packet
+    ~timestamp_begin:s.packet_time_start
+    ~timestamp_end:s.packet_time_end
+    ~alloc_id_begin:s.obj_ids.start_id
+    ~alloc_id_end:s.obj_ids.next_id;
+  write_fd s.dest s.packet;
+  (* Finally, reset the buffer *)
+  s.packet_time_start <- now;
+  s.packet_time_end <- now;
+  s.new_locs_len <- 0;
+  s.packet <- Write.of_bytes s.packet.buf;
+  Obj_id.Allocator.new_packet s.obj_ids;
+  s.packet_header
+  <- put_ctf_header s.packet ~pid:s.pid ~domain:s.domain ~cache:(Some s.cache)
+;;
+
+let max_ev_size =
+  100
+  (* upper bound on fixed-size portion of events
+         (i.e. not backtraces or locations) *)
+  + max Location_codec.Writer.max_length Backtrace_codec.Writer.max_length
+;;
+
+let begin_event s ev ~(now : Timestamp.t) =
+  let open Write in
+  if remaining s.packet < max_ev_size
+     || s.new_locs_len > 128
+     || Int64.(sub now s.packet_time_start > of_int packet_max_time)
+     || not (Obj_id.Allocator.has_next s.obj_ids)
+  then flush_at s ~now;
+  s.packet_time_end <- now;
+  put_event_header s.packet ev now
+;;
+
+let flush s = flush_at s ~now:s.packet_time_end
+
+(* Returns length of the longest suffix of curr which is also a suffix of prev *)
+let find_common_suffix (prev : int array) prev_start (curr : int array) curr_start =
+  assert (prev_start >= 0);
+  assert (curr_start >= 0);
+  let i = ref (Array.length curr - 1)
+  and j = ref (Array.length prev - 1) in
+  while !i >= curr_start && !j >= prev_start do
+    if Array.unsafe_get curr !i = Array.unsafe_get prev !j
+    then (
+      decr i;
+      decr j)
+    else j := -1
+  done;
+  (* !i is now the highest index of curr that doesn't match prev *)
+  Array.length curr - (!i + 1)
+;;
+
+type alloc_length_format =
+  | Len_short of Write.position_8
+  | Len_long of Write.position_16
+
+let put_alloc
+  s
+  now
+  ~length
+  ~nsamples
+  ~source
+  ~callstack
+  ~callstack_as_ints
+  ~decode_callstack_entry
+  ~drop_slots
+  =
+  let open Write in
+  let common_len =
+    find_common_suffix s.last_callstack s.last_dropped_slots callstack_as_ints drop_slots
+  in
+  let new_len = Array.length callstack_as_ints - common_len in
+  s.last_callstack <- callstack_as_ints;
+  s.last_dropped_slots <- drop_slots;
+  let is_short =
+    1 <= length
+    && length <= 16
+    && source = Allocation_source.Minor
+    && nsamples = 1
+    && new_len < 256
+  in
+  begin_event s (if is_short then Ev_short_alloc length else Ev_alloc) ~now;
+  let id = Obj_id.Allocator.take_next_exn s.obj_ids in
+  let cache = s.cache in
+  let b = s.packet in
+  let src_code =
+    match source with
+    | Minor -> 0
+    | Major -> 1
+    | External -> 2
+  in
+  let bt_len_off =
+    if is_short
+    then (
+      put_vint b common_len;
+      Len_short (skip_8 b))
+    else (
+      put_vint b length;
+      put_vint b nsamples;
+      put_8 b src_code;
+      put_vint b common_len;
+      Len_long (skip_16 b))
+  in
+  let bt_elem_off = b.pos in
+  let log_new_location ~index =
+    log_new_loc s (callstack_as_ints.(index), decode_callstack_entry callstack index)
+  in
+  let nencoded =
+    Backtrace_codec.Writer.put_backtrace
+      cache
+      b
+      ~alloc_id:id
+      ~callstack:callstack_as_ints
+      ~callstack_pos:drop_slots
+      ~callstack_len:new_len
+      ~log_new_location
+  in
+  (match bt_len_off with
+   | Len_short p ->
+     assert (nencoded <= 0xff);
+     update_8 b p nencoded
+   | Len_long p ->
+     (* This can't overflow because there isn't room in a packet for more than
+        0xffff entries. (See max_packet_size) *)
+     assert (nencoded <= 0xffff);
+     update_16 b p nencoded);
+  (match s.debug_reader_cache with
+   | None -> ()
+   | Some c ->
+     let open Read in
+     (* Decode the backtrace and check that it matches *)
+     let b' = Read.of_bytes_sub b.buf ~pos:bt_elem_off ~pos_end:b.pos in
+     let decoded, decoded_len =
+       Backtrace_codec.Reader.get_backtrace c b' ~nencoded ~common_pfx_len:common_len
+     in
+     assert (remaining b' = 0);
+     let rev_callstack =
+       callstack_as_ints |> Array.to_list |> List.rev |> Array.of_list
+     in
+     if Array.sub decoded 0 decoded_len <> rev_callstack
+     then (
+       rev_callstack |> Array.map Int64.of_int |> Array.iter (Printf.printf " %08Lx");
+       Printf.printf " !\n%!";
+       Array.sub decoded 0 decoded_len |> Array.iter (Printf.printf " %08x");
+       Printf.printf " !\n%!";
+       failwith "bad coded backtrace"));
+  id
+;;
+
+let get_alloc ~parse_backtraces ~domain evcode cache alloc_id b =
+  let open Read in
+  let is_short, length, nsamples, source =
+    match evcode with
+    | Ev_short_alloc n -> true, n, 1, Allocation_source.Minor
+    | Ev_alloc ->
+      let length = get_vint b in
+      let nsamples = get_vint b in
+      let source : Allocation_source.t =
+        match get_8 b with
+        | 0 -> Minor
+        | 1 -> Major
+        | 2 -> External
+        | _ -> bad_format "source"
+      in
+      false, length, nsamples, source
+    | _ -> assert false
+  in
+  let common_pfx_len = get_vint b in
+  let nencoded = if is_short then get_8 b else get_16 b in
+  let backtrace_buffer, backtrace_length =
+    if parse_backtraces
+    then Backtrace_codec.Reader.get_backtrace cache b ~nencoded ~common_pfx_len
+    else (
+      Backtrace_codec.Reader.skip_backtrace cache b ~nencoded ~common_pfx_len;
+      [||], 0)
+  in
+  Event.Alloc
+    { obj_id = alloc_id
+    ; length
+    ; domain
+    ; nsamples
+    ; source
+    ; backtrace_buffer
+    ; backtrace_length
+    ; common_prefix = common_pfx_len
+    }
+;;
+
+(* The other events are much simpler *)
+
+let put_promote s now id =
+  let open Write in
+  begin_event s Ev_promote ~now;
+  let b = s.packet in
+  put_vint b (s.obj_ids.next_id - 1 - id)
+;;
+
+let get_promote ~domain alloc_id b =
+  let open Read in
+  let id_delta = get_vint b in
+  check_fmt "promote id sync" (id_delta >= 0);
+  let id = alloc_id - 1 - id_delta in
+  Event.Promote (id, domain)
+;;
+
+let put_collect s now id =
+  let open Write in
+  begin_event s Ev_collect ~now;
+  let b = s.packet in
+  put_vint b (s.obj_ids.next_id - 1 - id)
+;;
+
+let get_collect ~domain alloc_id b =
+  let open Read in
+  let id_delta = get_vint b in
+  (* Typically, id_delta >= 0, because you are collecting an object with an earlier object
+     ID. However, a tricky case in domain termination (collecting an object previously
+     allocated by a now-terminated domain) means that this is not necessarily the case, so
+     there's no assertion here *)
+  let id = alloc_id - 1 - id_delta in
+  Event.Collect (id, domain)
+;;
+
+(** Trace reader *)
+
+type reader =
+  { fd : Unix.file_descr
+  ; info : Info.t
+  ; data_off : int
+  ; loc_table : Location.t list Location_code.Tbl.t
+  }
+
+let make_reader fd =
+  let open Read in
+  let buf = Bytes.make max_packet_size '\042' in
+  let start_pos = Unix.lseek fd 0 SEEK_CUR in
+  let b = read_fd fd buf in
+  let packet_info = get_ctf_header b in
+  let header_size = b.pos in
+  let b, _ = split b packet_info.content_size in
+  check_fmt "trace info packet size" (remaining b >= packet_info.content_size);
+  let ev, evtime = get_event_header packet_info b in
+  check_fmt "trace info packet code" (ev = Ev_trace_info);
+  check_fmt "trace info packet time" (evtime = packet_info.time_begin);
+  let trace_info = get_trace_info b ~packet_info in
+  check_fmt "trace info packet done" (remaining b = 0);
+  let loc_table = Location_code.Tbl.create 20 in
+  let data_off = start_pos + header_size + packet_info.content_size in
+  { fd; info = trace_info; data_off; loc_table }
+;;
+
+let report_hack fmt = Printf.kfprintf (fun ppf -> Printf.fprintf ppf "\n%!") stderr fmt
+
+let refill_to size fd stream =
+  let open Read in
+  if remaining stream < size then refill_fd fd stream else stream
+;;
+
+let iter s ?(parse_backtraces = true) f =
+  let open Read in
+  let per_domain = Domain_id.Tbl.create 1 in
+  let iter_events_of_packet (packet_header : packet_header_info) b =
+    let domain = packet_header.domain in
+    let alloc_id = ref (Int64.to_int packet_header.alloc_id_begin) in
+    let loc_reader, cache, last_timestamp =
+      try Domain_id.Tbl.find per_domain domain with
+      | Not_found ->
+        let reader = Location_codec.Reader.create () in
+        let cache = Backtrace_codec.Reader.create () in
+        let last_timestamp = ref s.info.start_time in
+        Domain_id.Tbl.add per_domain domain (reader, cache, last_timestamp);
+        reader, cache, last_timestamp
+    in
+    if parse_backtraces
+    then
+      if not
+           (Backtrace_codec.Reader.check_cache_verifier
+              cache
+              packet_header.cache_verifier)
+      then bad_format "cache verification";
+    while remaining b > 0 do
+      let ev, time = get_event_header packet_header b in
+      check_fmt "monotone timestamps" (!last_timestamp <= time);
+      last_timestamp := time;
+      let dt = Int64.(sub time s.info.start_time) in
+      match ev with
+      | Ev_trace_info -> bad_format "Multiple trace-info events present"
+      | Ev_location ->
+        let id, loc = Location_codec.Reader.get_location loc_reader b in
+        (*Printf.printf "%3d _ _ location\n" (b.pos - last_pos);*)
+        if Location_code.Tbl.mem s.loc_table id
+        then
+          check_fmt
+            "consistent location info"
+            (Location_code.Tbl.find s.loc_table id = loc)
+        else Location_code.Tbl.add s.loc_table id loc
+      | (Ev_alloc | Ev_short_alloc _) as evcode ->
+        let info = get_alloc ~parse_backtraces ~domain evcode cache !alloc_id b in
+        incr alloc_id;
+        (*Printf.printf "%3d " (b.pos - last_pos);*)
+        f dt info
+      | Ev_collect ->
+        let info = get_collect ~domain !alloc_id b in
+        (*Printf.printf "%3d " (b.pos - last_pos);*)
+        f dt info
+      | Ev_promote ->
+        let info = get_promote ~domain !alloc_id b in
+        (*Printf.printf "%3d " (b.pos - last_pos);*)
+        f dt info
+    done;
+    check_fmt "alloc id sync" (packet_header.alloc_id_end = Int64.of_int !alloc_id)
+  in
+  Unix.lseek s.fd s.data_off SEEK_SET |> ignore;
+  let rec iter_packets stream =
+    let header_upper_bound = 200 (* more than big enough for a header *) in
+    let stream = refill_to header_upper_bound s.fd stream in
+    if remaining stream = 0
+    then ()
+    else (
+      let packet_header = get_ctf_header stream in
+      let stream = refill_to packet_header.content_size s.fd stream in
+      let packet, rest = split stream packet_header.content_size in
+      if packet_header.pid <> s.info.pid
+      then
+        report_hack
+          "skipping bad packet (wrong pid: %Ld, but tracing %Ld)"
+          packet_header.pid
+          s.info.pid
+      else if remaining packet <> packet_header.content_size
+      then report_hack "skipping truncated packet"
+      else iter_events_of_packet packet_header packet;
+      iter_packets rest)
+  in
+  iter_packets (read_fd s.fd (Bytes.make max_packet_size '\000'))
+;;
+
+module Private = struct
+  let name_of_memprof_tracer = Atomic.make ""
+
+  let set_name_of_memprof_tracer_module s =
+    Atomic.set name_of_memprof_tracer (s ^ ".ext_alloc")
+  ;;
+
+  let obj_ids_per_chunk = Obj_id.Allocator.ids_per_chunk
+end
+
+module Writer = struct
+  type t = writer
+
+  exception Pid_changed = Pid_changed
+
+  let create = make_writer
+  let domain t = t.domain
+
+  let for_domain_at_time ~start_time t : domain:int -> t =
+    let { dest; pid; getpid; _ } = t in
+    let obj_ids = Obj_id.Allocator.for_new_domain t.obj_ids in
+    fun ~domain ->
+      let obj_ids = obj_ids () in
+      let t = writer_for_domain ~dest ~pid ~getpid ~domain ~obj_ids ~start_time in
+      t
+  ;;
+
+  let for_domain t = for_domain_at_time ~start_time:t.packet_time_end t
+
+  (* Unfortunately, efficient access to the backtrace is not possible
+     with the current Printexc API, even though internally it's an int
+     array. For now, wave the Obj.magic wand. There's a PR to fix this:
+     https://github.com/ocaml/ocaml/pull/9663 *)
+  let location_code_array_of_raw_backtrace (b : Printexc.raw_backtrace)
+    : Location_code.t array
+    =
+    Obj.magic b
+  ;;
+
+  (* Is this a location that we'd prefer to leave out of traces? This mechanism only
+     really makes sense for inlinable functions, so that we can drop a single frame out of
+     a backtrace slot. For non-inlinable functions like
+     [Memprof_tracer.ext_alloc_slowpath], we instead avoid capturing the slot to begin
+     with (using [put_alloc_with_suffix_of_raw_backtrace]). *)
+  let is_internal_location (loc : Location.t) =
+    String.equal loc.defname (Atomic.get Private.name_of_memprof_tracer)
+  ;;
+
+  let decode_raw_backtrace_entry callstack i : Location.t list =
+    let open Printexc in
+    let rec get_locations slot : Location.t list =
+      let tail =
+        match get_raw_backtrace_next_slot slot with
+        | None -> []
+        | Some slot -> get_locations slot
+      in
+      let slot = convert_raw_backtrace_slot slot in
+      match Slot.location slot with
+      | None -> tail
+      | Some { filename; line_number; start_char; end_char; _ } ->
+        let defname =
+          match Slot.name slot with
+          | Some n -> n
+          | _ -> "??"
+        in
+        { filename; line = line_number; start_char; end_char; defname } :: tail
+    in
+    let locs = get_locations (get_raw_backtrace_slot callstack i) |> List.rev in
+    match List.filter (fun loc -> not (is_internal_location loc)) locs with
+    | [] ->
+      (* It would break things to return an empty list here, and the worst that happens if
+         we return the whole list is occasionally slightly confusing output (it looks like
+         Memtrace is using memory rather than user code). *)
+      locs
+    | at_least_one -> at_least_one
+  ;;
+
+  let put_alloc_with_suffix_of_raw_backtrace
+    t
+    now
+    ~length
+    ~nsamples
+    ~source
+    ~callstack
+    ~drop_slots
+    =
+    let callstack_as_ints = location_code_array_of_raw_backtrace callstack in
+    put_alloc
+      t
+      now
+      ~length
+      ~nsamples
+      ~source
+      ~callstack
+      ~callstack_as_ints
+      ~decode_callstack_entry:decode_raw_backtrace_entry
+      ~drop_slots
+  ;;
+
+  let put_alloc_with_raw_backtrace t now ~length ~nsamples ~source ~callstack =
+    let callstack_as_ints = location_code_array_of_raw_backtrace callstack in
+    put_alloc
+      t
+      now
+      ~length
+      ~nsamples
+      ~source
+      ~callstack
+      ~callstack_as_ints
+      ~decode_callstack_entry:decode_raw_backtrace_entry
+      ~drop_slots:0
+  ;;
+
+  let put_alloc t now ~length ~nsamples ~source ~callstack ~decode_callstack_entry =
+    let decode_callstack_entry cs i = decode_callstack_entry cs.(i) in
+    put_alloc
+      t
+      now
+      ~length
+      ~nsamples
+      ~source
+      ~callstack
+      ~callstack_as_ints:callstack
+      ~decode_callstack_entry
+      ~drop_slots:0
+  ;;
+
+  let put_collect = put_collect
+  let put_promote = put_promote
+  let flush = flush
+
+  let close t =
+    flush t;
+    Buf.Shared_writer_fd.close t.dest
+  ;;
+
+  let put_event w ~decode_callstack_entry now (ev : Event.t) =
+    if Event.domain ev <> w.domain
+    then raise (Invalid_argument "Trace.put_event: mismatched domain fields");
+    if now < w.packet_time_end
+    then raise (Invalid_argument "Trace.put_event: out-of-order timestamps");
+    match ev with
+    | Alloc
+        { obj_id
+        ; length
+        ; domain = _
+        ; nsamples
+        ; source
+        ; backtrace_buffer
+        ; backtrace_length
+        ; common_prefix = _
+        } ->
+      let btrev =
+        Array.init backtrace_length (fun i -> backtrace_buffer.(backtrace_length - 1 - i))
+      in
+      let id =
+        put_alloc w now ~length ~nsamples ~source ~callstack:btrev ~decode_callstack_entry
+      in
+      if id <> obj_id then raise (Invalid_argument "Incorrect allocation ID")
+    | Promote (id, _domain) -> put_promote w now id
+    | Collect (id, _domain) -> put_collect w now id
+  ;;
+
+  module Multiplexed_domains = struct
+    type nonrec t =
+      { mutable last_domain : Domain_id.t
+      ; (* Invariant: all writers except possibly that of [last_domain] are flushed *)
+        writers : t Domain_id.Tbl.t
+      ; start_time : Timestamp.t
+      }
+
+    let create dest ?getpid info =
+      let w = create dest ?getpid info in
+      let writers = Domain_id.Tbl.create 1 in
+      let dom = domain w in
+      Domain_id.Tbl.add writers dom w;
+      { last_domain = dom; writers; start_time = info.start_time }
+    ;;
+
+    let writer_for_domain t ~domain =
+      let last_w = Domain_id.Tbl.find t.writers t.last_domain in
+      if domain = t.last_domain
+      then last_w
+      else (
+        flush last_w;
+        t.last_domain <- domain;
+        try Domain_id.Tbl.find t.writers domain with
+        | Not_found ->
+          let w = (for_domain_at_time ~start_time:t.start_time last_w) ~domain in
+          Domain_id.Tbl.add t.writers domain w;
+          w)
+    ;;
+
+    let next_alloc_id t ~domain =
+      let w = writer_for_domain t ~domain in
+      if not (Obj_id.Allocator.has_next w.obj_ids) then flush_at w ~now:w.packet_time_end;
+      Obj_id.Allocator.read_next_exn w.obj_ids
+    ;;
+
+    let put_event t ~decode_callstack_entry time ev =
+      let w = writer_for_domain t ~domain:(Event.domain ev) in
+      put_event w ~decode_callstack_entry time ev
+    ;;
+
+    let flush t = flush (Domain_id.Tbl.find t.writers t.last_domain)
+  end
+end
+
+module Reader = struct
+  type t = reader
+
+  let create = make_reader
+  let info s = s.info
+
+  let lookup_location_code { loc_table; _ } code =
+    match Location_code.Tbl.find loc_table code with
+    | v -> v
+    | exception Not_found ->
+      raise (Invalid_argument (Printf.sprintf "invalid location code %08x" code))
+  ;;
+
+  let iter = iter
+  let open_ ~filename = make_reader (Unix.openfile filename [ Unix.O_RDONLY ] 0)
+  let size_bytes s = (Unix.LargeFile.fstat s.fd).st_size
+  let close s = Unix.close s.fd
+end

src/trace.mli

···
+(** Encoder and decoder for Memtrace traces *)
+
+(** Timestamps *)
+module Timestamp : sig
+  type t
+
+  val now : unit -> t
+
+  (** Convert to and from the number of microseconds since the Unix epoch *)
+  val of_int64 : int64 -> t
+
+  val to_int64 : t -> int64
+
+  (** Convert back and forth between the Unix module's float format and timestamps *)
+  val to_float : t -> float
+
+  val of_float : float -> t
+end
+
+(** Times measured from the start of the trace *)
+module Timedelta : sig
+  type t
+
+  (** Convert to the number of microseconds since the start of the trace *)
+  val to_int64 : t -> int64
+
+  val offset : Timestamp.t -> t -> Timestamp.t
+end
+
+(** Source locations in the traced program *)
+module Location : sig
+  type t =
+    { filename : string
+    ; line : int
+    ; start_char : int
+    ; end_char : int
+    ; defname : string
+    }
+
+  val to_string : t -> string
+  val unknown : t
+end
+
+(** Identifiers to represent allocations *)
+module Obj_id : sig
+  type t = private int
+
+  (** For convenience, a hashtable keyed by object ID *)
+  module Tbl : Hashtbl.SeededS with type key = t
+end
+
+(** Identifiers to represent domains *)
+module Domain_id : sig
+  type t = private int
+
+  val main_domain : t
+
+  module Expert : sig
+    val of_int : int -> t
+  end
+end
+
+(** Codes for subsequences of locations in a backtrace *)
+module Location_code : sig
+  type t = private int
+
+  (** For convenience, a hashtable keyed by location code *)
+  module Tbl : Hashtbl.SeededS with type key = t
+
+  module Expert : sig
+    val of_int : int -> t
+  end
+end
+
+(** Types of allocation *)
+module Allocation_source : sig
+  type t =
+    | Minor
+    | Major
+    | External
+end
+
+(** Trace events *)
+module Event : sig
+  type t =
+    | Alloc of
+        { obj_id : Obj_id.t
+        (** An identifier for this allocation, used to refer to it in other events. These
+            identifiers are generated in allocation order.
+
+            Identifiers are not reused across domains. *)
+        ; length : int
+        (** The ID of the domain on which this event occurred.
+
+            All events with the same obj_id will occur on the same domain, unless that
+            domain terminates before collecting this object (in which case promotion or
+            collection events may occur on an arbitrary domain, but will always appear in
+            order Alloc-Promote-Collect for a given obj_id).
+
+            Events from different domains and different obj_ids may appear out-of-order in
+            a trace: timestamps and object identifiers are only guaranteed to increase
+            monotonically among events from a single domain. Readers that require a global
+            order of events must merge the streams of events from different domains. *)
+        ; domain : Domain_id.t
+        (** Length of the sampled allocation, in words, not including header word *)
+        ; nsamples : int (** Number of samples made in this allocation. At least 1. *)
+        ; source : Allocation_source.t (** How this object was initially allocated *)
+        ; backtrace_buffer : Location_code.t array
+        (** Backtrace of the allocation. The backtrace elements are stored in order from
+            caller to callee. The first element is the main entrypoint and the last is the
+            allocation.
+
+            NB: this is a mutable buffer, reused between events. Entries at indices beyond
+            [backtrace_length - 1] are not meaningful. If you want to store backtraces,
+            you must copy them using: [Array.sub backtrace_buffer 0 backtrace_length]. *)
+        ; backtrace_length : int (** Length of the backtrace *)
+        ; common_prefix : int
+        (** A prefix of this length has not changed since the last allocation event that
+            occurred on the same domain. *)
+        }
+    | Promote of Obj_id.t * Domain_id.t
+    | Collect of Obj_id.t * Domain_id.t
+
+  val domain : t -> Domain_id.t
+  val to_string : (Location_code.t -> Location.t list) -> t -> string
+end
+
+(** Global trace info *)
+module Info : sig
+  type t =
+    { sample_rate : float
+    ; word_size : int
+    ; executable_name : string
+    ; host_name : string
+    ; ocaml_runtime_params : string
+    ; pid : Int64.t
+    ; initial_domain : Domain_id.t
+    ; start_time : Timestamp.t
+    ; context : string option
+    }
+end
+
+(** Writing traces *)
+module Writer : sig
+  type t
+
+  exception Pid_changed
+
+  val create : Unix.file_descr -> ?getpid:(unit -> int64) -> Info.t -> t
+  val domain : t -> Domain_id.t
+  val for_domain : t -> domain:Domain_id.t -> t
+
+  (** All of the functions below may raise Unix_error if writing to the file descriptor
+      fails, or Pid_changed if getpid returns a different value. *)
+
+  val put_alloc
+    :  t
+    -> Timestamp.t
+    -> length:int
+    -> nsamples:int
+    -> source:Allocation_source.t
+    -> callstack:Location_code.t array
+    -> decode_callstack_entry:(Location_code.t -> Location.t list)
+    -> Obj_id.t
+
+  val put_alloc_with_raw_backtrace
+    :  t
+    -> Timestamp.t
+    -> length:int
+    -> nsamples:int
+    -> source:Allocation_source.t
+    -> callstack:Printexc.raw_backtrace
+    -> Obj_id.t
+
+  val put_alloc_with_suffix_of_raw_backtrace
+    :  t
+    -> Timestamp.t
+    -> length:int
+    -> nsamples:int
+    -> source:Allocation_source.t
+    -> callstack:Printexc.raw_backtrace
+    -> drop_slots:int
+    -> Obj_id.t
+
+  val put_collect : t -> Timestamp.t -> Obj_id.t -> unit
+  val put_promote : t -> Timestamp.t -> Obj_id.t -> unit
+
+  (** Flushes currently buffered events. The [file_descr] is not closed, and more events
+      may be written after flush. *)
+  val flush : t -> unit
+
+  (** Flushes and closes the underlying [file_descr] *)
+  val close : t -> unit
+
+  module Multiplexed_domains : sig
+    (** A set of per-domain [Writer.t]s, allowing events from different domains to be
+        multiplexed into a single stream *)
+    type t
+
+    val create : Unix.file_descr -> ?getpid:(unit -> int64) -> Info.t -> t
+
+    val put_event
+      :  t
+      -> decode_callstack_entry:(Location_code.t -> Location.t list)
+      -> Timestamp.t
+      -> Event.t
+      -> unit
+
+    val next_alloc_id : t -> domain:Domain_id.t -> Obj_id.t
+    val flush : t -> unit
+  end
+end
+
+(** Reading traces *)
+module Reader : sig
+  type t
+
+  val create : Unix.file_descr -> t
+  val info : t -> Info.t
+  val lookup_location_code : t -> Location_code.t -> Location.t list
+
+  (** Iterate over a trace *)
+  val iter : t -> ?parse_backtraces:bool -> (Timedelta.t -> Event.t -> unit) -> unit
+
+  (** Convenience functions for accessing traces stored in files *)
+  val open_ : filename:string -> t
+
+  val size_bytes : t -> int64
+  val close : t -> unit
+end
+
+module Private : sig
+  (*_ Internal hack to avoid depending on build-system-specific behavior *)
+  val set_name_of_memprof_tracer_module : string -> unit
+
+  (* For testing *)
+  val obj_ids_per_chunk : int Atomic.t
+end

test/copy.ml

···
+open Memtrace.Trace
+
+let copy inf outf =
+  let r = Reader.open_ ~filename:inf in
+  let wfd = Unix.openfile outf [ O_CREAT; O_WRONLY; O_TRUNC ] 0o600 in
+  let info = Reader.info r in
+  let pid = info.pid in
+  let w = Writer.Multiplexed_domains.create wfd ~getpid:(fun () -> pid) info in
+  Reader.iter r (fun now ev ->
+    Writer.Multiplexed_domains.put_event
+      w
+      ~decode_callstack_entry:(fun loc -> Reader.lookup_location_code r loc)
+      (Timedelta.offset info.start_time now)
+      ev);
+  Reader.close r;
+  Writer.Multiplexed_domains.flush w;
+  Unix.close wfd
+;;
+
+let () =
+  match Sys.argv with
+  | [| _; inf; outf |] -> copy inf outf
+  | _ ->
+    Printf.fprintf stderr "usage: copy <in> <out>\n%!";
+    exit 1
+;;

test/dune

···
+(executables
+ (modes byte exe)
+ (names test copy trace geom_sampler fork)
+ (libraries memtrace unix)
+ (preprocess
+  (pps ppx_jane)))
+
+(rule
+ (deps test.exe)
+ (action
+  (run ./test.exe))
+ (alias runtest))
+
+(rule
+ (deps trace.exe)
+ (action
+  (run ./trace.exe))
+ (alias runtest))
+
+(rule
+ (deps fork.exe)
+ (action
+  (run ./fork.exe))
+ (alias runtest))
+
+(rule
+ (deps geom_sampler.exe geom_sampler.expected)
+ (action
+  (bash "diff geom_sampler.expected <(./geom_sampler.exe)"))
+ (alias runtest))
+
+(rule
+ (targets ocamlopt.ctf.copy)
+ (deps copy.exe ocamlopt.ctf)
+ (action
+  (run ./copy.exe ocamlopt.ctf ocamlopt.ctf.copy)))
+
+(rule
+ (targets ocamlopt.ctf.txt)
+ (deps ../bin/dump_trace.exe ocamlopt.ctf)
+ (action
+  (bash "../bin/dump_trace.exe ocamlopt.ctf > ocamlopt.ctf.txt")))
+
+(rule
+ (targets ocamlopt.ctf.copy.txt)
+ (deps ../bin/dump_trace.exe ocamlopt.ctf.copy)
+ (action
+  (bash "../bin/dump_trace.exe ocamlopt.ctf.copy > ocamlopt.ctf.copy.txt")))
+
+(rule
+ (deps ocamlopt.ctf.txt ocamlopt.ctf.copy.txt)
+ (action
+  (bash "diff -u ocamlopt.ctf.txt ocamlopt.ctf.copy.txt"))
+ (alias runtest))
+
+(rule
+ (deps ocamlopt.ctf ocamlopt.ctf.copy)
+ (action
+  (bash "cmp ocamlopt.ctf ocamlopt.ctf.copy"))
+ (alias runtest))

test/fork.ml

···
+let test_fork ~quick_exit () =
+  let filename = Filename.temp_file "memtrace" "ctf" in
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" filename;
+  let tr = Memtrace.start_tracing ~context:None ~sampling_rate:1. ~filename in
+  let alloc_before = 1234
+  and alloc_after = 7364
+  and alloc_child = 42 in
+  let _ : string array = Sys.opaque_identity Array.make alloc_before "a" in
+  (match Unix.fork () with
+   | 0 ->
+     let count = if quick_exit then 1 else 1000000 in
+     for _i = 1 to count do
+       ignore (Sys.opaque_identity Array.make alloc_child "a" : string array)
+     done;
+     exit 0
+   | pid ->
+     (match Unix.waitpid [] pid with
+      | _, WEXITED 0 -> ()
+      | _ -> assert false));
+  let _ : string array = Sys.opaque_identity Array.make alloc_after "a" in
+  Memtrace.stop_tracing tr;
+  let module R = Memtrace.Trace.Reader in
+  let tr = R.open_ ~filename in
+  let sizes = Hashtbl.create 20 in
+  R.iter tr (fun _time ev ->
+    match ev with
+    | Alloc a -> Hashtbl.add sizes a.length ()
+    | _ -> ());
+  assert (Hashtbl.mem sizes alloc_before);
+  assert (Hashtbl.mem sizes alloc_after);
+  assert (not (Hashtbl.mem sizes alloc_child));
+  ()
+;;
+
+let () = test_fork ~quick_exit:false ()
+let () = test_fork ~quick_exit:true ()

test/geom_sampler.expected

···
+sample rate: 0.01 (0.01), P(X = 3): 0.01 (0.01)
+sample rate: 0.13 (0.13), P(X = 3): 0.10 (0.10)
+sample rate: 0.42 (0.42), P(X = 3): 0.14 (0.14)
+sample rate: 0.73 (0.73), P(X = 3): 0.05 (0.05)
+sample rate: 1.00 (1.00), P(X = 3): 0.00 (0.00)

test/geom_sampler.ml

···
+open Memtrace.Geometric_sampler
+
+let test ~sampling_rate =
+  let t = make ~sampling_rate () in
+  let total = 100000 in
+  let s = ref total in
+  let n = ref 0 in
+  let n3 = ref 0 in
+  let rec go () =
+    let k = draw t in
+    s := !s - k;
+    if !s >= 0
+    then (
+      incr n;
+      if k = 3 then incr n3;
+      go ())
+  in
+  go ();
+  let observed_rate = float_of_int !n /. float_of_int total in
+  let expected_p3 = (1. -. sampling_rate) *. (1. -. sampling_rate) *. sampling_rate in
+  let observed_p3 = float_of_int !n3 /. float_of_int !n in
+  (* These numbers are printed at low precision to have a high probability of producing
+     the same answer. (We don't expect the observed and expected numbers to be exactly
+     equal) *)
+  Printf.printf
+    "sample rate: %.2f (%.2f), P(X = 3): %.2f (%.2f)\n"
+    sampling_rate
+    observed_rate
+    expected_p3
+    observed_p3
+;;
+
+let () = [ 0.01; 0.13; 0.42; 0.73; 1. ] |> List.iter (fun s -> test ~sampling_rate:s)

test/test.ml

···
+open Memtrace.Trace
+
+let with_temp f =
+  let s = Filename.temp_file "memtrace" "ctf" in
+  let fd = Unix.openfile s [ O_RDWR ] 0o600 in
+  Fun.protect
+    ~finally:(fun () -> if Sys.file_exists s then Unix.unlink s)
+    (fun () -> f fd)
+;;
+
+let mkloc filename line start_char end_char defname =
+  Location.{ filename; line; start_char; end_char; defname }
+;;
+
+(* These locations are expected to be encoded and decoded accurately *)
+let reasonable_locations =
+  [ [ mkloc "foo.ml" 42 100 120 "func" ]
+  ; [ mkloc "apiosdjfoaijsdf.ml" 100 58 1023 "aiosjdf" ]
+  ; [ mkloc "apiosdjfoaijsdf.ml" 19 97 1023 "aiosjdf"; mkloc "inline" 1 1 1 "fjkisda" ]
+  ]
+;;
+
+(* These locations are too big, and are expected to be encoded as "unknown" *)
+let ridiculous_locations =
+  [ [ mkloc (String.make 60000 'j') 1000 1000 1000 (String.make 60000 'a') ]
+  ; List.init 10000 (fun _ -> mkloc "asdf.ml" 42 93 84 "Asdf.fun")
+  ]
+;;
+
+let locations = Array.of_list (reasonable_locations @ ridiculous_locations)
+let id : int -> Obj_id.t = Obj.magic
+let dom : int -> Domain_id.t = Obj.magic
+let loc (n : int) : Location_code.t = Obj.magic (n + 1)
+
+let info : Info.t =
+  { sample_rate = 0.01
+  ; word_size = 64
+  ; executable_name = "exec"
+  ; host_name = "host"
+  ; ocaml_runtime_params = "runtime"
+  ; pid = 42L
+  ; initial_domain = dom 0
+  ; start_time = Timestamp.of_int64 23897423L
+  ; context = Some "context"
+  }
+;;
+
+let events : (int * Event.t) list =
+  let big_length =
+    if Int.max_int > 0x3fff_ffff then int_of_string "0x81234567" else 0x31234567
+  in
+  [ ( 0
+    , Alloc
+        { obj_id = id 0
+        ; length = 42
+        ; domain = dom 0
+        ; nsamples = 1
+        ; source = Minor
+        ; backtrace_buffer = [| loc 0; loc 1 |]
+        ; backtrace_length = 2
+        ; common_prefix = 0
+        } )
+  ; ( 1
+    , Alloc
+        { obj_id = id 1
+        ; length = 2
+        ; domain = dom 0
+        ; nsamples = 1
+        ; source = Major
+        ; backtrace_buffer = [| loc 0; loc 1; loc 2 |]
+        ; backtrace_length = 3
+        ; common_prefix = 2
+        } )
+  ; ( 100
+    , Alloc
+        { obj_id = id 2
+        ; length = big_length
+        ; domain = dom 0
+        ; nsamples = 1
+        ; source = Minor
+        ; backtrace_buffer = [| loc 0; loc 1; loc 2 |]
+        ; backtrace_length = 3
+        ; common_prefix = 3
+        } )
+  ; 101, Collect (id 1, dom 0)
+  ; 102, Promote (id 2, dom 0)
+  ; ( 103
+    , Alloc
+        { obj_id = id 3
+        ; length = 2
+        ; domain = dom 0
+        ; nsamples = 1
+        ; source = External
+        ; backtrace_buffer = [| loc 3 |]
+        ; backtrace_length = 1
+        ; common_prefix = 0
+        } )
+  ; ( 103
+    , Alloc
+        { obj_id = id 4
+        ; length = 2
+        ; domain = dom 0
+        ; nsamples = 1
+        ; source = Minor
+        ; backtrace_buffer = [| loc 4 |]
+        ; backtrace_length = 1
+        ; common_prefix = 0
+        } )
+  ]
+;;
+
+let copy_event : Event.t -> Event.t = function
+  | Alloc ev ->
+    Alloc
+      { ev with backtrace_buffer = Array.sub ev.backtrace_buffer 0 ev.backtrace_length }
+  | ev -> ev
+;;
+
+let test () =
+  with_temp
+  @@ fun fd ->
+  let w = Writer.Multiplexed_domains.create fd info in
+  let decode_loc l = locations.((l : Location_code.t :> int) - 1) in
+  events
+  |> List.iter (fun (i, ev) ->
+    let now = Int64.(add (Timestamp.to_int64 info.start_time) (of_int (i * 1_000_000))) in
+    Writer.Multiplexed_domains.put_event
+      w
+      ~decode_callstack_entry:decode_loc
+      (Timestamp.of_int64 now)
+      ev);
+  Writer.Multiplexed_domains.flush w;
+  let _ : int = Unix.lseek fd 0 SEEK_SET in
+  let r = Reader.create fd in
+  assert (Reader.info r = info);
+  let evs = ref [] in
+  Reader.iter r ~parse_backtraces:true (fun td ev ->
+    (* assert (Int64.rem td 1_000_000L = 0L); *)
+    evs
+    := (Int64.(to_int (div (Timedelta.to_int64 td) 1_000_000L)), copy_event ev) :: !evs);
+  let rec compare exp act =
+    match exp, act with
+    | [], [] -> ()
+    | exp :: exps, act :: acts when exp = act -> compare exps acts
+    | [], (tact, act) :: _ ->
+      Printf.printf
+        "Extra event decoded:\n  %d. %s\n%!"
+        tact
+        (Event.to_string decode_loc act);
+      failwith "Extra events"
+    | (texp, exp) :: _, [] ->
+      Printf.printf "Missing event:\n  %d. %s\n%!" texp (Event.to_string decode_loc exp);
+      failwith "Missing events"
+    | (texp, exp) :: _, (tact, act) :: _ ->
+      Printf.printf
+        "Event doesn't match. Expected:\n  %d. %s\nbut decoded:\n  %d. %s\n%!"
+        texp
+        (Event.to_string decode_loc exp)
+        tact
+        (Event.to_string decode_loc act);
+      failwith "Incorrect event"
+  in
+  compare events (List.rev !evs);
+  for i = 0 to List.length reasonable_locations - 1 do
+    assert (Reader.lookup_location_code r (loc i) = locations.(i))
+  done;
+  for i = List.length reasonable_locations to Array.length locations - 1 do
+    assert (Reader.lookup_location_code r (loc i) = [ Location.unknown ])
+  done;
+  Reader.close r
+;;
+
+let test_failure () =
+  with_temp
+  @@ fun fd ->
+  let w = Writer.create fd info in
+  let got_epipe = Atomic.make false in
+  let report_exn = function
+    | Unix.Unix_error (Unix.EPIPE, "write", _) -> Atomic.set got_epipe true
+    | e -> raise e
+  in
+  let t = Memtrace.Memprof_tracer.start ~report_exn ~sampling_rate:0.2 w in
+  for _i = 1 to 50000 do
+    let _ : int ref = Sys.opaque_identity (ref 42) in
+    ()
+  done;
+  let rd, wr = Unix.pipe () in
+  if not Sys.win32 then Sys.Safe.set_signal Sys.sigpipe Signal_ignore;
+  Unix.close rd;
+  Unix.dup2 wr fd;
+  Unix.close wr;
+  for _i = 1 to 50000 do
+    let _ : int ref = Sys.opaque_identity (ref 42) in
+    ()
+  done;
+  Memtrace.Memprof_tracer.stop t;
+  if not (Atomic.get got_epipe) then failwith "should have failed"
+;;
+
+let () = test ()
+let () = test_failure ()

test/trace.ml

···
+let check_errors () =
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" "/bad/file/name";
+  (match Memtrace.trace_if_requested () with
+   | _ -> assert false
+   | exception Invalid_argument _ -> ());
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" "/tmp/goodfilename";
+  (match Memtrace.trace_if_requested ~sampling_rate:(-3.) () with
+   | _ -> assert false
+   | exception Invalid_argument _ -> ());
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" "/tmp/goodfilename";
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE_RATE" "42";
+  (match Memtrace.trace_if_requested () with
+   | _ -> assert false
+   | exception Invalid_argument _ -> ());
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE" "/tmp/goodfilename";
+  (Unix.putenv [@ocaml.alert "-unsafe_multidomain"]) "MEMTRACE_RATE" "potato";
+  match Memtrace.trace_if_requested () with
+  | _ -> assert false
+  | exception Invalid_argument _ -> ()
+;;
+
+let () = check_errors ()
+
+let is_bad_location (loc : Memtrace.Trace.Location.t) =
+  let defname = loc.defname in
+  String.ends_with defname ~suffix:"ext_alloc"
+  || String.ends_with defname ~suffix:"ext_alloc_slowpath"
+;;
+
+let validate_ext_alloc_backtrace r bt len =
+  (* Make sure the backtrace has been scrubbed of calls to
+     [ext_alloc] and [ext_alloc_slowpath] in [memprof_tracer.ml] *)
+  for i = 0 to len - 1 do
+    let locs = Memtrace.Trace.Reader.lookup_location_code r bt.(i) in
+    List.iter
+      (fun (loc : Memtrace.Trace.Location.t) -> assert (not (is_bad_location loc)))
+      locs
+  done
+;;
+
+let globs = Array.make 1000 [||]
+let nglobs = ref 0
+
+let leak x =
+  globs.(!nglobs) <- x;
+  incr nglobs
+;;
+
+let each_iter () = leak (Array.make 1000 0)
+
+let rec long_bt = function
+  | 0 ->
+    leak (Array.make 1000 0);
+    (Sys.opaque_identity List.iter) each_iter [ () ];
+    42
+  | n -> if Random.bool () then 1 + long_bt (n - 1) else 2 + long_bt (n - 1)
+;;
+
+let go () =
+  let filename = Filename.temp_file "memtrace" "ctf" in
+  (* Check that we can recover from a bad sampling rate *)
+  (match Memtrace.start_tracing ~context:(Some "ctx") ~sampling_rate:42.0 ~filename with
+   | _ -> failwith "should have failed"
+   | exception _ -> ());
+  (* Verify that non-initial domains aren't traced *)
+  let dom_func () =
+    for _i = 1 to 10 do
+      let _ : int array = Array.make 500 42 |> Sys.opaque_identity in
+      match Memtrace.External.alloc ~bytes:50 with
+      | Null -> ()
+      | This _ -> assert false
+    done
+  in
+  let _ : _ = Sys.opaque_identity dom_func in
+  let t = Memtrace.start_tracing ~context:(Some "ctx") ~sampling_rate:0.1 ~filename in
+  let spawn_traced_domain () =
+    (Domain.Safe.spawn [@inlined never] [@alert "-do_not_spawn_domains"])
+      (Obj.magic_portable dom_func) [@nontail]
+  in
+  let domain =
+    if Domain.recommended_domain_count () <= 1
+    then None
+    else Some (spawn_traced_domain ())
+  in
+  leak (Array.make 4242 42);
+  for _i = 1 to 10 do
+    let n = long_bt 10_000 in
+    assert (n > 0)
+  done;
+  for _i = 1 to 1000 do
+    match Memtrace.External.alloc ~bytes:(Sys.word_size / 8 * 7) with
+    | Null -> ()
+    | This token -> Memtrace.External.free token
+  done;
+  Memtrace.stop_tracing t;
+  Option.iter Domain.join domain;
+  let r = Memtrace.Trace.Reader.open_ ~filename in
+  let first = ref true in
+  let n_long = ref 0 in
+  let last_ext = ref None in
+  let ext_samples = ref 0 in
+  (* Ignore any samples arising from spawn_traced_domains *)
+  let should_ignore_backtrace (bt : Memtrace.Trace.Location_code.t array) =
+    bt
+    |> Array.exists (fun loc ->
+      Memtrace.Trace.Reader.lookup_location_code r loc
+      |> List.exists (fun (loc : Memtrace.Trace.Location.t) ->
+        String.ends_with loc.defname ~suffix:"spawn_traced_domain"))
+  in
+  let ignored_ids = Memtrace.Trace.Obj_id.Tbl.create 10 in
+  Memtrace.Trace.Reader.iter r (fun _ ev ->
+    match ev with
+    | Alloc info
+      when should_ignore_backtrace
+             (Array.sub info.backtrace_buffer 0 info.backtrace_length) ->
+      Memtrace.Trace.Obj_id.Tbl.add ignored_ids info.obj_id ()
+    | (Promote (id, _) | Collect (id, _))
+      when Memtrace.Trace.Obj_id.Tbl.mem ignored_ids id -> ()
+    | Alloc info when !first ->
+      first := false;
+      assert (info.length = 4242);
+      ()
+    | Alloc info when info.length = 1000 ->
+      (* backtraces should be truncated *)
+      assert (info.backtrace_length > 3500 && info.backtrace_length < 4000);
+      incr n_long
+    | Alloc info when info.length = 7 ->
+      last_ext := Some info.obj_id;
+      ext_samples := !ext_samples + info.nsamples;
+      validate_ext_alloc_backtrace r info.backtrace_buffer info.backtrace_length
+    | Collect (id, _) ->
+      assert (!last_ext = Some id);
+      last_ext := None
+    | e ->
+      failwith
+        ("unexpected "
+         ^ Memtrace.Trace.Event.to_string (Memtrace.Trace.Reader.lookup_location_code r) e
+        ));
+  Memtrace.Trace.Reader.close r;
+  Unix.unlink filename;
+  assert (650 <= !ext_samples && !ext_samples < 750);
+  assert (not !first);
+  assert (!n_long = 20)
+;;
+
+let () =
+  go ();
+  go ()
+;;

trace_ocamlopt/README.md

···
+# memtrace support for `ocamlopt`
+
+The `ocamlopt.exe` program in this directory is a version of
+`ocamlopt` that supports tracing with memtrace.
+
+Use the environment variable `MEMTRACE` to specify a trace file
+location. If desire, the sampling rate can be adjusted with
+`MEMTRACE_RATE`.

trace_ocamlopt/ocamlopt.ml

···
+let () =
+  Memtrace.trace_if_requested ();
+  exit (Optmaindriver.main Sys.argv Format.err_formatter)
+;;