doc

a basic ambient span provider.

.github/workflows/format.yml

@@ -0,0 +1,28 @@
+name: format
+
+on:
+  pull_request:
+  push:
+    branches:
+      - main
+
+jobs:
+  format:
+    name: format
+    strategy:
+      matrix:
+        ocaml-compiler:
+            - '5.3'
+    runs-on: 'ubuntu-latest'
+    steps:
+      - uses: actions/checkout@main
+      - name: Use OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+          dune-cache: true
+          allow-prerelease-opam: true
+
+      - run: opam install ocamlformat.0.27.0
+      - run: opam exec -- make format-check
+

.github/workflows/gh-pages.yml

@@ -0,0 +1,38 @@
+name: github pages
+
+on:
+  push:
+    branches:
+      - main # Set a branch name to trigger deployment
+
+jobs:
+  deploy:
+    name: Deploy doc
+    runs-on: ubuntu-latest
+    permissions:
+      contents: write
+    steps:
+      - uses: actions/checkout@main
+
+      - name: Use OCaml
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: '5.1.x'
+          allow-prerelease-opam: true
+          dune-cache: true
+
+      - run: opam pin odoc 3.1.0 -y -n
+        # crash with 2.4, see https://github.com/ocaml/odoc/issues/1066
+      - name: Deps
+        run: opam install odig thread-local-storage trace trace-tef trace-fuchsia ppx_trace
+
+      - name: Build
+        run: opam exec -- odig odoc --cache-dir=_doc/ trace trace-tef trace-fuchsia ppx_trace
+
+      - name: Deploy
+        uses: peaceiris/actions-gh-pages@v3
+        with:
+          github_token: ${{ secrets.GITHUB_TOKEN }}
+          publish_dir: ./_doc/html
+          destination_dir: .
+          enable_jekyll: false

.github/workflows/main.yml

@@ -19,20 +19,42 @@ jobs:
         ocaml-compiler:
             - '4.08.x'
             - '4.14.x'
-            - '5.0.x'
+            - '5.3.x'
 
     runs-on: ${{ matrix.os }}
     steps:
       - uses: actions/checkout@main
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
-        uses: ocaml/setup-ocaml@v2
+        uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           dune-cache: true
+          allow-prerelease-opam: true
 
-      - run: opam install -t trace trace-tef --deps-only
-      - run: opam exec -- dune build '@install' -p trace,trace-tef
+      # check that trace compiles with no optional deps
+      - run: opam install -t trace --deps-only
+      - run: opam exec -- dune build '@install' -p trace
+
+      # install all packages
+      - run: opam install -t trace trace-tef trace-fuchsia --deps-only
+      - run: opam install ppx_trace --deps-only # no tests
+        if: matrix.ocaml-compiler != '4.08.x'
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
+      - run: opam exec -- dune build '@install' -p ppx_trace
+        if: matrix.ocaml-compiler != '4.08.x'
       - run: opam exec -- dune runtest -p trace
       - run: opam install trace
-      - run: opam exec -- dune runtest -p trace-tef
+      - run: opam exec -- dune runtest -p trace-tef,trace-fuchsia
+
+      # with depopts
+      - run: opam install hmap thread-local-storage
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
+
+      - run: opam install picos_aux
+        if: matrix.ocaml-compiler != '4.08.x' && matrix.ocaml-compiler != '4.12.x'
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
+        if: matrix.ocaml-compiler != '4.08.x' && matrix.ocaml-compiler != '4.12.x'
+
+      - run: opam install mtime
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
 

.gitignore

@@ -1,3 +1,7 @@
 _opam
 _build
 *.json
+*.exe
+perf.*
+*.fxt
+*.tmp

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.27.0
 profile=conventional
 margin=80
 if-then-else=k-r

CHANGES.md

@@ -1,3 +1,88 @@
+# 0.12
+
+- use `current_span` when entering spans or sending messages
+- add `Trace.Ambient_span_provider.t` concept, to track the current span.
+    It is not part of the collector and is optional.
+- add `trace.thread-local-storage` optional library that implements the `Ambient_span_provider.t`
+- add a runtime events collector, + test, in `trace-runtime-events`
+- add `{thread,process}_sort_index` extension + TEF support
+
+# 0.11
+
+- entire rework of the collector, now lighter, and using an open sum type
+    for `span`. No global state is required anymore.
+- add `enabled` to the collector
+- extensible `metric`; pass level around in collector
+- remove unused deps on hmap, thread-local-storage
+- add `Trace.with_setup_collector`
+- add `trace.debug` to find what spans were not closed on exit
+- remove dead code and `on_tracing_error`
+- remove subscriber entirely
+- core: remove `current_span` from collector
+- update deps to ppxlib=0.37~
+- breaking: use poly variants for `user_data/span_flavor`
+- use `at_exit` in `trace_tef` and `tldrs`
+- fix fuchsia: bound check
+
+# 0.10
+
+- breaking: manual spans now take a `explicit_span_ctx` as parent, that
+    can potentially be transmitted across processes/machines. It also
+    is intended to be more compatible with OTEL.
+- breaking `trace.subscriber`: timestamps are `int64`ns now, not floats
+- breaking `trace`: pass a `string` trace_id in manual spans, which helps
+    for backends such as opentelemetry. It's also useful for extensions.
+
+- refactor `trace-fuchsia`: full revamp of the library, modularized, using subscriber API
+- refactor `trace-tef`: split into exporter,writer,subscriber, using subscriber API
+- feat: add `trace.event`, useful for background threads
+- feat `trace.subscriber`: add `Span_tbl`, and a depopt on picos_aux
+- feat `trace.subscriber`: tee a whole array at once
+- feat tef-tldrs: use EMIT_TEF_AT_EXIT
+- feat `trace.subscriber`: depopt on unix for timestamps
+- refactor `trace-tef`: depopt on unix for TEF timestamps
+
+# 0.9.1
+
+
+- fix: upper bound on ppxlib
+- feat trace-tef: print names of non-closed spans upon exit
+- fix: block signals in background threads
+
+# 0.9
+
+- add an extensible sum type, so users can implement custom events. For example
+    an OTEL collector can provide custom events to link two spans to one another.
+
+# 0.8
+
+- add `trace.subscriber` instead of a separate library
+- add `trace-tef.tldrs`, to trace multiple processes easily (with external rust daemon)
+
+- breaking: `trace-tef`: use `mtime.now`, not a counter, for multiproc
+- `trace-fuchsia`: require thread-local-storage 0.2
+
+# 0.7
+
+- feat: add levels to `Trace_core`. Levels are similar to `logs` levels, to help control verbosity.
+- add hmap as a depopt (#28)
+
+- fix: truncate large strings in fuchsia
+
+# 0.6
+
+- add `ppx_trace` for easier instrumentation.
+  * `let%trace span = "foo" in …` will enter a scope `span` named "foo"
+  * `let%trace () = "foo" in …` will enter a scope named "foo" with a hidden name
+- add `trace-fuchsia` backend, which produces traces in the binary format
+    of [fuchsia](https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format).
+    These traces are reasonably efficient to produce (~60ns per span on my machines)
+    and reasonably compact on disk, at least compared to the TEF backend.
+
+# 0.5
+
+- perf: reduce overhead in trace-tef
+- perf: add Mpsc_queue, adapted from picos, to trace-tef
 
 # 0.4
 

Makefile

@@ -8,10 +8,18 @@ clean:
 
 test:
 	@dune runtest $(DUNE_OPTS)
+test-autopromote:
+	@dune runtest $(DUNE_OPTS) --auto-promote
 
 doc:
 	@dune build $(DUNE_OPTS) @doc
 
+format:
+	@dune build @fmt --auto-promote
+
+format-check:
+	@dune build @fmt --ignore-promoted-rules
+
 WATCH?= @install @runtest
 watch:
 	dune build $(DUNE_OPTS) -w $(WATCH)

README.md

@@ -1,19 +1,20 @@
 
 # Trace
 
-[![Build and Test](https://github.com/c-cube/ocaml-trace/actions/workflows/main.yml/badge.svg)](https://github.com/c-cube/ocaml-trace/actions/workflows/main.yml)
+[![Build and Test](https://github.com/ocaml-tracing/ocaml-trace/actions/workflows/main.yml/badge.svg)](https://github.com/ocaml-tracing/ocaml-trace/actions/workflows/main.yml)
 
 This small library provides basic types that can be used to instrument
 a library or application, either by hand or via a ppx.
 
-### Features
+## Features
 
 - [x] spans
 - [x] messages
 - [x] counters
 - [ ] other metrics?
+- [x] ppx to help instrumentation
 
-### Usage
+## Usage
 
 To instrument your code, you can simply add `trace` to your dune/opam files, and then
 write code like such:
@@ -74,16 +75,94 @@ Opening it in https://ui.perfetto.dev we get something like this:
 
 ![screenshot of perfetto UI](media/ui.png)
 
-### Backends
+## ppx_trace
+
+On OCaml >= 4.12, and with `ppxlib` installed, you can install `ppx_trace`.
+This is a preprocessor that will rewrite like so:
+
+```ocaml
+let%trace f x y z =
+  do_sth x;
+  do_sth y;
+  begin
+    let%trace () = "sub-span" in
+    do_sth z
+  end
+```
+
+This more or less corresponds to:
+
+```ocaml
+let f x y z =
+  let _trace_span = Trace_core.enter_span ~__FILE__ ~__LINE__ "Foo.f" in
+  match
+    do_sth x;
+    do_sth y;
+    begin
+      let _trace_span = Trace_core.enter_span ~__FILE__ ~__LINE__ "sub-span" in
+      match do_sth z with
+      | res ->
+        Trace_core.exit_span _trace_span;
+        res
+      | exception e ->
+        Trace_core.exit_span _trace_span
+        raise e
+    end;
+  with
+  | res ->
+    Trace_core.exit_span _trace_span
+    res
+  | exception e ->
+    Trace_core.exit_span _trace_span
+    raise e
+```
+
+Alternatively, a name can be provided for the span, which is useful if you want
+to access it and use functions like `Trace.add_data_to_span`:
+
+
+```ocaml
+let%trace f x y z =
+  do_sth x;
+  do_sth y;
+  begin
+    let%trace _sp = "sub-span" in
+    do_sth z;
+    Trace.add_data_to_span _sp ["x", `Int 42]
+  end
+```
+
+### Dune configuration
+
+In your `library` or `executable` stanza, add: `(preprocess (pps ppx_trace))`.
+The dependency on `trace.core` is automatically added. You still need to
+configure a backend to actually do collection.
+
+## Backends (collector implementations)
 
 Concrete tracing or observability formats such as:
 
-- [ ] Fuchsia (see [tracing](https://github.com/janestreet/tracing))
+- [x] Fuchsia (see [the spec](https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format) and [tracing](https://github.com/janestreet/tracing).
+        Can be opened in https://ui.perfetto.dev)
 - Catapult
-  * [x] light bindings here with `trace-tef`
-  * [ ] richer bindings with [ocaml-catapult](https://github.com/imandra-ai/catapult),
-        with multi-process backends, etc.
-- [x] Tracy (see [ocaml-tracy](https://github.com/imandra-ai/ocaml-tracy), more specifically `tracy-client.trace`)
-- [x] Opentelemetry (see [ocaml-opentelemetry](https://github.com/imandra-ai/ocaml-opentelemetry/), in `opentelemetry.trace`)
+  * [x] light bindings here with `trace-tef`.
+        (Can be opened in https://ui.perfetto.dev)
+  * [x] backend for [tldrs](https://github.com/imandra-ai/tldrs), a
+        small rust daemon that aggregates TEF traces from multiple processes/clients
+        into a single `.jsonl` file
+  * [x] [tldrs](https://github.com/imandra-ai/tldrs), to collect TEF traces from multiple processes in a clean way.
+        This requires the rust `tldrs` program to be in path.
+  * ~~[ ] richer bindings with [ocaml-catapult](https://github.com/imandra-ai/catapult),
+        with multi-process backends, etc.~~ (subsumed by tldrs)
+- [x] Tracy (see [ocaml-tracy](https://github.com/ocaml-tracing/ocaml-tracy), more specifically `tracy-client.trace`)
+- [x] Opentelemetry (see [ocaml-opentelemetry](https://github.com/ocaml-tracing/ocaml-opentelemetry/), in `opentelemetry.trace`)
 - [ ] landmarks?
+- [ ] native perfetto backend
+- [ ] OCaml runtime events
 - [ ] Logs (only for messages, obviously)
+
+Collectors are now more composable and replace `trace.subscribers`.
+
+## Subscribers
+
+Not a thing anymore.

bench/bench_fuchsia_write.ml

@@ -0,0 +1,67 @@
+open Trace_fuchsia
+open Trace_fuchsia.Writer
+module B = Benchmark
+
+let pf = Printf.printf
+
+let encode_1000_span (bufs : Buf_chain.t) () =
+  for _i = 1 to 1000 do
+    Event.Duration_complete.encode bufs ~name:"span" ~t_ref:(Thread_ref.Ref 5)
+      ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] ()
+  done;
+  Buf_chain.ready_all_non_empty bufs;
+  Buf_chain.pop_ready bufs ~f:ignore;
+  ()
+
+let encode_300_span (bufs : Buf_chain.t) () =
+  for _i = 1 to 100 do
+    Event.Duration_complete.encode bufs ~name:"outer" ~t_ref:(Thread_ref.Ref 5)
+      ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] ();
+    Event.Duration_complete.encode bufs ~name:"inner" ~t_ref:(Thread_ref.Ref 5)
+      ~time_ns:180_000L ~end_time_ns:4_500_000L ~args:[] ();
+    Event.Instant.encode bufs ~name:"hello" ~time_ns:1_234_567L
+      ~t_ref:(Thread_ref.Ref 5)
+      ~args:[ "x", A_int 42 ]
+      ()
+  done;
+  Buf_chain.ready_all_non_empty bufs;
+  Buf_chain.pop_ready bufs ~f:ignore;
+  ()
+
+let time_per_iter_ns n_per_iter (samples : B.t list) : float =
+  let n_iters = ref 0L in
+  let time = ref 0. in
+  List.iter
+    (fun (s : B.t) ->
+      n_iters := Int64.add !n_iters s.iters;
+      time := !time +. s.stime +. s.utime)
+    samples;
+  !time *. 1e9 /. (Int64.to_float !n_iters *. float n_per_iter)
+
+let () =
+  let buf_pool = Buf_pool.create () in
+  let bufs = Buf_chain.create ~sharded:false ~buf_pool () in
+
+  let samples =
+    B.throughput1 4 ~name:"encode_1000_span" (encode_1000_span bufs) ()
+  in
+  B.print_gc samples;
+
+  let [ (_, samples) ] = samples [@@warning "-8"] in
+  let iter_per_ns = time_per_iter_ns 1000 samples in
+  pf "%.3f ns/iter\n" iter_per_ns;
+
+  ()
+
+let () =
+  let buf_pool = Buf_pool.create () in
+  let bufs = Buf_chain.create ~sharded:false ~buf_pool () in
+  let samples =
+    B.throughput1 4 ~name:"encode_300_span" (encode_300_span bufs) ()
+  in
+  B.print_gc samples;
+
+  let [ (_, samples) ] = samples [@@warning "-8"] in
+  let iter_per_ns = time_per_iter_ns 300 samples in
+  pf "%.3f ns/iter\n" iter_per_ns;
+  ()

bench/dune

@@ -0,0 +1,23 @@
+(executable
+ (name trace1)
+ (modules trace1)
+ (libraries trace.core trace-tef))
+
+(executable
+ (name trace_fx)
+ (modules trace_fx)
+ (preprocess
+  (pps ppx_trace))
+ (libraries trace.core trace-fuchsia))
+
+(executable
+ (name trace_tldrs)
+ (modules trace_tldrs)
+ (preprocess
+  (pps ppx_trace))
+ (libraries trace.core trace-tef.tldrs))
+
+(executable
+ (name bench_fuchsia_write)
+ (modules bench_fuchsia_write)
+ (libraries benchmark trace-fuchsia))

bench/trace1.ml

@@ -0,0 +1,40 @@
+module Trace = Trace_core
+
+let ( let@ ) = ( @@ )
+
+let work ~n () : unit =
+  let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "work" in
+  Trace.add_data_to_span _sp [ "n", `Int n ];
+
+  for _i = 1 to n do
+    let@ _sp =
+      Trace.with_span ~__FILE__ ~__LINE__ "outer" ~data:(fun () ->
+          [ "i", `Int _i ])
+    in
+    for _k = 1 to 10 do
+      let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "inner" in
+      ()
+    done
+    (* Thread.delay 1e-6 *)
+  done
+
+let main ~n ~j () : unit =
+  let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "main" in
+  let domains = Array.init j (fun _ -> Domain.spawn (fun () -> work ~n ())) in
+  Array.iter Domain.join domains
+
+let () =
+  let@ () = Trace_tef.with_setup () in
+
+  let n = ref 10_000 in
+  let j = ref 4 in
+
+  let args =
+    [
+      "-n", Arg.Set_int n, " number of iterations";
+      "-j", Arg.Set_int j, " set number of workers";
+    ]
+    |> Arg.align
+  in
+  Arg.parse args ignore "bench1";
+  main ~n:!n ~j:!j ()

bench/trace_fx.ml

@@ -0,0 +1,50 @@
+module Trace = Trace_core
+
+let ( let@ ) = ( @@ )
+
+let work ~dom_idx ~n () : unit =
+  Trace_core.set_thread_name (Printf.sprintf "worker%d" dom_idx);
+  for _i = 1 to n do
+    let%trace _sp = "outer" in
+    Trace_core.add_data_to_span _sp [ "i", `Int _i ];
+    for _k = 1 to 10 do
+      let%trace _sp = "inner" in
+      ()
+    done;
+
+    (* Thread.delay 1e-6 *)
+    if dom_idx = 0 && _i mod 4096 = 0 then (
+      Trace_core.message "gc stats";
+      let stat = Gc.quick_stat () in
+      Trace_core.counter_float "gc.minor" (8. *. stat.minor_words);
+      Trace_core.counter_float "gc.major" (8. *. stat.major_words)
+    )
+  done
+
+let main ~n ~j () : unit =
+  let domains =
+    Array.init j (fun dom_idx -> Domain.spawn (fun () -> work ~dom_idx ~n ()))
+  in
+
+  let%trace () = "join" in
+  Array.iter Domain.join domains
+
+let () =
+  let@ () = Trace_fuchsia.with_setup () in
+  Trace_core.set_process_name "trace_fxt1";
+  Trace_core.set_thread_name "main";
+
+  let%trace () = "main" in
+
+  let n = ref 10_000 in
+  let j = ref 4 in
+
+  let args =
+    [
+      "-n", Arg.Set_int n, " number of iterations";
+      "-j", Arg.Set_int j, " set number of workers";
+    ]
+    |> Arg.align
+  in
+  Arg.parse args ignore "bench1";
+  main ~n:!n ~j:!j ()

bench/trace_tldrs.ml

@@ -0,0 +1,61 @@
+module Trace = Trace_core
+
+let ( let@ ) = ( @@ )
+
+let work ~n () : unit =
+  for _i = 1 to n do
+    let@ _sp =
+      Trace.with_span ~__FILE__ ~__LINE__ "outer" ~data:(fun () ->
+          [ "i", `Int _i ])
+    in
+    for _k = 1 to 10 do
+      let@ _sp =
+        Trace.with_span ~__FILE__ ~__LINE__ "inner" ~data:(fun () ->
+            (* add some big data sometimes *)
+            if _i mod 100 = 0 && _k = 9 then
+              [ "s", `String (String.make 5000 '-') ]
+            else
+              [])
+      in
+      ()
+    done;
+
+    if _i mod 1000 = 0 then Thread.yield ()
+    (* Thread.delay 1e-6 *)
+  done
+
+let main ~n ~j ~child () : unit =
+  if child then
+    work ~n ()
+  else
+    let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "parent" in
+    let cmd =
+      Printf.sprintf "%s --child -n=%d" (Filename.quote Sys.argv.(0)) n
+    in
+    let procs = Array.init j (fun _ -> Unix.open_process_in cmd) in
+    Array.iteri
+      (fun idx _ic ->
+        let@ _sp =
+          Trace.with_span ~__FILE__ ~__LINE__ "wait.child" ~data:(fun () ->
+              [ "i", `Int idx ])
+        in
+        ignore @@ Unix.close_process_in _ic)
+      procs
+
+let () =
+  let@ () = Trace_tef_tldrs.with_setup () in
+
+  let n = ref 10_000 in
+  let j = ref 4 in
+  let child = ref false in
+
+  let args =
+    [
+      "-n", Arg.Set_int n, " number of iterations";
+      "-j", Arg.Set_int j, " set number of workers";
+      "--child", Arg.Set child, " act as child process";
+    ]
+    |> Arg.align
+  in
+  Arg.parse args ignore "bench1";
+  main ~n:!n ~j:!j ~child:!child ()

bench1.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+DUNE_OPTS="--profile=release --display=quiet"
+exec dune exec $DUNE_OPTS bench/trace1.exe -- $@

bench_fx.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+DUNE_OPTS="--profile=release --display=quiet"
+exec dune exec $DUNE_OPTS bench/trace_fx.exe -- $@

bench_tldrs.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+DUNE_OPTS="--profile=release --display=quiet"
+exec dune exec $DUNE_OPTS bench/trace_tldrs.exe -- $@

dune

@@ -1,4 +1,9 @@
-
 (env
-  (_ (flags :standard -strict-sequence -warn-error -a+8+26+27 -w +a-4-40-70)))
-
+ (_
+  (flags
+   :standard
+   -strict-sequence
+   -warn-error
+   -a+8+26+27
+   -w
+   +a-4-40-42-44-70)))

dune-project

@@ -1,36 +1,111 @@
 (lang dune 2.9)
 
 (name trace)
+
 (generate_opam_files true)
-(version 0.4)
+
+(version 0.12)
 
 (source
- (github c-cube/ocaml-trace))
+ (github ocaml-tracing/ocaml-trace))
+
 (authors "Simon Cruanes")
+
 (maintainers "Simon Cruanes")
+
 (license MIT)
 
 ;(documentation https://url/to/documentation)
 
 (package
  (name trace)
- (synopsis "A stub for tracing/observability, agnostic in how data is collected")
+ (synopsis
+  "A lightweight stub for tracing/observability, agnostic in how data is collected")
+ (description
+  "ocaml-trace can be used to instrument libraries and programs with low overhead.\n\n              It doesn't do any IO unless a collector is plugged in, which only\n              the final executable should do.")
  (depends
-   (ocaml (>= 4.08))
-   dune)
+  (ocaml
+   (>= 4.08))
+  dune)
+ (depopts
+  unix
+  (thread-local-storage (>= 0.2))
+  (mtime
+   (>= 2.0)))
  (tags
   (trace tracing observability profiling)))
 
 (package
- (name trace-tef)
- (synopsis "A simple backend for trace, emitting Catapult/TEF JSON into a file")
+ (name ppx_trace)
+ (synopsis "A ppx-based preprocessor for trace")
  (depends
-   (ocaml (>= 4.08))
-   (trace (= :version))
-   (mtime (>= 2.0))
-   base-unix
-   dune)
+  (ocaml
+   (>= 4.12))
+  ; we use __FUNCTION__
+  (ppxlib
+   (and
+    (>= 0.37)
+    (< 0.38)))
+  (trace
+   (= :version))
+  (trace-tef
+   (and
+    (= :version)
+    :with-test))
+  dune)
+ (depopts
+  (mtime
+   (>= 2.0)))
  (tags
-  (trace tracing catapult)))
+  (trace ppx)))
+
+(package
+ (name trace-tef)
+ (synopsis
+  "A simple backend for trace, emitting Catapult/TEF JSON into a file")
+ (depends
+  (ocaml
+   (>= 4.08))
+  (trace
+   (= :version))
+  (mtime
+   (>= 2.0))
+  base-unix
+  dune)
+ (tags
+  (trace tracing catapult TEF chrome-format chrome-trace json)))
+
+(package
+ (name trace-fuchsia)
+ (synopsis
+  "A high-performance backend for trace, emitting a Fuchsia trace into a file")
+ (depends
+  (ocaml
+   (>= 4.08))
+  (trace
+   (= :version))
+  (mtime
+   (>= 2.0))
+  base-bigarray
+  base-unix
+  dune)
+ (tags
+  (trace tracing fuchsia)))
+
+(package
+ (name trace-runtime-events)
+ (synopsis
+  "A simple collector relying on runtime-events for OCaml 5. Some assembly required.")
+ (depends
+  (ocaml
+   (>= 5.1))
+  (trace
+   (= :version))
+  (ppx_trace (and (= :version) :with-test))
+  base-bigarray
+  base-unix
+  dune)
+ (tags
+  (trace tracing trace runtime-events)))
 
 ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

ppx_trace.opam

@@ -0,0 +1,38 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.12"
+synopsis: "A ppx-based preprocessor for trace"
+maintainer: ["Simon Cruanes"]
+authors: ["Simon Cruanes"]
+license: "MIT"
+tags: ["trace" "ppx"]
+homepage: "https://github.com/ocaml-tracing/ocaml-trace"
+bug-reports: "https://github.com/ocaml-tracing/ocaml-trace/issues"
+depends: [
+  "ocaml" {>= "4.12"}
+  "ppxlib" {>= "0.37" & < "0.38"}
+  "trace" {= version}
+  "trace-tef" {= version & with-test}
+  "dune" {>= "2.9"}
+  "odoc" {with-doc}
+]
+depopts: [
+  "mtime" {>= "2.0"}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "--promote-install-files=false"
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+  ["dune" "install" "-p" name "--create-install-files" name]
+]
+dev-repo: "git+https://github.com/ocaml-tracing/ocaml-trace.git"

src/core/ambient_span_provider.ml

@@ -0,0 +1,20 @@
+(** Access/set the current span from some ambient context.
+    @since 0.12 *)
+
+open Types
+
+module Callbacks = struct
+  type 'st t = {
+    with_current_span_set_to: 'a. 'st -> span -> (span -> 'a) -> 'a;
+        (** [with_current_span_set_to span f] sets the span as current span,
+            enters [f span], and restores the previous current span if any *)
+    get_current_span: 'st -> span option;
+        (** Access the current span from some ambient scope. This is only
+            supported for collectors that provide a [current_span_wrap] field.
+        *)
+  }
+end
+
+type t =
+  | ASP_none
+  | ASP_some : 'st * 'st Callbacks.t -> t

src/core/collector.ml

@@ -1,82 +1,93 @@
 (** A global collector.
 
-    The collector, if present, is responsible for collecting messages
-    and spans, and storing them, recording them, forward them, or
-    offering them to other services and processes.
-*)
+    The collector, if present, is responsible for collecting messages and spans,
+    and storing them, recording them, forward them, or offering them to other
+    services and processes. *)
 
 open Types
 
-let dummy_span : span = Int64.min_int
+type span += Span_dummy
 
-let dummy_explicit_span : explicit_span =
-  { span = dummy_span; meta = Meta_map.empty }
+(** A fake span that never emits data. All collectors should handle this span by
+    doing nothing. *)
+let dummy_span : span = Span_dummy
 
-(** Signature for a collector.
+module Callbacks = struct
+  type 'st t = {
+    enter_span:
+      'st ->
+      __FUNCTION__:string option ->
+      __FILE__:string ->
+      __LINE__:int ->
+      level:Level.t ->
+      params:extension_parameter list ->
+      data:(string * user_data) list ->
+      parent:parent ->
+      string ->
+      span;
+        (** Enter a span *)
+    exit_span: 'st -> span -> unit;
+        (** Exit a span. Must be called exactly once per span. Additional
+            constraints on nesting, threads, etc. vary per collector. *)
+    add_data_to_span: 'st -> span -> (string * user_data) list -> unit;
+    enabled: 'st -> Level.t -> bool;
+        (** Is the collector accepting spans/messages/metrics with this level?
+        *)
+    message:
+      'st ->
+      level:Level.t ->
+      params:extension_parameter list ->
+      data:(string * user_data) list ->
+      span:span option ->
+      string ->
+      unit;
+        (** Emit a message or log *)
+    metric:
+      'st ->
+      level:Level.t ->
+      params:extension_parameter list ->
+      data:(string * user_data) list ->
+      string ->
+      metric ->
+      unit;
+        (** Metric . *)
+    extension: 'st -> level:Level.t -> extension_event -> unit;
+        (** Collector-specific extension. It now has a level as well. *)
+    init: 'st -> unit;  (** Called on initialization *)
+    shutdown: 'st -> unit;
+        (** Shutdown collector, possibly waiting for it to finish sending data.
+        *)
+  }
+  (** Callbacks taking a state ['st] *)
+
+  (** Helper to create backends in a future-proof way *)
+  let make ?(enabled = fun _ _ -> true) ~enter_span ~exit_span ~add_data_to_span
+      ~message ~metric ?(extension = fun _ ~level:_ _ -> ()) ?(init = ignore)
+      ?(shutdown = ignore) () : _ t =
+    {
+      enter_span;
+      exit_span;
+      add_data_to_span;
+      enabled;
+      message;
+      metric;
+      extension;
+      init;
+      shutdown;
+    }
+end
+
+(** Definition of a collector.
 
     This is only relevant to implementors of tracing backends; to instrument
-    your code you only need to look at the {!Trace} module. *)
-module type S = sig
-  val with_span :
-    __FUNCTION__:string option ->
-    __FILE__:string ->
-    __LINE__:int ->
-    data:(string * user_data) list ->
-    string ->
-    (span -> 'a) ->
-    'a
-  (** Run the function in a new span.
+    your code you only need to look at the {!Trace} module.
 
-      This replaces the previous [enter_span] and [exit_span] which were too flexible
-      to be efficient to implement in async contexts.
-     @since 0.3 *)
+    The definition changed since 0.11 to a record of callbacks + a state *)
+type t =
+  | C_none  (** No collector. *)
+  | C_some : 'st * 'st Callbacks.t -> t
+      (** Collector with a state and some callbacks. *)
 
-  val enter_manual_span :
-    parent:explicit_span option ->
-    flavor:[ `Sync | `Async ] option ->
-    __FUNCTION__:string option ->
-    __FILE__:string ->
-    __LINE__:int ->
-    data:(string * user_data) list ->
-    string ->
-    explicit_span
-  (** Enter an explicit span. Surrounding scope, if any, is provided by [parent],
-      and this function can store as much metadata as it wants in the hmap
-      in the {!explicit_span}'s [meta] field.
-
-      This means that the collector doesn't need to implement contextual
-      storage mapping {!span} to scopes, metadata, etc. on its side;
-      everything can be transmitted in the {!explicit_span}.
-      @since 0.3 *)
-
-  val exit_manual_span : explicit_span -> unit
-  (** Exit an explicit span.
-      @since 0.3 *)
-
-  val add_data_to_span : span -> (string * user_data) list -> unit
-  (** @since Adds data to the current span.
-      NEXT_RELEASE *)
-
-  val add_data_to_manual_span :
-    explicit_span -> (string * user_data) list -> unit
-  (** Adds data to the given span.
-      @since NEXT_RELEASE *)
-
-  val message : ?span:span -> data:(string * user_data) list -> string -> unit
-  (** Emit a message with associated metadata. *)
-
-  val name_thread : string -> unit
-  (** Give a name to the current thread. *)
-
-  val name_process : string -> unit
-  (** Give a name to the current process. *)
-
-  val counter_int : data:(string * user_data) list -> string -> int -> unit
-  (** Integer counter. *)
-
-  val counter_float : data:(string * user_data) list -> string -> float -> unit
-  (** Float counter. *)
-
-  val shutdown : unit -> unit
-  (** Shutdown collector, possibly waiting for it to finish sending data. *)
-end
+let[@inline] is_some = function
+  | C_none -> false
+  | C_some _ -> true

src/core/core_ext.ml

@@ -0,0 +1,24 @@
+(** A few core extensions.
+
+    @since 0.11 *)
+
+open Types
+
+(** Additional extensions *)
+type extension_event +=
+  | Extension_set_thread_name of string
+  | Extension_set_process_name of string
+  | Extension_set_thread_sort_index of int
+        (** https://github.com/google/perfetto/pull/3273/changes#diff-ecec88c33adb7591ee6aa88e29b62ad52ef443611cba5e0f0ecac9b5725afdba
+        *)
+  | Extension_set_process_sort_index of int
+
+(** Specialized parameters *)
+type extension_parameter +=
+  | Extension_span_flavor of [ `Sync | `Async ]
+        (** Tell the backend if this is a sync or async span *)
+
+type metric +=
+  | Metric_int of int  (** Int counter or gauge, supported by tracy, TEF, etc *)
+  | Metric_float of float
+        (** Float counter or gauge, supported by tracy, TEF, etc *)

src/core/dune

@@ -1,12 +1,11 @@
-
 (library
  (name trace_core)
  (public_name trace.core)
- (synopsis "Lightweight stub for tracing")
-)
+ (synopsis "Lightweight stub for tracing"))
 
 (rule
-  (targets atomic_.ml)
-  (action
-    (with-stdout-to %{targets}
-     (run ./gen/gen.exe --ocaml %{ocaml_version} --atomic))))
+ (targets atomic_.ml)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./gen/gen.exe --ocaml %{ocaml_version} --atomic))))

src/core/gen/dune

@@ -1,3 +1,2 @@
-
 (executable
-  (name gen))
+ (name gen))

src/core/level.ml

@@ -0,0 +1,33 @@
+(** Tracing levels.
+
+    This is similar to log levels in, say, [Logs]. In a thoroughly instrumented
+    program, there will be a {b lot} of spans, and enabling them all in
+    production might slow down the application or overwhelm the tracing system;
+    yet they might be useful in debug situations.
+
+    @since 0.7 *)
+
+(** Level of tracing. These levels are in increasing order, i.e if level
+    [Debug1] is enabled, everything below it (Error, Warning, Info, etc.) are
+    also enabled.
+    @since 0.7 *)
+type t =
+  | Error  (** Only errors *)
+  | Warning  (** Warnings *)
+  | Info
+  | Debug1  (** Least verbose debugging level *)
+  | Debug2  (** Intermediate verbosity debugging level *)
+  | Debug3  (** Maximum verbosity debugging level *)
+  | Trace  (** Enable everything (default level) *)
+
+(** @since 0.7 *)
+let to_string : t -> string = function
+  | Error -> "error"
+  | Warning -> "warning"
+  | Info -> "info"
+  | Debug1 -> "debug1"
+  | Debug2 -> "debug2"
+  | Debug3 -> "debug3"
+  | Trace -> "trace"
+
+let[@inline] leq (a : t) (b : t) : bool = a <= b

src/core/meta_map.ml

@@ -1,83 +0,0 @@
-module type KEY_IMPL = sig
-  type t
-
-  exception Store of t
-
-  val id : int
-end
-
-module Key = struct
-  type 'a t = (module KEY_IMPL with type t = 'a)
-
-  let _n = ref 0
-
-  let create (type k) () =
-    incr _n;
-    let id = !_n in
-    let module K = struct
-      type t = k
-
-      let id = id
-
-      exception Store of k
-    end in
-    (module K : KEY_IMPL with type t = k)
-
-  let id (type k) (module K : KEY_IMPL with type t = k) = K.id
-
-  let equal : type a b. a t -> b t -> bool =
-   fun (module K1) (module K2) -> K1.id = K2.id
-end
-
-type pair = Pair : 'a Key.t * 'a -> pair
-type exn_pair = E_pair : 'a Key.t * exn -> exn_pair
-
-let pair_of_e_pair (E_pair (k, e)) =
-  let module K = (val k) in
-  match e with
-  | K.Store v -> Pair (k, v)
-  | _ -> assert false
-
-module M = Map.Make (struct
-  type t = int
-
-  let compare (i : int) j = Stdlib.compare i j
-end)
-
-type t = exn_pair M.t
-
-let empty = M.empty
-let mem k t = M.mem (Key.id k) t
-
-let find_exn (type a) (k : a Key.t) t : a =
-  let module K = (val k) in
-  let (E_pair (_, e)) = M.find K.id t in
-  match e with
-  | K.Store v -> v
-  | _ -> assert false
-
-let find k t = try Some (find_exn k t) with Not_found -> None
-
-let add_e_pair_ p t =
-  let (E_pair ((module K), _)) = p in
-  M.add K.id p t
-
-let add_pair_ p t =
-  let (Pair (((module K) as k), v)) = p in
-  let p = E_pair (k, K.Store v) in
-  M.add K.id p t
-
-let add (type a) (k : a Key.t) v t =
-  let module K = (val k) in
-  add_e_pair_ (E_pair (k, K.Store v)) t
-
-let remove (type a) (k : a Key.t) t =
-  let module K = (val k) in
-  M.remove K.id t
-
-let cardinal t = M.cardinal t
-let length = cardinal
-let iter f t = M.iter (fun _ p -> f (pair_of_e_pair p)) t
-let to_list t = M.fold (fun _ p l -> pair_of_e_pair p :: l) t []
-let add_list t l = List.fold_right add_pair_ l t
-let of_list l = add_list empty l

src/core/meta_map.mli

@@ -1,37 +0,0 @@
-(** Associative containers with Heterogeneous Values *)
-
-(** Keys with a type witness. *)
-module Key : sig
-  type 'a t
-  (** A key of type ['a t] is used to access the portion of the
-      map or table that associates keys of type ['a] to values. *)
-
-  val create : unit -> 'a t
-  (** Make a new key. This is generative, so calling [create ()] twice with the
-      same return type will produce incompatible keys that cannot see each
-      other's bindings. *)
-
-  val equal : 'a t -> 'a t -> bool
-  (** Compare two keys that have compatible types. *)
-end
-
-type pair = Pair : 'a Key.t * 'a -> pair
-
-type t
-(** Immutable map from {!Key.t} to values *)
-
-val empty : t
-val mem : _ Key.t -> t -> bool
-val add : 'a Key.t -> 'a -> t -> t
-val remove : _ Key.t -> t -> t
-val length : t -> int
-val cardinal : t -> int
-val find : 'a Key.t -> t -> 'a option
-
-val find_exn : 'a Key.t -> t -> 'a
-(** @raise Not_found if the key is not in the table. *)
-
-val iter : (pair -> unit) -> t -> unit
-val add_list : t -> pair list -> t
-val of_list : pair list -> t
-val to_list : t -> pair list

src/core/trace_core.ml

@@ -1,140 +1,225 @@
 include Types
 module A = Atomic_
 module Collector = Collector
-module Meta_map = Meta_map
+module Level = Level
+module Core_ext = Core_ext
+module Ambient_span_provider = Ambient_span_provider
 
-type collector = (module Collector.S)
+type collector = Collector.t
+
+(* ## globals ## *)
 
 (** Global collector. *)
-let collector : collector option A.t = A.make None
+let collector : collector A.t = A.make Collector.C_none
+
+(* default level for spans without a level *)
+let default_level_ = A.make Level.Trace
+let current_level_ = A.make Level.Trace
+
+(** Global provider of span context *)
+let ambient_span_provider : Ambient_span_provider.t A.t =
+  A.make Ambient_span_provider.ASP_none
+
+(* ## implementation ## *)
+
+let[@inline] option_or_ a f =
+  match a with
+  | Some _ -> a
+  | None -> f ()
 
 let data_empty_build_ () = []
+let[@inline] enabled () = Collector.is_some (A.get collector)
+let[@inline] get_default_level () = A.get default_level_
+let[@inline] set_default_level l = A.set default_level_ l
+let[@inline] set_current_level l = A.set current_level_ l
+let[@inline] get_current_level () = A.get current_level_
 
-let[@inline] enabled () =
-  match A.get collector with
-  | None -> false
-  | Some _ -> true
+let[@inline] check_level_ ~level st (cbs : _ Collector.Callbacks.t) : bool =
+  Level.leq level (A.get current_level_) && cbs.enabled st level
 
-let with_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
-    ~__LINE__ ?(data = data_empty_build_) name f =
-  let data = data () in
-  C.with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f
+let[@inline] current_span () =
+  match A.get ambient_span_provider with
+  | ASP_none -> None
+  | ASP_some (st, cbs) -> cbs.get_current_span st
 
-let[@inline] with_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f =
-  match A.get collector with
+let[@inline] with_current_span_set_to sp f =
+  match A.get ambient_span_provider with
+  | ASP_none -> f sp
+  | ASP_some (st, cbs) -> cbs.with_current_span_set_to st sp f
+
+let parent_of_span_opt_opt = function
   | None ->
+    (match current_span () with
+    | None -> P_unknown
+    | Some p -> P_some p)
+  | Some None -> P_none
+  | Some (Some p) -> P_some p
+
+let enter_span_st st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ~level ?parent ?(params = []) ?(data = data_empty_build_) name :
+    span =
+  let parent = parent_of_span_opt_opt parent in
+  let data = data () in
+  cbs.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~parent ~params
+    ~data name
+
+let with_span_collector_ st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__
+    ~__FILE__ ~__LINE__ ~level ?parent ?params ?data name f =
+  let sp : span =
+    enter_span_st st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ~level ?parent
+      ?params ?data name
+  in
+  match
+    (* set [sp] as current span before calling [f sp] *)
+    with_current_span_set_to sp f
+  with
+  | res ->
+    cbs.exit_span st sp;
+    res
+  | exception exn ->
+    let bt = Printexc.get_raw_backtrace () in
+    cbs.exit_span st sp;
+    Printexc.raise_with_backtrace exn bt
+
+let[@inline] with_span ?(level = A.get default_level_) ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ?parent ?params ?data name f =
+  match A.get collector with
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
+    with_span_collector_ st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ~level ?parent
+      ?params ?data name f
+  | _ ->
     (* fast path: no collector, no span *)
     f Collector.dummy_span
-  | Some collector ->
-    with_span_collector_ collector ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
-      f
 
-let enter_explicit_span_collector_ (module C : Collector.S) ~parent ~flavor
-    ?__FUNCTION__ ~__FILE__ ~__LINE__ ?(data = data_empty_build_) name :
-    explicit_span =
-  let data = data () in
-  C.enter_manual_span ~parent ~flavor ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data
-    name
-
-let[@inline] enter_manual_sub_span ~parent ?flavor ?__FUNCTION__ ~__FILE__
-    ~__LINE__ ?data name : explicit_span =
+let[@inline] enter_span ?(level = A.get default_level_) ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ?flavor ?parent ?(params = []) ?data name : span =
   match A.get collector with
-  | None -> Collector.dummy_explicit_span
-  | Some coll ->
-    enter_explicit_span_collector_ coll ~parent:(Some parent) ~flavor
-      ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
+    let params =
+      match flavor with
+      | None -> params
+      | Some f -> Core_ext.Extension_span_flavor f :: params
+    in
+    (enter_span_st [@inlined never]) st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__
+      ~level ?parent ~params ?data name
+  | _ -> Collector.dummy_span
 
-let[@inline] enter_manual_toplevel_span ?flavor ?__FUNCTION__ ~__FILE__
-    ~__LINE__ ?data name : explicit_span =
+let[@inline] exit_span sp : unit =
   match A.get collector with
-  | None -> Collector.dummy_explicit_span
-  | Some coll ->
-    enter_explicit_span_collector_ coll ~parent:None ~flavor ?__FUNCTION__
-      ~__FILE__ ~__LINE__ ?data name
-
-let[@inline] exit_manual_span espan : unit =
-  match A.get collector with
-  | None -> ()
-  | Some (module C) -> C.exit_manual_span espan
+  | C_none -> ()
+  | C_some (st, cbs) -> cbs.exit_span st sp
 
 let[@inline] add_data_to_span sp data : unit =
-  if data <> [] then (
+  if sp != Collector.dummy_span && data <> [] then (
     match A.get collector with
-    | None -> ()
-    | Some (module C) -> C.add_data_to_span sp data
+    | C_none -> ()
+    | C_some (st, cbs) -> cbs.add_data_to_span st sp data
   )
 
-let[@inline] add_data_to_manual_span esp data : unit =
-  if data <> [] then (
-    match A.get collector with
-    | None -> ()
-    | Some (module C) -> C.add_data_to_manual_span esp data
-  )
-
-let message_collector_ (module C : Collector.S) ?span
-    ?(data = data_empty_build_) msg : unit =
+let message_collector_ st (cbs : _ Collector.Callbacks.t) ~level ?span
+    ?(params = []) ?(data = data_empty_build_) msg : unit =
   let data = data () in
-  C.message ?span ~data msg
+  let span = option_or_ span current_span in
+  cbs.message st ~level ~span ~params ~data msg
 
-let[@inline] message ?span ?data msg : unit =
+let[@inline] message ?(level = A.get default_level_) ?span ?params ?data msg :
+    unit =
   match A.get collector with
-  | None -> ()
-  | Some coll -> message_collector_ coll ?span ?data msg
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
+    (message_collector_ [@inlined never]) st cbs ~level ?span ?params ?data msg
+  | _ -> ()
 
-let messagef ?span ?data k =
+let messagef ?(level = A.get default_level_) ?span ?params ?data k =
   match A.get collector with
-  | None -> ()
-  | Some (module C) ->
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
     k (fun fmt ->
         Format.kasprintf
-          (fun str ->
-            let data =
-              match data with
-              | None -> []
-              | Some f -> f ()
-            in
-            C.message ?span ~data str)
+          (fun str -> message_collector_ st cbs ~level ?span ?params ?data str)
           fmt)
+  | _ -> ()
 
-let counter_int ?(data = data_empty_build_) name n : unit =
+let metric ?(level = A.get default_level_) ?(params = [])
+    ?(data = data_empty_build_) name m : unit =
   match A.get collector with
-  | None -> ()
-  | Some (module C) ->
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
     let data = data () in
-    C.counter_int ~data name n
+    cbs.metric st ~level ~params ~data name m
+  | _ -> ()
 
-let counter_float ?(data = data_empty_build_) name f : unit =
-  match A.get collector with
-  | None -> ()
-  | Some (module C) ->
-    let data = data () in
-    C.counter_float ~data name f
+let counter_int ?level ?params ?data name n : unit =
+  metric ?level ?params ?data name (Core_ext.Metric_int n)
 
-let set_thread_name name : unit =
-  match A.get collector with
-  | None -> ()
-  | Some (module C) -> C.name_thread name
-
-let set_process_name name : unit =
-  match A.get collector with
-  | None -> ()
-  | Some (module C) -> C.name_process name
+let counter_float ?level ?params ?data name n : unit =
+  metric ?level ?params ?data name (Core_ext.Metric_float n)
 
 let setup_collector c : unit =
   while
     let cur = A.get collector in
     match cur with
-    | Some _ -> invalid_arg "trace: collector already present"
-    | None -> not (A.compare_and_set collector cur (Some c))
+    | C_some _ -> invalid_arg "trace: collector already present"
+    | C_none -> not (A.compare_and_set collector cur c)
   do
     ()
-  done
+  done;
+
+  (* initialize collector *)
+  match c with
+  | C_none -> ()
+  | C_some (st, cb) -> cb.init st
 
 let shutdown () =
-  match A.exchange collector None with
-  | None -> ()
-  | Some (module C) -> C.shutdown ()
+  match A.exchange collector C_none with
+  | C_none -> ()
+  | C_some (st, cbs) -> cbs.shutdown st
+
+let with_setup_collector c f =
+  setup_collector c;
+  Fun.protect ~finally:shutdown f
+
+let set_ambient_context_provider p = A.set ambient_span_provider p
+
+type extension_event = Types.extension_event = ..
+
+let[@inline] extension_event ?(level = A.get default_level_) ev : unit =
+  match A.get collector with
+  | C_some (st, cbs) when check_level_ ~level st cbs ->
+    cbs.extension st ~level ev
+  | _ -> ()
+
+let set_thread_name name : unit =
+  extension_event @@ Core_ext.Extension_set_thread_name name
+
+let set_process_name name : unit =
+  extension_event @@ Core_ext.Extension_set_process_name name
 
 module Internal_ = struct
   module Atomic_ = Atomic_
 end
+
+(* ### deprecated *)
+
+[@@@ocaml.alert "-deprecated"]
+
+let enter_manual_span ~parent ?flavor ?level ?__FUNCTION__ ~__FILE__ ~__LINE__
+    ?data name : explicit_span =
+  let params =
+    match flavor with
+    | None -> []
+    | Some f -> [ Core_ext.Extension_span_flavor f ]
+  in
+  enter_span ~parent ~params ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
+
+let enter_manual_toplevel_span ?flavor ?level ?__FUNCTION__ ~__FILE__ ~__LINE__
+    ?data name : explicit_span =
+  enter_manual_span ~parent:None ?flavor ?level ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ?data name
+
+let enter_manual_sub_span ~parent ?flavor ?level ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ?data name : explicit_span =
+  enter_manual_span ~parent:(Some parent) ?flavor ?level ?__FUNCTION__ ~__FILE__
+    ~__LINE__ ?data name
+
+let exit_manual_span = exit_span
+let add_data_to_manual_span = add_data_to_span
+
+[@@@ocaml.alert "+deprecated"]

src/core/trace_core.mli

@@ -1,141 +1,13 @@
-(** Trace. *)
+(** Main tracing interface.
+
+    This interface is intended to be lightweight and usable in both libraries
+    and applications. It has very low overhead if no {!Collector.t} is
+    installed. *)
 
 include module type of Types
 module Collector = Collector
-module Meta_map = Meta_map
-
-(** {2 Tracing} *)
-
-val enabled : unit -> bool
-(** Is there a collector?
-
-    This is fast, so that the traced program can check it before creating
-    any span or message. *)
-
-val with_span :
-  ?__FUNCTION__:string ->
-  __FILE__:string ->
-  __LINE__:int ->
-  ?data:(unit -> (string * user_data) list) ->
-  string ->
-  (span -> 'a) ->
-  'a
-(** [with_span ~__FILE__ ~__LINE__ name f] enters a new span [sp],
-    and calls [f sp].
-    [sp] might be a dummy span if no collector is installed.
-    When [f sp] returns or raises, the span [sp] is exited.
-
-    This is the recommended way to instrument most code.
-
-    {b NOTE} an important restriction is that this is only supposed to
-    work for synchronous, direct style code. Monadic concurrency, Effect-based
-    fibers, etc. might not play well with this style of spans on some
-    or all backends. If you use cooperative concurrency,
-    see {!enter_manual_span}.
-*)
-
-val add_data_to_span : span -> (string * user_data) list -> unit
-(** Add structured data to the given active span (see {!with_span}).
-    Behavior is not specified if the span has been exited.
-    @since NEXT_RELEASE *)
-
-val enter_manual_sub_span :
-  parent:explicit_span ->
-  ?flavor:[ `Sync | `Async ] ->
-  ?__FUNCTION__:string ->
-  __FILE__:string ->
-  __LINE__:int ->
-  ?data:(unit -> (string * user_data) list) ->
-  string ->
-  explicit_span
-(** Like {!with_span} but the caller is responsible for
-    obtaining the [parent] span from their {e own} caller, and carry the resulting
-    {!explicit_span} to  the matching {!exit_manual_span}. 
-    @param flavor a description of the span that can be used by the {!Collector.S}
-      to decide how to represent the span. Typically, [`Sync] spans
-      start and stop on one thread, and are nested purely by their timestamp;
-      and [`Async] spans can overlap, migrate between threads, etc. (as happens in
-      Lwt, Eio, Async, etc.) which impacts how the collector might represent them.
-    @since 0.3 *)
-
-val enter_manual_toplevel_span :
-  ?flavor:[ `Sync | `Async ] ->
-  ?__FUNCTION__:string ->
-  __FILE__:string ->
-  __LINE__:int ->
-  ?data:(unit -> (string * user_data) list) ->
-  string ->
-  explicit_span
-(** Like {!with_span} but the caller is responsible for carrying this
-    [explicit_span] around until it's exited with {!exit_manual_span}.
-    The span can be used as a parent in {!enter_manual_sub_span}.
-    @param flavor see {!enter_manual_sub_span} for more details.
-    @since 0.3 *)
-
-val exit_manual_span : explicit_span -> unit
-(** Exit an explicit span. This can be on another thread, in a
-    fiber or lightweight thread, etc. and will be supported by backends
-    nonetheless.
-    The span can be obtained via {!enter_manual_sub_span} or
-    {!enter_manual_toplevel_span}.
-    @since 0.3 *)
-
-val add_data_to_manual_span : explicit_span -> (string * user_data) list -> unit
-(** [add_data_explicit esp data] adds [data] to the span [esp].
-      The behavior is not specified is the span has been exited already.
-    @since NEXT_RELEASE *)
-
-val message :
-  ?span:span -> ?data:(unit -> (string * user_data) list) -> string -> unit
-(** [message msg] logs a message [msg] (if a collector is installed).
-    Additional metadata can be provided.
-    @param span the surrounding span, if any. This might be ignored by the collector. *)
-
-val messagef :
-  ?span:span ->
-  ?data:(unit -> (string * user_data) list) ->
-  ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) ->
-  unit
-(** [messagef (fun k->k"hello %s %d!" "world" 42)] is like
-    [message "hello world 42!"] but only computes the string formatting
-    if a collector is installed. *)
-
-val set_thread_name : string -> unit
-(** Give a name to the current thread.
-    This might be used by the collector
-    to display traces in a more informative way. *)
-
-val set_process_name : string -> unit
-(** Give a name to the current process.
-    This might be used by the collector
-    to display traces in a more informative way. *)
-
-val counter_int :
-  ?data:(unit -> (string * user_data) list) -> string -> int -> unit
-(** Emit a counter of type [int]. Counters represent the evolution of some quantity
-    over time.
-    @param data metadata for this metric (since NEXT_RELEASE) *)
-
-val counter_float :
-  ?data:(unit -> (string * user_data) list) -> string -> float -> unit
-(** Emit a counter of type [float]. See {!counter_int} for more details.
-    @param data metadata for this metric (since NEXT_RELEASE) *)
-
-(** {2 Collector} *)
-
-type collector = (module Collector.S)
-(** An event collector.
-
-    See {!Collector} for more details. *)
-
-val setup_collector : collector -> unit
-(** [setup_collector c] installs [c] as the current collector.
-    @raise Invalid_argument if there already is an established
-    collector. *)
-
-val shutdown : unit -> unit
-(** [shutdown ()] shutdowns the current collector, if one was installed,
-    and waits for it to terminate before returning. *)
+module Level = Level
+module Ambient_span_provider = Ambient_span_provider
 
 (**/**)
 
@@ -145,3 +17,285 @@ module Internal_ : sig
 end
 
 (**/**)
+
+(** {2 Tracing} *)
+
+val enabled : unit -> bool
+(** Is there a collector?
+
+    This is fast, so that the traced program can check it before creating any
+    span or message. *)
+
+val get_default_level : unit -> Level.t
+(** Current default level for spans.
+    @since 0.7 *)
+
+val set_default_level : Level.t -> unit
+(** Set level used for spans that do not specify it. The default default value
+    is [Level.Trace].
+    @since 0.7 *)
+
+val with_span :
+  ?level:Level.t ->
+  ?__FUNCTION__:string ->
+  __FILE__:string ->
+  __LINE__:int ->
+  ?parent:span option ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  (span -> 'a) ->
+  'a
+(** [with_span ~__FILE__ ~__LINE__ name f] enters a new span [sp], and calls
+    [f sp]. [sp] might be a dummy span if no collector is installed. When [f sp]
+    returns or raises, the span [sp] is exited.
+
+    This is the recommended way to instrument most code.
+
+    @param level
+      optional level for this span. since 0.7. Default is set via
+      {!set_default_level}.
+    @param parent the span's parent, if any. since 0.11.
+    @param params
+      extension parameters, used to communicate additional information to the
+      collector. It might be collector-specific. since 0.11.
+
+    Depending on the collector, this might clash with some forms of cooperative
+    concurrency in which [with_span (fun span -> …)] might contain a yield
+    point. Effect-based fibers, etc. might not play well with this style of
+    spans on some or all backends. If you use cooperative concurrency, a safer
+    alternative can be {!enter_span}. *)
+
+val enter_span :
+  ?level:Level.t ->
+  ?__FUNCTION__:string ->
+  __FILE__:string ->
+  __LINE__:int ->
+  ?flavor:[ `Sync | `Async ] ->
+  ?parent:span option ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  span
+(** Enter a span manually. This means the caller is responsible for exiting the
+    span exactly once on every path that exits the current scope. The context
+    must be passed to the exit function as is.
+
+    @param level
+      optional level for this span. since 0.7. Default is set via
+      {!set_default_level}.
+    @param parent the span's parent, if any. since 0.11.
+    @param params see {!with_span}. *)
+
+val exit_span : span -> unit
+(** Exit a span manually. Spans must be nested correctly (ie form a stack or
+    tree).
+
+    For some collectors, [enter_span] and [exit_span] must run on the same
+    thread (e.g. Tracy). For some others, it doesn't matter. *)
+
+val add_data_to_span : span -> (string * user_data) list -> unit
+(** Add structured data to the given active span (see {!with_span}). Behavior is
+    not specified if the span has been exited.
+    @since 0.4 *)
+
+val message :
+  ?level:Level.t ->
+  ?span:span ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  unit
+(** [message msg] logs a message [msg] (if a collector is installed). Additional
+    metadata can be provided.
+    @param level
+      optional level for this span. since 0.7. Default is set via
+      {!set_default_level}.
+    @param span
+      the surrounding span, if any. This might be ignored by the collector.
+    @param params
+      extension parameters, used to communicate additional information to the
+      collector. It might be collector-specific. since 0.11. *)
+
+val messagef :
+  ?level:Level.t ->
+  ?span:span ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) ->
+  unit
+(** [messagef (fun k->k"hello %s %d!" "world" 42)] is like
+    [message "hello world 42!"] but only computes the string formatting if a
+    collector is installed.
+
+    See {!message} for a description of the other arguments. *)
+
+val set_thread_name : string -> unit
+(** Give a name to the current thread. This might be used by the collector to
+    display traces in a more informative way.
+
+    Uses {!Core_ext.Extension_set_thread_name} since 0.11 *)
+
+val set_process_name : string -> unit
+(** Give a name to the current process. This might be used by the collector to
+    display traces in a more informative way.
+
+    Uses {!Core_ext.Extension_set_process_name} since 0.11 *)
+
+val metric :
+  ?level:Level.t ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  metric ->
+  unit
+(** Emit a metric. Metrics are an extensible type, each collector might support
+    a different subset.
+    @since 0.11 *)
+
+val counter_int :
+  ?level:Level.t ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  int ->
+  unit
+(** Emit a counter of type [int] via {!metric}. Counters represent the evolution
+    of some quantity over time.
+    @param level
+      optional level for this span. since 0.7. Default is set via
+      {!set_default_level}.
+    @param data metadata for this metric (since 0.4) *)
+
+val counter_float :
+  ?level:Level.t ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  float ->
+  unit
+(** Emit a counter of type [float] via {!metric}. See {!counter_int} for more
+    details.
+    @param level
+      optional level for this span. since 0.7. Default is set via
+      {!set_default_level}.
+    @param data metadata for this metric (since 0.4) *)
+
+val current_span : unit -> span option
+(** Access the current span from some ambient scope, {b if supported}. This is
+    only supported if a {!Ambient_span_provider} has been set up.
+    @since 0.12 *)
+
+val with_current_span_set_to : span -> (span -> 'a) -> 'a
+(** [with_current_span_set_to span f] sets the span as current span, enters
+    [f span], and restores the previous current span (if any).
+
+    This is only supported if a {!Ambient_span_provider} has been set up,
+    otherwise it is a no-op.
+
+    Automatically called by {!with_span}.
+
+    @since 0.12 *)
+
+(** {2 Collector} *)
+
+type collector = Collector.t
+(** An event collector. See {!Collector} for more details. *)
+
+val setup_collector : collector -> unit
+(** [setup_collector c] installs [c] as the current collector.
+    @raise Invalid_argument if there already is an established collector. *)
+
+val get_current_level : unit -> Level.t
+(** Get current level. This is only meaningful if a collector was set up with
+    {!setup_collector}.
+    @since 0.7 *)
+
+val set_current_level : Level.t -> unit
+(** Set the current level of tracing. This only has a visible effect if a
+    collector was installed with {!setup_collector}.
+    @since 0.7 *)
+
+val shutdown : unit -> unit
+(** [shutdown ()] shutdowns the current collector, if one was installed, and
+    waits for it to terminate before returning. *)
+
+val with_setup_collector : Collector.t -> (unit -> 'a) -> 'a
+(** [with_setup_collector c f] installs [c], calls [f()], and shutdowns [c] once
+    [f()] is done.
+    @since 0.11 *)
+
+(** {2 ambient span provider} *)
+
+val set_ambient_context_provider : Ambient_span_provider.t -> unit
+(** Install a provider for {!current_span} and {!with_current_span_set_to}. The
+    default provider does nothing (ie [current_span ()] is always [None]).
+    @since 0.12 *)
+
+(** {2 Extensions} *)
+
+type extension_event = Types.extension_event = ..
+(** Extension event
+    @since 0.8 *)
+
+val extension_event : ?level:Level.t -> extension_event -> unit
+(** Trigger an extension event, whose meaning depends on the library that
+    defines it. Some collectors will simply ignore it. This does nothing if no
+    collector is setup.
+    @param level filtering level, since 0.11
+    @since 0.8 *)
+
+(** {2 Core extensions} *)
+
+module Core_ext = Core_ext
+
+(** {2 Deprecated} *)
+
+[@@@ocaml.alert "-deprecated"]
+
+val enter_manual_span :
+  parent:explicit_span_ctx option ->
+  ?flavor:[ `Sync | `Async ] ->
+  ?level:Level.t ->
+  ?__FUNCTION__:string ->
+  __FILE__:string ->
+  __LINE__:int ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  explicit_span
+[@@deprecated "use enter_span"]
+
+val enter_manual_sub_span :
+  parent:explicit_span ->
+  ?flavor:[ `Sync | `Async ] ->
+  ?level:Level.t ->
+  ?__FUNCTION__:string ->
+  __FILE__:string ->
+  __LINE__:int ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  explicit_span
+[@@deprecated "use enter_span"]
+(** @deprecated since 0.10, use {!enter_span} *)
+
+val enter_manual_toplevel_span :
+  ?flavor:[ `Sync | `Async ] ->
+  ?level:Level.t ->
+  ?__FUNCTION__:string ->
+  __FILE__:string ->
+  __LINE__:int ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  explicit_span
+[@@deprecated "use enter_span"]
+(** @deprecated since 0.10 use {!enter_span} *)
+
+val exit_manual_span : explicit_span -> unit
+[@@deprecated "use exit_span"]
+(** @deprecated since 0.10 use {!exit_span} *)
+
+val add_data_to_manual_span : explicit_span -> (string * user_data) list -> unit
+[@@deprecated "use add_data_to_span"]
+(** @deprecated since 0.10 use {!add_data_to_span} *)
+
+[@@@ocaml.alert "+deprecated"]

src/core/types.ml

@@ -1,7 +1,16 @@
-type span = int64
-(** A span identifier.
+(** Main type definitions *)
 
-    The meaning of the identifier depends on the collector. *)
+type span = ..
+(** A span. Its representation is defined by the current collector.
+
+    This representation changed in 0.11 (from [int64] to an open sum type) *)
+
+(** Information about a span's parent span, if any.
+    @since 0.11 *)
+type parent =
+  | P_unknown  (** Parent is not specified at this point *)
+  | P_none  (** We know the current span has no parent *)
+  | P_some of span  (** We know the parent of the current span *)
 
 type user_data =
   [ `Int of int
@@ -10,13 +19,23 @@ type user_data =
   | `Float of float
   | `None
   ]
-(** User defined data, generally passed as key/value pairs to
-    whatever collector is installed (if any). *)
+(** User defined data, generally passed as key/value pairs to whatever collector
+    is installed (if any). *)
 
-type explicit_span = {
-  span: span;
-      (** Identifier for this span. Several explicit spans might share the same
-      identifier since we can differentiate between them via [meta]. *)
-  mutable meta: Meta_map.t;  (** Metadata for this span (and its context) *)
-}
-(** Explicit span, with collector-specific metadata *)
+type explicit_span = span [@@deprecated "use span"]
+type explicit_span_ctx = span [@@deprecated "use span"]
+
+type extension_event = ..
+(** An extension event, used to add features that are backend specific or simply
+    not envisioned by [trace]. See {!Core_ext} for some builtin extension
+    events.
+    @since 0.8 *)
+
+type extension_parameter = ..
+(** An extension parameter, used to carry information for spans/messages/metrics
+    that can be backend-specific or just not envisioned by [trace].
+    @since 0.11 *)
+
+type metric = ..
+(** A metric, can be of many types. See {!Core_ext} for some builtin metrics.
+    @since 0.11 *)

src/debug/dune

@@ -0,0 +1,6 @@
+(library
+ (name trace_debug)
+ (public_name trace.debug)
+ (synopsis "helper to debug unclosed spans")
+ (optional) ; threads
+ (libraries threads trace.core trace.util))

src/debug/track_spans.ml

@@ -0,0 +1,150 @@
+module A = Trace_core.Internal_.Atomic_
+open Trace_core
+
+let ( let@ ) = ( @@ )
+
+type span += Span_tracked of (* id *) int * span
+
+type unclosed_spans = {
+  num: int;
+  by_name: (string * int) list;
+}
+
+type out =
+  [ `Out of out_channel
+  | `Call of unclosed_spans -> unit
+  ]
+
+open struct
+  module Tbl = Hashtbl.Make (struct
+    type t = int
+
+    let equal = Stdlib.( = )
+    let hash = Hashtbl.hash
+  end)
+
+  type 'state st = {
+    mutex: Mutex.t;
+    tbl_open_spans: string Tbl.t;
+    gen_id: int A.t;
+    state: 'state;
+    cbs: 'state Collector.Callbacks.t;  (** underlying callbacks *)
+    out: out;
+  }
+
+  let create_st ~state ~cbs ~out () : _ st =
+    {
+      mutex = Mutex.create ();
+      tbl_open_spans = Tbl.create 32;
+      gen_id = A.make 0;
+      state;
+      cbs;
+      out;
+    }
+
+  let with_mutex mut f =
+    Mutex.lock mut;
+    Fun.protect f ~finally:(fun () -> Mutex.unlock mut)
+
+  let enter_span (self : _ st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params
+      ~data ~parent name : span =
+    let span =
+      self.cbs.enter_span self.state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level
+        ~params ~data ~parent name
+    in
+    let id = A.fetch_and_add self.gen_id 1 in
+    (let@ () = with_mutex self.mutex in
+     Tbl.add self.tbl_open_spans id name);
+    Span_tracked (id, span)
+
+  let exit_span (self : _ st) span =
+    match span with
+    | Span_tracked (id, span) ->
+      (let@ () = with_mutex self.mutex in
+       Tbl.remove self.tbl_open_spans id);
+      self.cbs.exit_span self.state span
+    | _ -> self.cbs.exit_span self.state span
+
+  let add_data_to_span (self : _ st) span data =
+    match span with
+    | Span_tracked (_, span) -> self.cbs.add_data_to_span self.state span data
+    | _ -> self.cbs.add_data_to_span self.state span data
+
+  let emit (self : _ st) (us : unclosed_spans) =
+    assert (us.by_name <> []);
+    match self.out with
+    | `Call f -> f us
+    | `Out out ->
+      Printf.fprintf out "trace: warning: %d spans were not closed\n" us.num;
+      List.iter
+        (fun (name, n) ->
+          Printf.fprintf out "  span %S was not closed (%d occurrences)\n" name
+            n)
+        us.by_name;
+      flush out
+
+  let print_non_closed_spans_warning (self : _ st) =
+    let module Str_map = Map.Make (String) in
+    let@ () = with_mutex self.mutex in
+
+    let num = Tbl.length self.tbl_open_spans in
+    if num > 0 then (
+      let names_with_count =
+        Tbl.fold
+          (fun _id name m ->
+            Str_map.add name
+              (1 + try Str_map.find name m with Not_found -> 0)
+              m)
+          self.tbl_open_spans Str_map.empty
+      in
+      let unclosed_spans =
+        {
+          num;
+          by_name =
+            Str_map.fold (fun name id l -> (name, id) :: l) names_with_count []
+            |> List.sort Stdlib.compare;
+        }
+      in
+      emit self unclosed_spans
+    )
+
+  let message self ~level ~params ~data ~span msg =
+    let span =
+      match span with
+      | Some (Span_tracked (_, sp)) -> Some sp
+      | _ -> span
+    in
+    self.cbs.message self.state ~level ~params ~data ~span msg
+
+  let metric self ~level ~params ~data name v =
+    self.cbs.metric self.state ~level ~params ~data name v
+
+  let enabled _ _ = true
+  let init (self : _ st) = self.cbs.init self.state
+
+  let shutdown (self : _ st) : unit =
+    print_non_closed_spans_warning self;
+    self.cbs.shutdown self.state
+
+  let extension self ~level ev = self.cbs.extension self.state ~level ev
+
+  let track_callbacks : _ st Collector.Callbacks.t =
+    {
+      enter_span;
+      exit_span;
+      add_data_to_span;
+      enabled;
+      message;
+      metric;
+      init;
+      shutdown;
+      extension;
+    }
+end
+
+let track ?(on_lingering_spans = `Out stderr) (c : Collector.t) : Collector.t =
+  match c with
+  | C_none -> C_none
+  | C_some (st, cbs) ->
+    let st = create_st ~state:st ~cbs ~out:on_lingering_spans () in
+    C_some (st, track_callbacks)

src/debug/track_spans.mli

@@ -0,0 +1,20 @@
+(** Helper to track which spans never get closed. *)
+
+open Trace_core
+
+type unclosed_spans = {
+  num: int;
+  by_name: (string * int) list;
+}
+
+val track :
+  ?on_lingering_spans:[ `Out of out_channel | `Call of unclosed_spans -> unit ] ->
+  Collector.t ->
+  Collector.t
+(** Modify the enter/exit span functions to track the set of spans that are
+    open, and warn at the end if some are not closed.
+
+    implementation notes: for now this uses a regular {!Hashtbl} protected by a
+    mutex, so runtime overhead isn't trivial.
+
+    @param on_lingering_spans what to do with the non-closed spans *)

src/dune

@@ -2,5 +2,5 @@
  (name trace)
  (public_name trace)
  (synopsis "Lightweight stub for tracing")
- (libraries (re_export trace.core))
-)
+ (libraries
+  (re_export trace.core)))

src/fuchsia/buf.ml

@@ -0,0 +1,43 @@
+open Util
+
+type t = {
+  buf: bytes;
+  mutable offset: int;
+}
+
+let empty : t = { buf = Bytes.empty; offset = 0 }
+
+let create (n : int) : t =
+  (* multiple of 8-bytes size *)
+  let buf = Bytes.create (round_to_word n) in
+  { buf; offset = 0 }
+
+let[@inline] clear self = self.offset <- 0
+let[@inline] available self = Bytes.length self.buf - self.offset
+let[@inline] size self = self.offset
+let[@inline] is_empty self = self.offset = 0
+
+(* see below: we assume little endian *)
+let () = assert (not Sys.big_endian)
+
+let[@inline] add_i64 (self : t) (i : int64) : unit =
+  (* NOTE: we use LE, most systems are this way, even though fuchsia
+     says we should use the system's native endianess *)
+  Bytes.set_int64_le self.buf self.offset i;
+  self.offset <- self.offset + 8
+
+let[@inline] add_string (self : t) (s : string) : unit =
+  let len = String.length s in
+  let missing = missing_to_round len in
+
+  (* bound check *)
+  Bytes.blit_string s 0 self.buf self.offset len;
+  self.offset <- self.offset + len;
+
+  (* add 0-padding *)
+  if missing != 0 then (
+    Bytes.unsafe_fill self.buf self.offset missing '\x00';
+    self.offset <- self.offset + missing
+  )
+
+let to_string (self : t) : string = Bytes.sub_string self.buf 0 self.offset

src/fuchsia/buf_chain.ml

@@ -0,0 +1,146 @@
+(** A set of buffers in use, and a set of ready buffers *)
+
+open Common_
+
+(** Buffers in use *)
+type buffers =
+  | B_one of { mutable buf: Buf.t }
+  | B_many of Buf.t Lock.t array
+      (** mask(thread id) -> buffer. This reduces contention *)
+
+type t = {
+  bufs: buffers;
+  has_ready: bool A.t;
+  ready: Buf.t Queue.t Lock.t;
+      (** Buffers that are full (enough) and must be written *)
+  buf_pool: Buf_pool.t;
+}
+(** A set of buffers, some of which are ready to be written *)
+
+open struct
+  let shard_log = 4
+  let shard = 1 lsl shard_log
+  let shard_mask = shard - 1
+end
+
+(** Create a buffer chain.
+
+    @param sharded
+      if true, multiple buffers are created, to reduce contention on each buffer
+      in case of concurrent access. This makes the buf chain thread-safe. If
+      false, there is only one (unprotected) buffer. *)
+let create ~(sharded : bool) ~(buf_pool : Buf_pool.t) () : t =
+  let bufs =
+    if sharded then (
+      let bufs =
+        Array.init shard (fun _ -> Lock.create @@ Buf_pool.alloc buf_pool)
+      in
+      B_many bufs
+    ) else
+      B_one { buf = Buf_pool.alloc buf_pool }
+  in
+  {
+    bufs;
+    buf_pool;
+    has_ready = A.make false;
+    ready = Lock.create @@ Queue.create ();
+  }
+
+open struct
+  let put_in_ready (self : t) buf : unit =
+    if Buf.size buf > 0 then (
+      let@ q = Lock.with_ self.ready in
+      A.set self.has_ready true;
+      Queue.push buf q
+    )
+
+  let assert_available buf ~available =
+    if Buf.available buf < available then (
+      let msg =
+        Printf.sprintf
+          "fuchsia: buffer is too small (available: %d bytes, needed: %d bytes)"
+          (Buf.available buf) available
+      in
+      failwith msg
+    )
+end
+
+(** Move all non-empty buffers to [ready] *)
+let ready_all_non_empty (self : t) : unit =
+  let@ q = Lock.with_ self.ready in
+  match self.bufs with
+  | B_one r ->
+    if not (Buf.is_empty r.buf) then (
+      Queue.push r.buf q;
+      A.set self.has_ready true;
+      r.buf <- Buf.empty
+    )
+  | B_many bufs ->
+    Array.iter
+      (fun buf ->
+        Lock.update buf (fun buf ->
+            if Buf.size buf > 0 then (
+              Queue.push buf q;
+              A.set self.has_ready true;
+              Buf.empty
+            ) else
+              buf))
+      bufs
+
+let[@inline] has_ready self : bool = A.get self.has_ready
+
+(** Get access to ready buffers, then clean them up automatically *)
+let pop_ready (self : t) ~(f : Buf.t Queue.t -> 'a) : 'a =
+  let@ q = Lock.with_ self.ready in
+  let res = f q in
+
+  (* clear queue *)
+  Queue.iter (Buf_pool.recycle self.buf_pool) q;
+  Queue.clear q;
+  A.set self.has_ready false;
+  res
+
+(** Maximum size available, in words, for a single message *)
+let[@inline] max_size_word (_self : t) : int = fuchsia_buf_size lsr 3
+
+(** Obtain a buffer with at least [available_word] 64-bit words *)
+let with_buf (self : t) ~(available_word : int) (f : Buf.t -> 'a) : 'a =
+  let available = available_word lsl 3 in
+  match self.bufs with
+  | B_one r ->
+    if Buf.available r.buf < available then (
+      put_in_ready self r.buf;
+      r.buf <- Buf_pool.alloc self.buf_pool
+    );
+    assert_available r.buf ~available;
+    f r.buf
+  | B_many bufs ->
+    let tid = Thread.(id (self ())) in
+    let masked_tid = tid land shard_mask in
+    let buf_lock = bufs.(masked_tid) in
+    let@ buf = Lock.with_ buf_lock in
+    let buf =
+      if Buf.available buf < available then (
+        put_in_ready self buf;
+        let new_buf = Buf_pool.alloc self.buf_pool in
+        assert_available new_buf ~available;
+        Lock.set_while_locked buf_lock new_buf;
+        new_buf
+      ) else
+        buf
+    in
+    f buf
+
+(** Dispose of resources (here, recycle buffers) *)
+let dispose (self : t) : unit =
+  match self.bufs with
+  | B_one r ->
+    Buf_pool.recycle self.buf_pool r.buf;
+    r.buf <- Buf.empty
+  | B_many bufs ->
+    Array.iter
+      (fun buf_lock ->
+        let@ buf = Lock.with_ buf_lock in
+        Buf_pool.recycle self.buf_pool buf;
+        Lock.set_while_locked buf_lock Buf.empty)
+      bufs

src/fuchsia/buf_pool.ml

@@ -0,0 +1,23 @@
+open Common_
+open Trace_util
+
+type t = Buf.t Rpool.t
+
+let create ?(max_size = 64) () : t =
+  Rpool.create ~max_size ~clear:Buf.clear
+    ~create:(fun () -> Buf.create fuchsia_buf_size)
+    ()
+
+let alloc = Rpool.alloc
+let[@inline] recycle self buf = if buf != Buf.empty then Rpool.recycle self buf
+
+let with_ (self : t) f =
+  let x = alloc self in
+  try
+    let res = f x in
+    recycle self x;
+    res
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    recycle self x;
+    Printexc.raise_with_backtrace e bt

src/fuchsia/collector_fuchsia.ml

@@ -0,0 +1,215 @@
+open Common_
+open Types
+open Trace_core
+
+type t = {
+  active: bool A.t;
+  pid: int;
+  buf_chain: Buf_chain.t;
+  exporter: Exporter.t;
+  trace_id_gen: Types.Trace_id.Gen.t;
+}
+(** Subscriber state *)
+
+open struct
+  (** Write the buffers that are ready *)
+  let[@inline] write_ready_ (self : t) =
+    if Buf_chain.has_ready self.buf_chain then
+      Buf_chain.pop_ready self.buf_chain ~f:self.exporter.write_bufs
+
+  (* TODO: nice to have, can we make it optional?
+  let print_non_closed_spans_warning spans =
+    let module Str_set = Set.Make (String) in
+    let spans = Span_tbl.to_list spans in
+    if spans <> [] then (
+      !on_tracing_error
+      @@ Printf.sprintf "warning: %d spans were not closed" (List.length spans);
+      let names =
+        List.fold_left
+          (fun set (_, span) -> Str_set.add span.name set)
+          Str_set.empty spans
+      in
+      Str_set.iter
+        (fun name ->
+          !on_tracing_error @@ Printf.sprintf "  span %S was not closed" name)
+        names;
+      flush stderr
+    )
+    *)
+end
+
+let close (self : t) : unit =
+  if A.exchange self.active false then (
+    Buf_chain.ready_all_non_empty self.buf_chain;
+    write_ready_ self;
+    self.exporter.close () (* TODO: print_non_closed_spans_warning self.spans *)
+  )
+
+let[@inline] active self = A.get self.active
+
+let flush (self : t) : unit =
+  Buf_chain.ready_all_non_empty self.buf_chain;
+  write_ready_ self;
+  self.exporter.flush ()
+
+let create ?(buf_pool = Buf_pool.create ()) ~pid ~exporter () : t =
+  let buf_chain = Buf_chain.create ~sharded:true ~buf_pool () in
+  {
+    active = A.make true;
+    buf_chain;
+    exporter;
+    pid;
+    trace_id_gen = Types.Trace_id.Gen.create ();
+  }
+
+open struct
+  let new_trace_id self = Types.Trace_id.Gen.gen self.trace_id_gen
+
+  let init (self : t) =
+    Writer.Metadata.Magic_record.encode self.buf_chain;
+    Writer.Metadata.Initialization_record.(
+      encode self.buf_chain ~ticks_per_secs:default_ticks_per_sec ());
+    Writer.Metadata.Provider_info.encode self.buf_chain ~id:0
+      ~name:"ocaml-trace" ();
+    (* make sure we write these immediately so they're not out of order *)
+    Buf_chain.ready_all_non_empty self.buf_chain;
+
+    write_ready_ self
+
+  let shutdown (self : t) = close self
+
+  (* add function name, if provided, to the metadata *)
+  let add_fun_name_ fun_name data : _ list =
+    match fun_name with
+    | None -> data
+    | Some f -> ("function", `String f) :: data
+
+  let rec flavor_of_params = function
+    | [] -> `Sync
+    | Core_ext.Extension_span_flavor f :: _ -> f
+    | _ :: tl -> flavor_of_params tl
+
+  let enter_span (self : t) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level:_ ~params
+      ~data ~parent name : span =
+    let flavor = flavor_of_params params in
+    let time_ns = Trace_util.Mock_.now_ns () in
+    let tid = Trace_util.Mock_.get_tid () in
+
+    match flavor with
+    | `Sync ->
+      Span_fuchsia_sync
+        {
+          __FUNCTION__;
+          name;
+          pid = self.pid;
+          tid;
+          args = data;
+          start_ns = time_ns;
+        }
+    | `Async ->
+      let data = add_fun_name_ __FUNCTION__ data in
+      let trace_id =
+        match parent with
+        | P_some (Span_fuchsia_async sp) -> sp.trace_id
+        | _ -> new_trace_id self
+      in
+
+      Writer.(
+        Event.Async_begin.encode self.buf_chain ~name
+          ~args:(args_of_user_data data)
+          ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid)
+          ~time_ns ~async_id:trace_id ());
+      write_ready_ self;
+
+      Span_fuchsia_async { pid = self.pid; tid; trace_id; name; args = data }
+
+  let exit_span (self : t) sp =
+    let end_time_ns = Trace_util.Mock_.now_ns () in
+
+    match sp with
+    | Span_fuchsia_sync { __FUNCTION__; name; tid; pid; args = data; start_ns }
+      ->
+      let data = add_fun_name_ __FUNCTION__ data in
+      Writer.(
+        Event.Duration_complete.encode self.buf_chain ~name
+          ~t_ref:(Thread_ref.inline ~pid ~tid)
+          ~time_ns:start_ns ~end_time_ns ~args:(args_of_user_data data) ());
+      write_ready_ self
+    | Span_fuchsia_async { name; tid; pid; trace_id; args = data } ->
+      Writer.(
+        Event.Async_end.encode self.buf_chain ~name
+          ~args:(args_of_user_data data)
+          ~t_ref:(Thread_ref.inline ~pid ~tid)
+          ~time_ns:end_time_ns ~async_id:trace_id ());
+      write_ready_ self
+    | _ -> ()
+
+  let add_data_to_span _st sp data =
+    match sp with
+    | Span_fuchsia_sync sp -> sp.args <- List.rev_append data sp.args
+    | Span_fuchsia_async sp -> sp.args <- List.rev_append data sp.args
+    | _ -> ()
+
+  let message (self : t) ~level:_ ~params:_ ~data ~span:_ msg : unit =
+    let time_ns = Trace_util.Mock_.now_ns () in
+    let tid = Trace_util.Mock_.get_tid () in
+    Writer.(
+      Event.Instant.encode self.buf_chain
+        ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid)
+        ~name:msg ~time_ns ~args:(args_of_user_data data) ());
+    write_ready_ self
+
+  let counter_float_ (self : t) ~data name n : unit =
+    let tid = Trace_util.Mock_.get_tid () in
+    let time_ns = Trace_util.Mock_.now_ns () in
+    Writer.(
+      Event.Counter.encode self.buf_chain
+        ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid)
+        ~name ~time_ns
+        ~args:((name, A_float n) :: args_of_user_data data)
+        ());
+    write_ready_ self
+
+  let counter_int_ self ~data name n =
+    let tid = Trace_util.Mock_.get_tid () in
+    let time_ns = Trace_util.Mock_.now_ns () in
+    Writer.(
+      Event.Counter.encode self.buf_chain
+        ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid)
+        ~name ~time_ns
+        ~args:((name, A_int n) :: args_of_user_data data)
+        ());
+    write_ready_ self
+
+  let metric self ~level:_ ~params:_ ~data name m =
+    match m with
+    | Core_ext.Metric_int i -> counter_int_ self ~data name i
+    | Core_ext.Metric_float n -> counter_float_ self ~data name n
+    | _ -> ()
+
+  let name_process_ (self : t) name : unit =
+    Writer.Kernel_object.(
+      encode self.buf_chain ~name ~ty:ty_process ~kid:self.pid ~args:[] ());
+    write_ready_ self
+
+  let name_thread_ (self : t) ~tid name : unit =
+    Writer.Kernel_object.(
+      encode self.buf_chain ~name ~ty:ty_thread ~kid:tid
+        ~args:[ "process", A_kid (Int64.of_int self.pid) ]
+        ());
+    write_ready_ self
+
+  let extension (self : t) ~level:_ ev =
+    match ev with
+    | Core_ext.Extension_set_thread_name name ->
+      let tid = Trace_util.Mock_.get_tid () in
+      name_thread_ self ~tid name
+    | Core_ext.Extension_set_process_name name -> name_process_ self name
+    | _ -> ()
+end
+
+let callbacks : t Collector.Callbacks.t =
+  Collector.Callbacks.make ~init ~shutdown ~enter_span ~exit_span
+    ~add_data_to_span ~message ~metric ~extension ()
+
+let collector (self : t) : Collector.t = Collector.C_some (self, callbacks)

src/fuchsia/collector_fuchsia.mli

@@ -0,0 +1,15 @@
+open Trace_core
+
+type t
+(** Main subscriber state. *)
+
+val create : ?buf_pool:Buf_pool.t -> pid:int -> exporter:Exporter.t -> unit -> t
+(** Create a subscriber state. *)
+
+val flush : t -> unit
+val close : t -> unit
+val active : t -> bool
+val callbacks : t Collector.Callbacks.t
+
+val collector : t -> Collector.t
+(** Subscriber that writes json into this writer *)

src/fuchsia/common_.ml

@@ -0,0 +1,18 @@
+module A = Trace_core.Internal_.Atomic_
+
+let ( let@ ) = ( @@ )
+let spf = Printf.sprintf
+
+let with_lock lock f =
+  Mutex.lock lock;
+  try
+    let res = f () in
+    Mutex.unlock lock;
+    res
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    Mutex.unlock lock;
+    Printexc.raise_with_backtrace e bt
+
+(** Buffer size we use. *)
+let fuchsia_buf_size = 1 lsl 16

src/fuchsia/dune

@@ -0,0 +1,6 @@
+(library
+ (name trace_fuchsia)
+ (public_name trace-fuchsia)
+ (synopsis
+  "A high-performance backend for trace, emitting a Fuchsia trace into a file")
+ (libraries trace.core trace.util bigarray mtime mtime.clock.os unix threads))

src/fuchsia/exporter.ml

@@ -0,0 +1,61 @@
+(** An exporter, takes buffers with fuchsia events, and writes them somewhere *)
+
+open Common_
+
+type t = {
+  write_bufs: Buf.t Queue.t -> unit;
+      (** Takes buffers and writes them somewhere. The buffers are only valid
+          during this call and must not be stored. The queue must not be
+          modified. *)
+  flush: unit -> unit;  (** Force write *)
+  close: unit -> unit;  (** Close underlying resources *)
+}
+(** An exporter, takes buffers and writes them somewhere. This should be
+    thread-safe if used in a threaded environment. *)
+
+open struct
+  let with_lock lock f =
+    Mutex.lock lock;
+    try
+      let res = f () in
+      Mutex.unlock lock;
+      res
+    with e ->
+      let bt = Printexc.get_raw_backtrace () in
+      Mutex.unlock lock;
+      Printexc.raise_with_backtrace e bt
+end
+
+(** Export to the channel
+    @param close_channel if true, closing the exporter will close the channel *)
+let of_out_channel ~close_channel oc : t =
+  let lock = Mutex.create () in
+  let closed = ref false in
+  let flush () =
+    let@ () = with_lock lock in
+    flush oc
+  in
+  let close () =
+    let@ () = with_lock lock in
+    if not !closed then (
+      closed := true;
+      if close_channel then close_out_noerr oc
+    )
+  in
+  let write_bufs bufs =
+    if not (Queue.is_empty bufs) then
+      let@ () = with_lock lock in
+      Queue.iter (fun (buf : Buf.t) -> output oc buf.buf 0 buf.offset) bufs
+  in
+  { flush; close; write_bufs }
+
+let of_buffer (buffer : Buffer.t) : t =
+  let buffer = Lock.create buffer in
+  let write_bufs bufs =
+    if not (Queue.is_empty bufs) then
+      let@ buffer = Lock.with_ buffer in
+      Queue.iter
+        (fun (buf : Buf.t) -> Buffer.add_subbytes buffer buf.buf 0 buf.offset)
+        bufs
+  in
+  { flush = ignore; close = ignore; write_bufs }

src/fuchsia/lock.ml

@@ -0,0 +1,27 @@
+type 'a t = {
+  mutex: Mutex.t;
+  mutable content: 'a;
+}
+
+let create content : _ t = { mutex = Mutex.create (); content }
+
+let with_ (self : _ t) f =
+  Mutex.lock self.mutex;
+  try
+    let x = f self.content in
+    Mutex.unlock self.mutex;
+    x
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    Mutex.unlock self.mutex;
+    Printexc.raise_with_backtrace e bt
+
+let[@inline] update self f = with_ self (fun x -> self.content <- f x)
+
+let[@inline] update_map l f =
+  with_ l (fun x ->
+      let x', y = f x in
+      l.content <- x';
+      y)
+
+let[@inline] set_while_locked (self : 'a t) (x : 'a) = self.content <- x

src/fuchsia/lock.mli

@@ -0,0 +1,10 @@
+type 'a t
+(** A value protected by a mutex *)
+
+val create : 'a -> 'a t
+val with_ : 'a t -> ('a -> 'b) -> 'b
+val update : 'a t -> ('a -> 'a) -> unit
+val update_map : 'a t -> ('a -> 'a * 'b) -> 'b
+
+val set_while_locked : 'a t -> 'a -> unit
+(** Change the value while inside [with_] or similar. *)

src/fuchsia/time.ml

@@ -0,0 +1,6 @@
+let counter = Mtime_clock.counter ()
+
+(** Now, in nanoseconds *)
+let[@inline] now_ns () : int64 =
+  let t = Mtime_clock.count counter in
+  Mtime.Span.to_uint64_ns t

src/fuchsia/trace_fuchsia.ml

@@ -0,0 +1,51 @@
+module Buf = Buf
+module Buf_chain = Buf_chain
+module Buf_pool = Buf_pool
+module Exporter = Exporter
+module Collector_fuchsia = Collector_fuchsia
+module Writer = Writer
+
+type output =
+  [ `File of string
+  | `Exporter of Exporter.t
+  ]
+
+let get_out_ (out : [< output ]) : Exporter.t =
+  match out with
+  | `File path ->
+    let oc = open_out path in
+    Exporter.of_out_channel ~close_channel:true oc
+  | `Exporter e -> e
+
+let collector ~out () : Trace_core.Collector.t =
+  let exporter = get_out_ out in
+  let pid = Trace_util.Mock_.get_pid () in
+  let coll_st = Collector_fuchsia.create ~pid ~exporter () in
+  Collector_fuchsia.collector coll_st
+
+let setup ?(out = `Env) () =
+  match out with
+  | `File path -> Trace_core.setup_collector @@ collector ~out:(`File path) ()
+  | `Exporter _ as out ->
+    let c = collector ~out () in
+    Trace_core.setup_collector c
+  | `Env ->
+    (match Sys.getenv_opt "TRACE" with
+    | Some ("1" | "true") ->
+      let path = "trace.fxt" in
+      let c = collector ~out:(`File path) () in
+      Trace_core.setup_collector c
+    | Some path ->
+      let c = collector ~out:(`File path) () in
+      Trace_core.setup_collector c
+    | None -> ())
+
+let with_setup ?out () f =
+  setup ?out ();
+  Fun.protect ~finally:Trace_core.shutdown f
+
+module Internal_ = struct
+  let mock_all_ () =
+    Trace_util.Mock_.mock_all ();
+    ()
+end

src/fuchsia/trace_fuchsia.mli

@@ -0,0 +1,48 @@
+(** Fuchsia trace collector.
+
+    This provides a collector for traces that emits data into a file using the
+    compact binary
+    {{:https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format} Fuchsia
+     trace format}. This reduces the tracing overhead compared to [trace-tef],
+    at the expense of simplicity. *)
+
+module Buf = Buf
+module Buf_chain = Buf_chain
+module Buf_pool = Buf_pool
+module Exporter = Exporter
+module Collector_fuchsia = Collector_fuchsia
+module Writer = Writer
+
+type output =
+  [ `File of string
+  | `Exporter of Exporter.t
+  ]
+
+val collector : out:[< output ] -> unit -> Trace_core.collector
+(** Make a collector that writes into the given output. See {!setup} for more
+    details. *)
+
+val setup : ?out:[ output | `Env ] -> unit -> unit
+(** [setup ()] installs the collector depending on [out].
+
+    @param out
+      can take different values:
+      - regular {!output} value to specify where events go
+      - [`Env] will enable tracing if the environment variable "TRACE" is set.
+
+    - If it's set to "1", then the file is "trace.fxt".
+    - Otherwise, if it's set to a non empty string, the value is taken to be the
+      file path into which to write. *)
+
+val with_setup : ?out:[< output | `Env > `Env ] -> unit -> (unit -> 'a) -> 'a
+(** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes
+    sure to shutdown before exiting. *)
+
+(**/**)
+
+module Internal_ : sig
+  val mock_all_ : unit -> unit
+  (** use fake, deterministic timestamps, TID, PID *)
+end
+
+(**/**)

src/fuchsia/types.ml

@@ -0,0 +1,20 @@
+module Trace_id = Trace_util.Trace_id64
+
+type trace_id = Trace_id.t
+
+type Trace_core.span +=
+  | Span_fuchsia_sync of {
+      __FUNCTION__: string option;
+      pid: int;
+      tid: int;
+      name: string;
+      start_ns: int64;
+      mutable args: (string * Trace_core.user_data) list;
+    }
+  | Span_fuchsia_async of {
+      pid: int;
+      tid: int;
+      name: string;
+      trace_id: trace_id;
+      mutable args: (string * Trace_core.user_data) list;
+    }

src/fuchsia/util.ml

@@ -0,0 +1,5 @@
+(** How many bytes are missing for [n] to be a multiple of 8 *)
+let[@inline] missing_to_round (n : int) : int = lnot (n - 1) land 0b111
+
+(** Round up to a multiple of 8 *)
+let[@inline] round_to_word (n : int) : int = n + (lnot (n - 1) land 0b111)

src/fuchsia/writer.ml

@@ -0,0 +1,584 @@
+(** Write fuchsia events into buffers.
+
+    Reference: https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format *)
+
+open Common_
+module Util = Util
+open Util
+
+type user_data = Trace_core.user_data
+
+type arg =
+  | A_bool of bool
+  | A_float of float
+  | A_int of int
+  | A_none
+  | A_string of string
+  | A_kid of int64
+
+let arg_of_user_data : user_data -> arg = function
+  | `Bool b -> A_bool b
+  | `Float f -> A_float f
+  | `Int i -> A_int i
+  | `String s -> A_string s
+  | `None -> A_none
+
+let[@inline] args_of_user_data :
+    (string * user_data) list -> (string * arg) list =
+ fun l -> List.rev_map (fun (k, v) -> k, arg_of_user_data v) l
+
+module I64 = struct
+  include Int64
+
+  let ( + ) = add
+  let ( - ) = sub
+  let ( = ) = equal
+  let ( land ) = logand
+  let ( lor ) = logor
+  let lnot = lognot
+  let ( lsl ) = shift_left
+  let ( lsr ) = shift_right_logical
+  let ( asr ) = shift_right
+end
+
+open struct
+  (** maximum length as specified in the
+      {{:https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format} spec}
+  *)
+  let max_str_len = 32000
+
+  (** Length of string, in words *)
+  let[@inline] str_len_word (s : string) =
+    let len = String.length s in
+    assert (len <= max_str_len);
+    round_to_word len lsr 3
+
+  let str_len_word_maybe_too_big s =
+    let len = min max_str_len (String.length s) in
+    round_to_word len lsr 3
+end
+
+module Str_ref = struct
+  type t = int
+  (** 16 bits *)
+
+  let[@inline never] inline_fail_ () =
+    invalid_arg
+      (Printf.sprintf "fuchsia: max length of strings is %d" max_str_len)
+
+  let inline (size : int) : t =
+    if size > max_str_len then
+      inline_fail_ ()
+    else if size = 0 then
+      0
+    else
+      (1 lsl 15) lor size
+end
+
+(** [truncate_string s] truncates [s] to the maximum length allowed for strings.
+    If [s] is already short enough, no allocation is done. *)
+let[@inline] truncate_string s : string =
+  if String.length s <= max_str_len then
+    s
+  else
+    String.sub s 0 max_str_len
+
+module Thread_ref = struct
+  type t =
+    | Ref of int
+    | Inline of {
+        pid: int;
+        tid: int;
+      }
+
+  let inline ~pid ~tid : t = Inline { pid; tid }
+
+  let ref x : t =
+    if x = 0 || x > 255 then
+      invalid_arg "fuchsia: thread inline ref must be >0 < 256";
+    Ref x
+
+  let size_word (self : t) : int =
+    match self with
+    | Ref _ -> 0
+    | Inline _ -> 2
+
+  (** 8-bit int for the reference *)
+  let as_i8 (self : t) : int =
+    match self with
+    | Ref i -> i
+    | Inline _ -> 0
+end
+
+(** record type = 0 *)
+module Metadata = struct
+  (** First record in the trace *)
+  module Magic_record = struct
+    let value = 0x0016547846040010L
+    let size_word = 1
+
+    let encode (bufs : Buf_chain.t) =
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in
+      Buf.add_i64 buf value
+  end
+
+  module Initialization_record = struct
+    let size_word = 2
+
+    (** Default: 1 tick = 1 ns *)
+    let default_ticks_per_sec = 1_000_000_000L
+
+    let encode (bufs : Buf_chain.t) ~ticks_per_secs () : unit =
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in
+      let hd = I64.(1L lor (of_int size_word lsl 4)) in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf ticks_per_secs
+  end
+
+  module Provider_info = struct
+    let size_word ~name () = 1 + str_len_word name
+
+    let encode (bufs : Buf_chain.t) ~(id : int) ~name () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+      let hd =
+        I64.(
+          (of_int size lsl 4)
+          lor (1L lsl 16)
+          lor (of_int id lsl 20)
+          lor (of_int (Str_ref.inline (str_len_word name)) lsl 52))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name
+  end
+
+  module Provider_section = struct end
+  module Trace_info = struct end
+end
+
+module Argument = struct
+  type t = string * arg
+
+  let check_valid_ : t -> unit = function
+    | _, A_string s -> assert (String.length s < max_str_len)
+    | _ -> ()
+
+  let[@inline] is_i32_ (i : int) : bool = Int32.(to_int (of_int i) = i)
+
+  let size_word (self : t) =
+    let name, data = self in
+    match data with
+    | A_none | A_bool _ -> 1 + str_len_word name
+    | A_int i when is_i32_ i -> 1 + str_len_word name
+    | A_int _ -> (* int64 *) 2 + str_len_word name
+    | A_float _ -> 2 + str_len_word name
+    | A_string s -> 1 + str_len_word_maybe_too_big s + str_len_word name
+    | A_kid _ -> 2 + str_len_word name
+
+  open struct
+    external int_of_bool : bool -> int = "%identity"
+  end
+
+  let encode (buf : Buf.t) (self : t) : unit =
+    let name, data = self in
+    let name = truncate_string name in
+    let size = size_word self in
+
+    (* part of header with argument name + size *)
+    let hd_arg_size =
+      I64.(
+        (of_int size lsl 4)
+        lor (of_int (Str_ref.inline (String.length name)) lsl 16))
+    in
+
+    match data with
+    | A_none ->
+      let hd = hd_arg_size in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name
+    | A_int i when is_i32_ i ->
+      let hd = I64.(1L lor hd_arg_size lor (of_int i lsl 32)) in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name
+    | A_int i ->
+      (* int64 *)
+      let hd = I64.(3L lor hd_arg_size) in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name;
+      Buf.add_i64 buf (I64.of_int i)
+    | A_float f ->
+      let hd = I64.(5L lor hd_arg_size) in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name;
+      Buf.add_i64 buf (I64.bits_of_float f)
+    | A_string s ->
+      let s = truncate_string s in
+      let hd =
+        I64.(
+          6L lor hd_arg_size
+          lor (of_int (Str_ref.inline (String.length s)) lsl 32))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name;
+      Buf.add_string buf s
+    | A_bool b ->
+      let hd = I64.(9L lor hd_arg_size lor (of_int (int_of_bool b) lsl 16)) in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name
+    | A_kid kid ->
+      (* int64 *)
+      let hd = I64.(8L lor hd_arg_size) in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name;
+      Buf.add_i64 buf kid
+end
+
+module Arguments = struct
+  type t = Argument.t list
+
+  let[@inline] len (self : t) : int =
+    match self with
+    | [] -> 0
+    | [ _ ] -> 1
+    | _ :: _ :: tl -> 2 + List.length tl
+
+  let check_valid (self : t) =
+    let len = len self in
+    if len > 15 then
+      invalid_arg (spf "fuchsia: can have at most 15 args, got %d" len);
+    List.iter Argument.check_valid_ self;
+    ()
+
+  let[@inline] size_word (self : t) =
+    match self with
+    | [] -> 0
+    | [ a ] -> Argument.size_word a
+    | a :: b :: tl ->
+      List.fold_left
+        (fun n arg -> n + Argument.size_word arg)
+        (Argument.size_word a + Argument.size_word b)
+        tl
+
+  let[@inline] encode (buf : Buf.t) (self : t) =
+    let rec aux buf l =
+      match l with
+      | [] -> ()
+      | x :: tl ->
+        Argument.encode buf x;
+        aux buf tl
+    in
+
+    match self with
+    | [] -> ()
+    | [ x ] -> Argument.encode buf x
+    | x :: tl ->
+      Argument.encode buf x;
+      aux buf tl
+end
+
+(** record type = 3 *)
+module Thread_record = struct
+  let size_word : int = 3
+
+  (** Record that [Thread_ref.ref as_ref] represents the pair [pid, tid] *)
+  let encode (bufs : Buf_chain.t) ~as_ref ~pid ~tid () : unit =
+    if as_ref <= 0 || as_ref > 255 then
+      invalid_arg "fuchsia: thread_record: invalid ref";
+
+    let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in
+
+    let hd = I64.(3L lor (of_int size_word lsl 4) lor (of_int as_ref lsl 16)) in
+    Buf.add_i64 buf hd;
+    Buf.add_i64 buf (I64.of_int pid);
+    Buf.add_i64 buf (I64.of_int tid)
+end
+
+(** record type = 4 *)
+module Event = struct
+  (** type=0 *)
+  module Instant = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args
+        () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      (* set category = 0 *)
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      ()
+  end
+
+  (** type=1 *)
+  module Counter = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args + 1 (* counter id *)
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args
+        () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (1L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      (* just use 0 as counter id *)
+      Buf.add_i64 buf 0L;
+      ()
+  end
+
+  (** type=2 *)
+  module Duration_begin = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args
+        () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (2L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      ()
+  end
+
+  (** type=3 *)
+  module Duration_end = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args
+        () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (3L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      ()
+  end
+
+  (** type=4 *)
+  module Duration_complete = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args + 1 (* end timestamp *)
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns
+        ~end_time_ns ~args () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      (* set category = 0 *)
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (4L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      Buf.add_i64 buf end_time_ns;
+      ()
+  end
+
+  (** type=5 *)
+  module Async_begin = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args + 1 (* async id *)
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns
+        ~(async_id : int64) ~args () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (5L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      Buf.add_i64 buf async_id;
+      ()
+  end
+
+  (** type=7 *)
+  module Async_end = struct
+    let size_word ~name ~t_ref ~args () : int =
+      1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name
+      + Arguments.size_word args + 1 (* async id *)
+
+    let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns
+        ~(async_id : int64) ~args () : unit =
+      let name = truncate_string name in
+      let size = size_word ~name ~t_ref ~args () in
+      let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (7L lsl 16)
+          lor (of_int (Arguments.len args) lsl 20)
+          lor (of_int (Thread_ref.as_i8 t_ref) lsl 24)
+          lor (of_int (Str_ref.inline (String.length name)) lsl 48))
+      in
+      Buf.add_i64 buf hd;
+      Buf.add_i64 buf time_ns;
+
+      (match t_ref with
+      | Thread_ref.Inline { pid; tid } ->
+        Buf.add_i64 buf (I64.of_int pid);
+        Buf.add_i64 buf (I64.of_int tid)
+      | Thread_ref.Ref _ -> ());
+
+      Buf.add_string buf name;
+      Arguments.encode buf args;
+      Buf.add_i64 buf async_id;
+      ()
+  end
+end
+
+(** record type = 7 *)
+module Kernel_object = struct
+  let size_word ~name ~args () : int =
+    1 + 1 + str_len_word name + Arguments.size_word args
+
+  (* see:
+     https://cs.opensource.google/fuchsia/fuchsia/+/main:zircon/system/public/zircon/types.h;l=441?q=ZX_OBJ_TYPE&ss=fuchsia%2Ffuchsia
+  *)
+
+  type ty = int
+
+  let ty_process : ty = 1
+  let ty_thread : ty = 2
+
+  let encode (bufs : Buf_chain.t) ~name ~(ty : ty) ~(kid : int) ~args () : unit
+      =
+    let name = truncate_string name in
+    let size = size_word ~name ~args () in
+    let@ buf = Buf_chain.with_buf bufs ~available_word:size in
+
+    let hd =
+      I64.(
+        7L
+        lor (of_int size lsl 4)
+        lor (of_int ty lsl 16)
+        lor (of_int (Arguments.len args) lsl 40)
+        lor (of_int (Str_ref.inline (String.length name)) lsl 24))
+    in
+    Buf.add_i64 buf hd;
+    Buf.add_i64 buf (I64.of_int kid);
+    Buf.add_string buf name;
+    Arguments.encode buf args;
+    ()
+end

src/ppx/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_trace)
+ (public_name ppx_trace)
+ (kind ppx_rewriter)
+ (preprocess
+  (pps ppxlib.metaquot))
+ (ppx_runtime_libraries trace.core)
+ (libraries ppxlib))

src/ppx/ppx_trace.ml

@@ -0,0 +1,114 @@
+open Ppxlib
+
+let location_errorf ~loc fmt =
+  Format.kasprintf
+    (fun err ->
+      raise (Ocaml_common.Location.Error (Ocaml_common.Location.error ~loc err)))
+    fmt
+
+(** {2 let expression} *)
+
+let expand_let ~ctxt (var : [ `Var of label loc | `Unit ]) (name : string) body
+    =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  Ast_builder.Default.(
+    let var_pat =
+      match var with
+      | `Var v -> ppat_var ~loc:v.loc v
+      | `Unit -> ppat_var ~loc { loc; txt = "_trace_span" }
+    in
+    let var_exp =
+      match var with
+      | `Var v -> pexp_ident ~loc:v.loc { txt = lident v.txt; loc = v.loc }
+      | `Unit -> [%expr _trace_span]
+    in
+    [%expr
+      let [%p var_pat] =
+        Trace_core.enter_span ~__FILE__ ~__LINE__ [%e estring ~loc name]
+      in
+      try
+        let res = [%e body] in
+        Trace_core.exit_span [%e var_exp];
+        res
+      with exn ->
+        Trace_core.exit_span [%e var_exp];
+        raise exn])
+
+let extension_let =
+  Extension.V3.declare "trace" Extension.Context.expression
+    (let open! Ast_pattern in
+     single_expr_payload
+       (pexp_let nonrecursive
+          (value_binding ~constraint_:none
+             ~pat:
+               (let pat_var = ppat_var __' |> map ~f:(fun f v -> f (`Var v)) in
+                let pat_unit =
+                  as__ @@ ppat_construct (lident (string "()")) none
+                  |> map ~f:(fun f _ -> f `Unit)
+                in
+                alt pat_var pat_unit)
+             ~expr:(estring __)
+          ^:: nil)
+          __))
+    expand_let
+
+let rule_let = Ppxlib.Context_free.Rule.extension extension_let
+
+(** {2 Toplevel binding} *)
+
+let expand_top_let ~ctxt rec_flag (vbs : _ list) =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  Ast_builder.Default.(
+    (* go in functions, and add tracing around the body *)
+    let rec push_into_fun (e : expression) : expression =
+      match e.pexp_desc with
+      | Pexp_function (args, ty, Pfunction_body body) ->
+        pexp_function ~loc args ty @@ Pfunction_body (push_into_fun body)
+      | Pexp_function (_args, _ty, Pfunction_cases _) ->
+        (* explicitly fail on [let%trace foo = function …], for now *)
+        Ast_helper.Exp.extension
+          ( { txt = "ocaml.error"; loc },
+            PStr
+              [
+                pstr_eval ~loc
+                  (pexp_constant ~loc
+                     (Pconst_string
+                        ( "ppxtrace: cannot trace `function`, please unsugar \
+                           to `fun`+`match`.",
+                          loc,
+                          None )))
+                  [];
+              ] )
+      | _ ->
+        [%expr
+          let _trace_span =
+            Trace_core.enter_span ~__FILE__ ~__LINE__ __FUNCTION__
+          in
+          match [%e e] with
+          | res ->
+            Trace_core.exit_span _trace_span;
+            res
+          | exception exn ->
+            let bt = Stdlib.Printexc.get_raw_backtrace () in
+            Trace_core.exit_span _trace_span;
+            Stdlib.Printexc.raise_with_backtrace exn bt]
+    in
+
+    let tr_vb (vb : value_binding) : value_binding =
+      let expr = push_into_fun vb.pvb_expr in
+      { vb with pvb_expr = expr }
+    in
+
+    let vbs = List.map tr_vb vbs in
+    pstr_value ~loc rec_flag vbs)
+
+let extension_top_let =
+  Extension.V3.declare "trace" Extension.Context.structure_item
+    (let open! Ast_pattern in
+     pstr (pstr_value __ __ ^:: nil))
+    expand_top_let
+
+let rule_top_let = Ppxlib.Context_free.Rule.extension extension_top_let
+
+let () =
+  Driver.register_transformation ~rules:[ rule_let; rule_top_let ] "ppx_trace"

src/runtime-events/dune

@@ -0,0 +1,8 @@
+(library
+ (name trace_runtime_events)
+ (public_name trace-runtime-events)
+ (synopsis "Simple collector that emits events via Runtime_events")
+ (libraries
+  trace.core
+  trace.util
+  (re_export runtime_events)))

src/runtime-events/trace_runtime_events.ml

@@ -0,0 +1,151 @@
+(** Simple backend that emits trace events via Runtime_events.
+
+    This backend allows trace spans, messages, and metrics to be collected by
+    external tools using the OCaml Runtime_events system. *)
+
+open Trace_core
+
+(* Register custom event types for strings *)
+module String_type = struct
+  let max_len = 1024
+
+  let encode buf s =
+    let len = min (String.length s) (max_len - 1) in
+    Bytes.blit_string s 0 buf 0 len;
+    len
+
+  let decode buf len = Bytes.sub_string buf 0 len
+  let ty = Runtime_events.Type.register ~encode ~decode
+end
+
+module String_int = struct
+  let max_len = 1024
+
+  let encode buf (s, i) =
+    let len = min (String.length s) (max_len - 9) in
+    Bytes.set_int64_le buf 0 (Int64.of_int i);
+    Bytes.blit_string s 0 buf 8 len;
+    len + 8
+
+  let decode buf len =
+    let i = Bytes.get_int64_le buf 0 in
+    Bytes.sub_string buf 8 (len - 8), Int64.to_int i
+
+  let ty = Runtime_events.Type.register ~encode ~decode
+end
+
+module String_float = struct
+  let max_len = 1024
+
+  let encode buf (s, f) =
+    let len = min (String.length s) (max_len - 9) in
+    Bytes.set_int64_le buf 0 (Int64.bits_of_float f);
+    Bytes.blit_string s 0 buf 8 len;
+    len + 8
+
+  let decode buf len =
+    let i = Bytes.get_int64_le buf 0 in
+    Bytes.sub_string buf 8 (len - 8), Int64.float_of_bits i
+
+  let ty = Runtime_events.Type.register ~encode ~decode
+end
+
+module Events = struct
+  (* Define event tags *)
+  type Runtime_events.User.tag +=
+    | Tag_span_enter
+    | Tag_span_exit
+    | Tag_message
+    | Tag_metric_int
+    | Tag_metric_float
+
+  (* Register user events *)
+  let span_enter_event =
+    Runtime_events.User.register "trace.span.enter" Tag_span_enter
+      String_type.ty
+
+  let span_exit_event =
+    Runtime_events.User.register "trace.span.exit" Tag_span_exit String_type.ty
+
+  let message_event =
+    Runtime_events.User.register "trace.message" Tag_message String_type.ty
+
+  let metric_int_event =
+    Runtime_events.User.register "trace.metric.int" Tag_metric_int String_int.ty
+
+  let metric_float_event =
+    Runtime_events.User.register "trace.metric.float" Tag_metric_float
+      String_float.ty
+end
+
+(* Span representation *)
+type span_info = { name: string }
+type Trace_core.span += Span_runtime_events of span_info
+
+(* Collector state *)
+type st = {
+  active: bool Trace_core.Internal_.Atomic_.t;
+  start_events: bool;
+}
+
+let create ?(start_events = true) () : st =
+  { active = Trace_core.Internal_.Atomic_.make true; start_events }
+
+(* Collector callbacks *)
+let init (self : st) = if self.start_events then Runtime_events.start ()
+
+let shutdown (self : st) =
+  Trace_core.Internal_.Atomic_.set self.active false;
+  Runtime_events.pause ()
+
+let enabled _ _ = true
+
+let enter_span (_self : st) ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~level:_
+    ~params:_ ~data:_ ~parent:_ name : span =
+  Runtime_events.User.write Events.span_enter_event name;
+  Span_runtime_events { name }
+
+let exit_span (_self : st) sp =
+  match sp with
+  | Span_runtime_events info ->
+    Runtime_events.User.write Events.span_exit_event info.name
+  | _ -> ()
+
+let add_data_to_span _st _sp _data =
+  (* Runtime_events doesn't support adding data to spans after creation,
+     so we just ignore this *)
+  ()
+
+let message (_self : st) ~level:_ ~params:_ ~data:_ ~span:_ msg : unit =
+  Runtime_events.User.write Events.message_event msg
+
+let metric (_self : st) ~level:_ ~params:_ ~data:_ name m : unit =
+  match m with
+  | Core_ext.Metric_int n ->
+    Runtime_events.User.write Events.metric_int_event (name, n)
+  | Core_ext.Metric_float f ->
+    Runtime_events.User.write Events.metric_float_event (name, f)
+  | _ -> ()
+
+let extension _self ~level:_ _ev =
+  (* Extension events like set_thread_name, set_process_name could be
+     emitted as custom events if needed *)
+  ()
+
+(* Create collector *)
+let callbacks : st Collector.Callbacks.t =
+  Collector.Callbacks.make ~init ~shutdown ~enabled ~enter_span ~exit_span
+    ~add_data_to_span ~message ~metric ~extension ()
+
+let collector ?(start_events = true) () : Collector.t =
+  let st = create ~start_events () in
+  Collector.C_some (st, callbacks)
+
+(* Setup function *)
+let setup ?(start_events = true) () =
+  Trace_core.setup_collector (collector ~start_events ())
+
+(* Convenience wrapper *)
+let with_setup ?start_events f =
+  setup ?start_events ();
+  Fun.protect ~finally:Trace_core.shutdown f

src/runtime-events/trace_runtime_events.mli

@@ -0,0 +1,55 @@
+(** Simple collector that emits trace events via Runtime_events.
+
+    @since 0.12 *)
+
+(** {2 Event types for decoding} *)
+
+module String_type : sig
+  val ty : string Runtime_events.Type.t
+end
+
+module String_int : sig
+  val ty : (string * int) Runtime_events.Type.t
+end
+
+module String_float : sig
+  val ty : (string * float) Runtime_events.Type.t
+end
+
+(** Custom events *)
+module Events : sig
+  type Runtime_events.User.tag +=
+    | Tag_span_enter
+    | Tag_span_exit
+    | Tag_message
+    | Tag_metric_int
+    | Tag_metric_float
+
+  val span_enter_event : string Runtime_events.User.t
+  val span_exit_event : string Runtime_events.User.t
+  val message_event : string Runtime_events.User.t
+  val metric_int_event : (string * int) Runtime_events.User.t
+  val metric_float_event : (string * float) Runtime_events.User.t
+end
+
+(** {2 Collector} *)
+
+val collector : ?start_events:bool -> unit -> Trace_core.Collector.t
+(** [collector ~start_events ()] creates a new collector that emits events via
+    Runtime_events.
+
+    @param start_events
+      if [true] (default), automatically call [Runtime_events.start()] when the
+      collector is initialized. *)
+
+val setup : ?start_events:bool -> unit -> unit
+(** [setup ~start_events ()] sets up the Runtime_events collector as the global
+    collector.
+
+    See {!collector} *)
+
+val with_setup : ?start_events:bool -> (unit -> 'a) -> 'a
+(** [with_setup ~start_events f] runs [f ()] with the Runtime_events collector
+    enabled, and shuts it down when done.
+
+    See {!collector} *)

src/simple/dune

@@ -0,0 +1,5 @@
+(library
+ (name trace_simple)
+ (public_name trace.simple)
+ (synopsis "simple type for spans")
+ (libraries trace.core trace.util))

src/simple/simple_span.ml

@@ -0,0 +1,33 @@
+(** A simple span.
+
+    This is a concrete representation of spans that is convenient to manipulate.
+
+    @since 0.11 *)
+
+open Trace_core
+
+type span_flavor =
+  [ `Sync
+  | `Async
+  ]
+
+type t = {
+  name: string;
+  __FUNCTION__: string option;
+  __FILE__: string;
+  __LINE__: int;
+  time_ns: int64;  (** Time the span was entered. *)
+  mutable time_exit_ns: int64;
+      (** Time the span was exited. Set at exit, [Int64.max_int] otherwise *)
+  tid: int;  (** Thread in which span was created *)
+  trace_id: int64;  (** For async spans *)
+  parent: parent;
+  flavor: span_flavor;
+  params: extension_parameter list;
+  mutable data: (string * Trace_core.user_data) list;
+      (** Modified by [add_data_to_span] *)
+}
+(** The type of spans used by all subscribers. *)
+
+type Trace_core.span +=
+  | Span_simple of t  (** How to turn a {!Simple_span.t} into a {!span}. *)

src/tef-tldrs/dune

@@ -0,0 +1,5 @@
+(library
+ (name trace_tef_tldrs)
+ (public_name trace-tef.tldrs)
+ (synopsis "Multiprocess tracing using the `tldrs` daemon")
+ (libraries trace.core trace.util trace-tef unix threads))

src/tef-tldrs/trace_tef_tldrs.ml

@@ -0,0 +1,141 @@
+open Trace_core
+
+let spf = Printf.sprintf
+let fpf = Printf.fprintf
+
+type output = [ `File of string ]
+
+(** Env variable used to communicate to subprocesses, which trace ID to use *)
+let env_var_trace_id = "TRACE_TEF_TLDR_TRACE_ID"
+
+(** Env variable used to communicate to subprocesses, which trace ID to use *)
+let env_var_unix_socket = "TRACE_TEF_TLDR_SOCKET"
+
+let get_unix_socket () =
+  match Sys.getenv_opt env_var_unix_socket with
+  | Some s -> s
+  | None ->
+    let s = "/tmp/tldrs.socket" in
+    (* children must agree on the socket file *)
+    Unix.putenv env_var_unix_socket s;
+    s
+
+type as_client = {
+  trace_id: string;
+  socket: string;  (** Unix socket address *)
+  emit_tef_at_exit: string option;
+      (** For parent, ask daemon to emit traces here *)
+}
+
+type role = as_client option
+
+let to_hex (s : string) : string =
+  let open String in
+  let i_to_hex (i : int) =
+    if i < 10 then
+      Char.chr (i + Char.code '0')
+    else
+      Char.chr (i - 10 + Char.code 'a')
+  in
+
+  let res = Bytes.create (2 * length s) in
+  for i = 0 to length s - 1 do
+    let n = Char.code (get s i) in
+    Bytes.set res (2 * i) (i_to_hex ((n land 0xf0) lsr 4));
+    Bytes.set res ((2 * i) + 1) (i_to_hex (n land 0x0f))
+  done;
+  Bytes.unsafe_to_string res
+
+let create_trace_id () : string =
+  let now = Unix.gettimeofday () in
+  let rand = Random.State.make_self_init () in
+
+  let rand_bytes = Bytes.create 16 in
+  for i = 0 to Bytes.length rand_bytes - 1 do
+    Bytes.set rand_bytes i (Random.State.int rand 256 |> Char.chr)
+  done;
+  (* convert to hex *)
+  spf "tr-%d-%s" (int_of_float now) (to_hex @@ Bytes.unsafe_to_string rand_bytes)
+
+(** Find what this particular process has to do wrt tracing *)
+let find_role ~out () : role =
+  match Sys.getenv_opt env_var_trace_id with
+  | Some trace_id ->
+    Some { trace_id; emit_tef_at_exit = None; socket = get_unix_socket () }
+  | None ->
+    let write_to_file path =
+      (* normalize path so the daemon knows what we're talking about *)
+      let path =
+        if Filename.is_relative path then
+          Filename.concat (Unix.getcwd ()) path
+        else
+          path
+      in
+      let trace_id = create_trace_id () in
+      Unix.putenv env_var_trace_id trace_id;
+      { trace_id; emit_tef_at_exit = Some path; socket = get_unix_socket () }
+    in
+
+    (match out with
+    | `File path -> Some (write_to_file path)
+    | `Env ->
+      (match Sys.getenv_opt "TRACE" with
+      | Some ("1" | "true") -> Some (write_to_file "trace.json")
+      | Some path -> Some (write_to_file path)
+      | None -> None))
+
+let collector_ (client : as_client) : Collector.t =
+  (* connect to unix socket *)
+  let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  (try Unix.connect sock (Unix.ADDR_UNIX client.socket)
+   with exn ->
+     failwith
+     @@ spf "Could not open socket to `tldrs` demon at %S: %s" client.socket
+          (Printexc.to_string exn));
+  let out = Unix.out_channel_of_descr sock in
+
+  (* what to do when the collector shuts down *)
+  let finally () =
+    (try flush out with _ -> ());
+    try Unix.close sock with _ -> ()
+  in
+
+  fpf out "OPEN %s\n%!" client.trace_id;
+  (* ask the collector to emit the trace in a user-chosen file, perhaps *)
+  Option.iter
+    (fun file -> fpf out "EMIT_TEF_AT_EXIT %s\n" file)
+    client.emit_tef_at_exit;
+
+  Trace_tef.Private_.collector_jsonl ~finally ~out:(`Output out) ()
+
+let collector ~out () : collector =
+  let role = find_role ~out () in
+  match role with
+  | None -> assert false
+  | Some c -> collector_ c
+
+open struct
+  let register_atexit =
+    let has_registered = ref false in
+    fun () ->
+      if not !has_registered then (
+        has_registered := true;
+        at_exit Trace_core.shutdown
+      )
+end
+
+let setup ?(out = `Env) () =
+  let role = find_role ~out () in
+  match role with
+  | None -> ()
+  | Some c ->
+    register_atexit ();
+    Trace_core.setup_collector @@ collector_ c
+
+let with_setup ?out () f =
+  setup ?out ();
+  Fun.protect ~finally:Trace_core.shutdown f
+
+module Private_ = struct
+  include Trace_tef.Private_
+end

src/tef-tldrs/trace_tef_tldrs.mli

@@ -0,0 +1,38 @@
+(** Emit traces by talking to the {{:https://github.com/imandra-ai/tldrs} tldrs}
+    daemon *)
+
+val collector : out:[ `File of string ] -> unit -> Trace_core.collector
+(** Make a collector that writes into the given output. See {!setup} for more
+    details. *)
+
+type output = [ `File of string ]
+(** Output for tracing.
+    - [`File "foo"] will enable tracing and print events into file named "foo".
+      The file is only written at exit. *)
+
+val setup : ?out:[ output | `Env ] -> unit -> unit
+(** [setup ()] installs the collector depending on [out].
+
+    @param out
+      can take different values:
+      - regular {!output} value to specify where events go
+      - [`Env] will enable tracing if the environment variable "TRACE" is set.
+
+    - If it's set to "1", then the file is "trace.json".
+    - If it's set to "stdout", then logging happens on stdout (since 0.2)
+    - If it's set to "stderr", then logging happens on stdout (since 0.2)
+    - Otherwise, if it's set to a non empty string, the value is taken to be the
+      file path into which to write. *)
+
+val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a
+(** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes
+    sure to shutdown before exiting. *)
+
+(**/**)
+
+module Private_ : sig
+  val mock_all_ : unit -> unit
+  (** use fake, deterministic timestamps, TID, PID *)
+end
+
+(**/**)

src/tef/b_queue.ml

@@ -1,73 +0,0 @@
-type 'a t = {
-  mutex: Mutex.t;
-  cond: Condition.t;
-  q: 'a Queue.t;
-  mutable closed: bool;
-}
-
-exception Closed
-
-let create () : _ t =
-  {
-    mutex = Mutex.create ();
-    cond = Condition.create ();
-    q = Queue.create ();
-    closed = false;
-  }
-
-let close (self : _ t) =
-  Mutex.lock self.mutex;
-  if not self.closed then (
-    self.closed <- true;
-    Condition.broadcast self.cond (* awake waiters so they fail  *)
-  );
-  Mutex.unlock self.mutex
-
-let push (self : _ t) x : unit =
-  Mutex.lock self.mutex;
-  if self.closed then (
-    Mutex.unlock self.mutex;
-    raise Closed
-  ) else (
-    let was_empty = Queue.is_empty self.q in
-    Queue.push x self.q;
-    if was_empty then Condition.broadcast self.cond;
-    Mutex.unlock self.mutex
-  )
-
-let pop (self : 'a t) : 'a =
-  Mutex.lock self.mutex;
-  let rec loop () =
-    if Queue.is_empty self.q then (
-      if self.closed then (
-        Mutex.unlock self.mutex;
-        raise Closed
-      );
-      Condition.wait self.cond self.mutex;
-      (loop [@tailcall]) ()
-    ) else (
-      let x = Queue.pop self.q in
-      Mutex.unlock self.mutex;
-      x
-    )
-  in
-  loop ()
-
-let transfer (self : 'a t) q2 : unit =
-  Mutex.lock self.mutex;
-  while
-    if Queue.is_empty self.q then (
-      if self.closed then (
-        Mutex.unlock self.mutex;
-        raise Closed
-      );
-      Condition.wait self.cond self.mutex;
-      true
-    ) else (
-      Queue.transfer self.q q2;
-      Mutex.unlock self.mutex;
-      false
-    )
-  do
-    ()
-  done

src/tef/b_queue.mli

@@ -1,23 +0,0 @@
-(** Basic Blocking Queue *)
-
-type 'a t
-
-val create : unit -> _ t
-
-exception Closed
-
-val push : 'a t -> 'a -> unit
-(** [push q x] pushes [x] into [q], and returns [()].
-    @raise Closed if [close q] was previously called.*)
-
-val pop : 'a t -> 'a
-(** [pop q] pops the next element in [q]. It might block until an element comes.
-   @raise Closed if the queue was closed before a new element was available. *)
-
-val transfer : 'a t -> 'a Queue.t -> unit
-(** [transfer bq q2] transfers all items presently
-    in [bq] into [q2], and clears [bq].
-    It blocks if no element is in [bq]. *)
-
-val close : _ t -> unit
-(** Close the queue, meaning there won't be any more [push] allowed. *)

src/tef/collector_tef.ml

@@ -0,0 +1,174 @@
+open Common_
+open Types
+open Trace_core
+
+module Buf_pool = struct
+  type t = Buffer.t Trace_util.Rpool.t
+
+  let create ?(max_size = 32) ?(buf_size = 256) () : t =
+    Trace_util.Rpool.create ~max_size ~clear:Buffer.reset
+      ~create:(fun () -> Buffer.create buf_size)
+      ()
+end
+
+open struct
+  let[@inline] time_us_of_time_ns (t : int64) : float =
+    Int64.div t 1_000L |> Int64.to_float
+end
+
+type t = {
+  active: bool A.t;
+  pid: int;
+  buf_pool: Buf_pool.t;
+  exporter: Exporter.t;
+  trace_id_gen: Trace_util.Trace_id64.Gen.t;
+}
+(** Subscriber state *)
+
+let close (self : t) : unit =
+  if A.exchange self.active false then
+    (* FIXME: print_non_closed_spans_warning self.spans; *)
+    self.exporter.close ()
+
+let[@inline] active self = A.get self.active
+let[@inline] flush (self : t) : unit = self.exporter.flush ()
+
+let create ?(buf_pool = Buf_pool.create ()) ~pid ~exporter () : t =
+  {
+    active = A.make true;
+    exporter;
+    buf_pool;
+    pid;
+    trace_id_gen = Trace_util.Trace_id64.Gen.create ();
+  }
+
+open struct
+  type st = t
+
+  let rec flavor_of_params = function
+    | [] -> `Sync
+    | Core_ext.Extension_span_flavor f :: _ -> f
+    | _ :: tl -> flavor_of_params tl
+
+  let new_trace_id (self : st) = Trace_util.Trace_id64.Gen.gen self.trace_id_gen
+  let init _ = ()
+  let shutdown (self : st) = close self
+
+  (* add function name, if provided, to the metadata *)
+  let add_fun_name_ fun_name data : _ list =
+    match fun_name with
+    | None -> data
+    | Some f -> ("function", `String f) :: data
+
+  let enter_span (self : st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level:_ ~params
+      ~data ~parent name : span =
+    let start_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
+    let flavor = flavor_of_params params in
+
+    let pid = self.pid in
+    let tid = Trace_util.Mock_.get_tid () in
+    match flavor with
+    | `Sync -> Span_tef_sync { name; pid; tid; args = data; start_us }
+    | `Async ->
+      let trace_id =
+        match parent with
+        | P_some (Span_tef_async sp) -> sp.trace_id
+        | _ -> new_trace_id self
+      in
+      let data = add_fun_name_ __FUNCTION__ data in
+
+      (let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+       Writer.emit_begin_async buf ~name ~pid ~tid ~trace_id ~ts:start_us
+         ~args:data;
+       self.exporter.on_json buf);
+
+      Span_tef_async { pid; tid; trace_id; name; args = data }
+
+  let exit_span (self : st) sp =
+    let end_time_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
+
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    let did_write =
+      match sp with
+      | Span_tef_sync { name; pid; tid; args; start_us } ->
+        (* emit full event *)
+        Writer.emit_duration_event buf ~pid ~tid ~name ~start:start_us
+          ~end_:end_time_us ~args;
+        true
+      | Span_tef_async { name; trace_id; pid; tid; args } ->
+        Writer.emit_end_async buf ~pid ~tid ~name ~trace_id ~ts:end_time_us
+          ~args;
+        true
+      | _ -> false
+    in
+
+    if did_write then self.exporter.on_json buf
+
+  let message (self : st) ~level:_ ~params:_ ~data ~span:_ msg : unit =
+    let tid = Trace_util.Mock_.get_tid () in
+    let time_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_instant_event buf ~pid:self.pid ~tid ~name:msg ~ts:time_us
+      ~args:data;
+    self.exporter.on_json buf
+
+  let counter_float (self : st) ~params:_ ~data:_ name n : unit =
+    let tid = Trace_util.Mock_.get_tid () in
+    let time_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_counter buf ~pid:self.pid ~name ~tid ~ts:time_us n;
+    self.exporter.on_json buf
+
+  let metric (self : st) ~level:_ ~params ~data name m : unit =
+    match m with
+    | Core_ext.Metric_float n -> counter_float self ~params ~data name n
+    | Core_ext.Metric_int i ->
+      counter_float self ~params ~data name (float_of_int i)
+    | _ -> ()
+
+  let add_data_to_span _st sp data =
+    match sp with
+    | Span_tef_sync sp -> sp.args <- List.rev_append data sp.args
+    | Span_tef_async sp -> sp.args <- List.rev_append data sp.args
+    | _ -> ()
+
+  let on_name_thread_ (self : st) ~tid name : unit =
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_name_thread buf ~pid:self.pid ~tid ~name;
+    self.exporter.on_json buf
+
+  let on_name_process_ (self : st) name : unit =
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_name_process ~pid:self.pid ~name buf;
+    self.exporter.on_json buf
+
+  let on_thread_sort_index_ (self : st) ~tid i : unit =
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_thread_sort_index ~pid:self.pid ~tid i buf;
+    self.exporter.on_json buf
+
+  let on_process_sort_index_ (self : st) i : unit =
+    let@ buf = Trace_util.Rpool.with_ self.buf_pool in
+    Writer.emit_process_sort_index ~pid:self.pid i buf;
+    self.exporter.on_json buf
+
+  let extension (self : st) ~level:_ ev =
+    match ev with
+    | Core_ext.Extension_set_thread_name name ->
+      let tid = Trace_util.Mock_.get_tid () in
+      on_name_thread_ self ~tid name
+    | Core_ext.Extension_set_process_name name -> on_name_process_ self name
+    | Core_ext.Extension_set_process_sort_index idx ->
+      on_process_sort_index_ self idx
+    | Core_ext.Extension_set_thread_sort_index idx ->
+      let tid = Trace_util.Mock_.get_tid () in
+      on_thread_sort_index_ self ~tid idx
+    | _ -> ()
+end
+
+let callbacks_collector : _ Collector.Callbacks.t =
+  Collector.Callbacks.make ~init ~shutdown ~enter_span ~exit_span ~message
+    ~add_data_to_span ~metric ~extension ()
+
+let collector (self : t) : Collector.t =
+  Collector.C_some (self, callbacks_collector)

src/tef/collector_tef.mli

@@ -0,0 +1,23 @@
+open Trace_core
+
+module Buf_pool : sig
+  type t
+
+  val create : ?max_size:int -> ?buf_size:int -> unit -> t
+end
+
+type t
+(** Main state. *)
+
+val create : ?buf_pool:Buf_pool.t -> pid:int -> exporter:Exporter.t -> unit -> t
+(** Create a fresh state. *)
+
+val flush : t -> unit
+val close : t -> unit
+val active : t -> bool
+
+val callbacks_collector : t Collector.Callbacks.t
+(** Callbacks used for the subscriber *)
+
+val collector : t -> Collector.t
+(** Subscriber that writes json into this writer *)

src/tef/common_.ml

@@ -0,0 +1,3 @@
+module A = Trace_core.Internal_.Atomic_
+
+let ( let@ ) = ( @@ )

src/tef/dune

@@ -1,6 +1,13 @@
-
 (library
-  (name trace_tef)
-  (public_name trace-tef)
-  (synopsis "Simple and lightweight tracing using TEF/Catapult format, in-process")
-  (libraries trace.core mtime mtime.clock.os unix threads))
+ (name trace_tef)
+ (public_name trace-tef)
+ (synopsis
+  "Simple and lightweight tracing using TEF/Catapult format, in-process")
+ (libraries
+  trace.core
+  trace.util
+  trace.debug
+  mtime
+  mtime.clock.os
+  unix
+  threads))

src/tef/exporter.ml

@@ -0,0 +1,73 @@
+open Common_
+
+type t = {
+  on_json: Buffer.t -> unit;
+  flush: unit -> unit;
+  close: unit -> unit;
+}
+
+open struct
+  let with_lock lock f =
+    Mutex.lock lock;
+    try
+      let res = f () in
+      Mutex.unlock lock;
+      res
+    with e ->
+      let bt = Printexc.get_raw_backtrace () in
+      Mutex.unlock lock;
+      Printexc.raise_with_backtrace e bt
+end
+
+let of_out_channel ~close_channel ~jsonl oc : t =
+  let lock = Mutex.create () in
+  let first = ref true in
+  let closed = ref false in
+  let flush () =
+    let@ () = with_lock lock in
+    flush oc
+  in
+  let close () =
+    let@ () = with_lock lock in
+    if not !closed then (
+      closed := true;
+      if not jsonl then output_char oc ']';
+      if close_channel then close_out_noerr oc
+    )
+  in
+  let on_json buf =
+    let@ () = with_lock lock in
+    if not jsonl then
+      if !first then (
+        if not jsonl then output_char oc '[';
+        first := false
+      ) else
+        output_string oc ",\n";
+    Buffer.output_buffer oc buf;
+    if jsonl then output_char oc '\n'
+  in
+  { flush; close; on_json }
+
+let of_buffer ~jsonl (buf : Buffer.t) : t =
+  let lock = Mutex.create () in
+  let first = ref true in
+  let closed = ref false in
+  let close () =
+    let@ () = with_lock lock in
+    if not !closed then (
+      closed := true;
+      if not jsonl then Buffer.add_char buf ']'
+    )
+  in
+  let on_json json =
+    let@ () = with_lock lock in
+    if not jsonl then
+      if !first then (
+        if not jsonl then Buffer.add_char buf '[';
+        first := false
+      ) else
+        Buffer.add_string buf ",\n";
+    Buffer.add_buffer buf json;
+    if jsonl then Buffer.add_char buf '\n'
+  in
+  { flush = ignore; close; on_json }

src/tef/exporter.mli

@@ -0,0 +1,22 @@
+(** An exporter, takes JSON objects and writes them somewhere *)
+
+type t = {
+  on_json: Buffer.t -> unit;
+      (** Takes a buffer and writes it somewhere. The buffer is only valid
+          during this call and must not be stored. *)
+  flush: unit -> unit;  (** Force write *)
+  close: unit -> unit;  (** Close underlying resources *)
+}
+(** An exporter, takes JSON objects and writes them somewhere.
+
+    This should be thread-safe if used in a threaded environment. *)
+
+val of_out_channel : close_channel:bool -> jsonl:bool -> out_channel -> t
+(** Export to the channel
+    @param jsonl
+      if true, export as a JSON object per line, otherwise export as a single
+      big JSON array.
+    @param close_channel if true, closing the exporter will close the channel *)
+
+val of_buffer : jsonl:bool -> Buffer.t -> t
+(** Emit into the buffer *)

src/tef/trace_tef.ml

@@ -1,350 +1,33 @@
 open Trace_core
-module A = Trace_core.Internal_.Atomic_
+module Collector_tef = Collector_tef
+module Exporter = Exporter
+module Writer = Writer
+module Types = Types
 
-module Mock_ = struct
-  let enabled = ref false
-  let now = ref 0
-
-  let[@inline never] now_us () : float =
-    let x = !now in
-    incr now;
-    float_of_int x
-end
-
-let counter = Mtime_clock.counter ()
-
-(** Now, in microseconds *)
-let now_us () : float =
-  if !Mock_.enabled then
-    Mock_.now_us ()
-  else (
-    let t = Mtime_clock.count counter in
-    Mtime.Span.to_float_ns t /. 1e3
-  )
-
-let protect ~finally f =
+let block_signals () =
   try
-    let x = f () in
-    finally ();
-    x
-  with exn ->
-    let bt = Printexc.get_raw_backtrace () in
-    finally ();
-    Printexc.raise_with_backtrace exn bt
+    ignore
+      (Unix.sigprocmask SIG_BLOCK
+         [
+           Sys.sigterm;
+           Sys.sigpipe;
+           Sys.sigint;
+           Sys.sigchld;
+           Sys.sigalrm;
+           Sys.sigusr1;
+           Sys.sigusr2;
+         ]
+        : _ list)
+  with _ -> ()
 
-let on_tracing_error = ref (fun s -> Printf.eprintf "trace-tef error: %s\n%!" s)
-
-type event =
-  | E_tick
-  | E_message of {
-      tid: int;
-      msg: string;
-      time_us: float;
-      data: (string * user_data) list;
-    }
-  | E_define_span of {
-      tid: int;
-      name: string;
-      time_us: float;
-      id: span;
-      fun_name: string option;
-      data: (string * user_data) list;
-    }
-  | E_exit_span of {
-      id: span;
-      time_us: float;
-    }
-  | E_add_data of {
-      id: span;
-      data: (string * user_data) list;
-    }
-  | E_enter_manual_span of {
-      tid: int;
-      name: string;
-      time_us: float;
-      id: int;
-      flavor: [ `Sync | `Async ] option;
-      fun_name: string option;
-      data: (string * user_data) list;
-    }
-  | E_exit_manual_span of {
-      tid: int;
-      name: string;
-      time_us: float;
-      flavor: [ `Sync | `Async ] option;
-      data: (string * user_data) list;
-      id: int;
-    }
-  | E_counter of {
-      name: string;
-      tid: int;
-      time_us: float;
-      n: float;
-    }
-  | E_name_process of { name: string }
-  | E_name_thread of {
-      tid: int;
-      name: string;
-    }
-
-module Span_tbl = Hashtbl.Make (struct
-  include Int64
-
-  let hash : t -> int = Hashtbl.hash
-end)
-
-type span_info = {
-  tid: int;
-  name: string;
-  start_us: float;
-  mutable data: (string * user_data) list;
-}
-
-(** key used to carry a unique "id" for all spans in an async context *)
-let key_async_id : int Meta_map.Key.t = Meta_map.Key.create ()
-
-let key_async_data : (string * [ `Sync | `Async ] option) Meta_map.Key.t =
-  Meta_map.Key.create ()
-
-let key_data : (string * user_data) list ref Meta_map.Key.t =
-  Meta_map.Key.create ()
-
-(** Writer: knows how to write entries to a file in TEF format *)
-module Writer = struct
-  type t = {
-    oc: out_channel;
-    mutable first: bool;  (** first event? *)
-    must_close: bool;  (** Do we have to close the underlying channel [oc]? *)
-    pid: int;
-  }
-  (** A writer to a [out_channel]. It writes JSON entries in an array
-      and closes the array at the end. *)
-
-  let create ~out () : t =
-    let oc, must_close =
-      match out with
-      | `Stdout -> stdout, false
-      | `Stderr -> stderr, false
-      | `File path -> open_out path, true
-    in
-    let pid =
-      if !Mock_.enabled then
-        2
-      else
-        Unix.getpid ()
-    in
-    output_char oc '[';
-    { oc; first = true; pid; must_close }
-
-  let close (self : t) : unit =
-    output_char self.oc ']';
-    flush self.oc;
-    if self.must_close then close_out self.oc
-
-  let with_ ~out f =
-    let writer = create ~out () in
-    protect ~finally:(fun () -> close writer) (fun () -> f writer)
-
-  let[@inline] flush (self : t) : unit = flush self.oc
-
-  let emit_sep_ (self : t) =
-    if self.first then
-      self.first <- false
-    else
-      output_string self.oc ",\n"
-
-  let char = output_char
-  let raw_string = output_string
-
-  let str_val oc (s : string) =
-    char oc '"';
-    let encode_char c =
-      match c with
-      | '"' -> raw_string oc {|\"|}
-      | '\\' -> raw_string oc {|\\|}
-      | '\n' -> raw_string oc {|\n|}
-      | '\b' -> raw_string oc {|\b|}
-      | '\r' -> raw_string oc {|\r|}
-      | '\t' -> raw_string oc {|\t|}
-      | _ when Char.code c <= 0x1f ->
-        raw_string oc {|\u00|};
-        Printf.fprintf oc "%02x" (Char.code c)
-      | c -> char oc c
-    in
-    String.iter encode_char s;
-    char oc '"'
-
-  let pp_user_data_ out : [< user_data ] -> unit = function
-    | `None -> Printf.fprintf out "null"
-    | `Int i -> Printf.fprintf out "%d" i
-    | `Bool b -> Printf.fprintf out "%b" b
-    | `String s -> str_val out s
-    | `Float f -> Printf.fprintf out "%g" f
-
-  (* emit args, if not empty. [ppv] is used to print values. *)
-  let emit_args_o_ ppv oc args : unit =
-    if args <> [] then (
-      Printf.fprintf oc {json|,"args": {|json};
-      List.iteri
-        (fun i (n, value) ->
-          if i > 0 then Printf.fprintf oc ",";
-          Printf.fprintf oc {json|"%s":%a|json} n ppv value)
-        args;
-      char oc '}'
-    )
-
-  let emit_duration_event ~tid ~name ~start ~end_ ~args (self : t) : unit =
-    let dur = end_ -. start in
-    let ts = start in
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json}
-      self.pid tid dur ts str_val name
-      (emit_args_o_ pp_user_data_)
-      args;
-    ()
-
-  let emit_manual_begin ~tid ~name ~id ~ts ~args ~flavor (self : t) : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"cat":"trace","id":%d,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json}
-      self.pid id tid ts str_val name
-      (match flavor with
-      | None | Some `Async -> 'b'
-      | Some `Sync -> 'B')
-      (emit_args_o_ pp_user_data_)
-      args;
-    ()
-
-  let emit_manual_end ~tid ~name ~id ~ts ~flavor ~args (self : t) : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"cat":"trace","id":%d,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json}
-      self.pid id tid ts str_val name
-      (match flavor with
-      | None | Some `Async -> 'e'
-      | Some `Sync -> 'E')
-      (emit_args_o_ pp_user_data_)
-      args;
-
-    ()
-
-  let emit_instant_event ~tid ~name ~ts ~args (self : t) : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"I"%a}|json}
-      self.pid tid ts str_val name
-      (emit_args_o_ pp_user_data_)
-      args;
-    ()
-
-  let emit_name_thread ~tid ~name (self : t) : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"tid": %d,"name":"thread_name","ph":"M"%a}|json} self.pid
-      tid
-      (emit_args_o_ pp_user_data_)
-      [ "name", `String name ];
-    ()
-
-  let emit_name_process ~name (self : t) : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"name":"process_name","ph":"M"%a}|json} self.pid
-      (emit_args_o_ pp_user_data_)
-      [ "name", `String name ];
-    ()
-
-  let emit_counter ~name ~tid ~ts (self : t) f : unit =
-    emit_sep_ self;
-    Printf.fprintf self.oc
-      {json|{"pid":%d,"tid":%d,"ts":%.2f,"name":"c","ph":"C"%a}|json} self.pid
-      tid ts
-      (emit_args_o_ pp_user_data_)
-      [ name, `Float f ];
-    ()
-end
-
-(** Background thread, takes events from the queue, puts them
-    in context using local state, and writes fully resolved
-    TEF events to [out]. *)
-let bg_thread ~out (events : event B_queue.t) : unit =
-  (* open a writer to [out] *)
-  Writer.with_ ~out @@ fun writer ->
-  (* local state, to keep track of span information and implicit stack context *)
-  let spans : span_info Span_tbl.t = Span_tbl.create 32 in
-  let local_q = Queue.create () in
-
-  (* add function name, if provided, to the metadata *)
-  let add_fun_name_ fun_name data : _ list =
-    match fun_name with
-    | None -> data
-    | Some f -> ("function", `String f) :: data
-  in
-
-  (* how to deal with an event *)
-  let handle_ev (ev : event) : unit =
-    match ev with
-    | E_tick -> Writer.flush writer
-    | E_message { tid; msg; time_us; data } ->
-      Writer.emit_instant_event ~tid ~name:msg ~ts:time_us ~args:data writer
-    | E_define_span { tid; name; id; time_us; fun_name; data } ->
-      let data = add_fun_name_ fun_name data in
-      let info = { tid; name; start_us = time_us; data } in
-      (* save the span so we find it at exit *)
-      Span_tbl.add spans id info
-    | E_exit_span { id; time_us = stop_us } ->
-      (match Span_tbl.find_opt spans id with
-      | None -> !on_tracing_error (Printf.sprintf "cannot find span %Ld" id)
-      | Some { tid; name; start_us; data } ->
-        Span_tbl.remove spans id;
-        Writer.emit_duration_event ~tid ~name ~start:start_us ~end_:stop_us
-          ~args:data writer)
-    | E_add_data { id; data } ->
-      (match Span_tbl.find_opt spans id with
-      | None -> !on_tracing_error (Printf.sprintf "cannot find span %Ld" id)
-      | Some info -> info.data <- List.rev_append data info.data)
-    | E_enter_manual_span { tid; time_us; name; id; data; fun_name; flavor } ->
-      let data = add_fun_name_ fun_name data in
-      Writer.emit_manual_begin ~tid ~name ~id ~ts:time_us ~args:data ~flavor
-        writer
-    | E_exit_manual_span { tid; time_us; name; id; flavor; data } ->
-      Writer.emit_manual_end ~tid ~name ~id ~ts:time_us ~flavor ~args:data
-        writer
-    | E_counter { tid; name; time_us; n } ->
-      Writer.emit_counter ~name ~tid ~ts:time_us writer n
-    | E_name_process { name } -> Writer.emit_name_process ~name writer
-    | E_name_thread { tid; name } -> Writer.emit_name_thread ~tid ~name writer
-  in
-
-  try
-    while true do
-      (* work on local events, already on this thread *)
-      while not (Queue.is_empty local_q) do
-        let ev = Queue.pop local_q in
-        handle_ev ev
-      done;
-
-      (* get all the events in the incoming blocking queue, in
-         one single critical section. *)
-      B_queue.transfer events local_q
-    done
-  with B_queue.Closed ->
-    (* warn if app didn't close all spans *)
-    if Span_tbl.length spans > 0 then
-      Printf.eprintf "trace-tef: warning: %d spans were not closed\n%!"
-        (Span_tbl.length spans);
-    ()
-
-(** Thread that simply regularly "ticks", sending events to
-    the background thread so it has a chance to write to the file *)
-let tick_thread events : unit =
-  try
-    while true do
-      Thread.delay 0.5;
-      B_queue.push events E_tick
-    done
-  with B_queue.Closed -> ()
+(** Thread that simply regularly "ticks", sending events to the background
+    thread so it has a chance to write to the file *)
+let tick_thread (c : Collector_tef.t) : unit =
+  block_signals ();
+  while Collector_tef.active c do
+    Thread.delay 0.5;
+    Collector_tef.flush c
+  done
 
 type output =
   [ `Stdout
@@ -352,138 +35,88 @@ type output =
   | `File of string
   ]
 
-let collector ~out () : collector =
-  let module M = struct
-    let active = A.make true
+let collector_ ~(finally : unit -> unit) ~out ~(mode : [ `Single | `Jsonl ]) ()
+    : Collector.t =
+  let jsonl = mode = `Jsonl in
+  let oc, must_close =
+    match out with
+    | `Stdout -> stdout, false
+    | `Stderr -> stderr, false
+    | `File path -> open_out path, true
+    | `File_append path ->
+      open_out_gen [ Open_creat; Open_wronly; Open_append ] 0o644 path, true
+    | `Output oc -> oc, false
+  in
+  let pid = Trace_util.Mock_.get_pid () in
 
-    (** generator for span ids *)
-    let span_id_gen_ = A.make 0
+  let exporter = Exporter.of_out_channel oc ~jsonl ~close_channel:must_close in
+  let exporter =
+    {
+      exporter with
+      close =
+        (fun () ->
+          exporter.close ();
+          finally ());
+    }
+  in
+  let coll_st = Collector_tef.create ~pid ~exporter () in
+  let _t_tick : Thread.t = Thread.create tick_thread coll_st in
+  Collector_tef.collector coll_st
 
-    (* queue of messages to write *)
-    let events : event B_queue.t = B_queue.create ()
+let[@inline] collector ~out () : collector =
+  collector_ ~finally:ignore ~mode:`Single ~out ()
 
-    (** writer thread. It receives events and writes them to [oc]. *)
-    let t_write : Thread.t = Thread.create (fun () -> bg_thread ~out events) ()
-
-    (** ticker thread, regularly sends a message to the writer thread.
-         no need to join it. *)
-    let _t_tick : Thread.t = Thread.create (fun () -> tick_thread events) ()
-
-    let shutdown () =
-      if A.exchange active false then (
-        B_queue.close events;
-        (* wait for writer thread to be done. The writer thread will exit
-           after processing remaining events because the queue is now closed *)
-        Thread.join t_write
+open struct
+  let register_atexit =
+    let has_registered = ref false in
+    fun () ->
+      if not !has_registered then (
+        has_registered := true;
+        at_exit Trace_core.shutdown
       )
+end
 
-    let get_tid_ () : int =
-      if !Mock_.enabled then
-        3
+let setup ?(debug = false) ?(out = `Env) () =
+  register_atexit ();
+
+  let setup_col c =
+    let c =
+      if debug then
+        Trace_debug.Track_spans.track c
       else
-        Thread.id (Thread.self ())
+        c
+    in
+    Trace_core.setup_collector c
+  in
 
-    let with_span ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name f =
-      let span = Int64.of_int (A.fetch_and_add span_id_gen_ 1) in
-      let tid = get_tid_ () in
-      let time_us = now_us () in
-      B_queue.push events
-        (E_define_span { tid; name; time_us; id = span; fun_name; data });
-
-      let finally () =
-        let time_us = now_us () in
-        B_queue.push events (E_exit_span { id = span; time_us })
-      in
-
-      Fun.protect ~finally (fun () -> f span)
-
-    let add_data_to_span span data =
-      if data <> [] then B_queue.push events (E_add_data { id = span; data })
-
-    let enter_manual_span ~(parent : explicit_span option) ~flavor
-        ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name :
-        explicit_span =
-      (* get the id, or make a new one *)
-      let id =
-        match parent with
-        | Some m -> Meta_map.find_exn key_async_id m.meta
-        | None -> A.fetch_and_add span_id_gen_ 1
-      in
-      let time_us = now_us () in
-      B_queue.push events
-        (E_enter_manual_span
-           { id; time_us; tid = get_tid_ (); data; name; fun_name; flavor });
-      {
-        span = 0L;
-        meta =
-          Meta_map.(
-            empty |> add key_async_id id |> add key_async_data (name, flavor));
-      }
-
-    let exit_manual_span (es : explicit_span) : unit =
-      let id = Meta_map.find_exn key_async_id es.meta in
-      let name, flavor = Meta_map.find_exn key_async_data es.meta in
-      let data =
-        try !(Meta_map.find_exn key_data es.meta) with Not_found -> []
-      in
-      let time_us = now_us () in
-      let tid = get_tid_ () in
-      B_queue.push events
-        (E_exit_manual_span { tid; id; name; time_us; data; flavor })
-
-    let add_data_to_manual_span (es : explicit_span) data =
-      if data <> [] then (
-        let data_ref, add =
-          try Meta_map.find_exn key_data es.meta, false
-          with Not_found -> ref [], true
-        in
-        let new_data = List.rev_append data !data_ref in
-        data_ref := new_data;
-        if add then es.meta <- Meta_map.add key_data data_ref es.meta
-      )
-
-    let message ?span:_ ~data msg : unit =
-      let time_us = now_us () in
-      let tid = get_tid_ () in
-      B_queue.push events (E_message { tid; time_us; msg; data })
-
-    let counter_float ~data:_ name f =
-      let time_us = now_us () in
-      let tid = get_tid_ () in
-      B_queue.push events (E_counter { name; n = f; time_us; tid })
-
-    let counter_int ~data name i = counter_float ~data name (float_of_int i)
-    let name_process name : unit = B_queue.push events (E_name_process { name })
-
-    let name_thread name : unit =
-      let tid = get_tid_ () in
-      B_queue.push events (E_name_thread { tid; name })
-  end in
-  (module M)
-
-let setup ?(out = `Env) () =
   match out with
-  | `Stderr -> Trace_core.setup_collector @@ collector ~out:`Stderr ()
-  | `Stdout -> Trace_core.setup_collector @@ collector ~out:`Stdout ()
-  | `File path -> Trace_core.setup_collector @@ collector ~out:(`File path) ()
+  | `Stderr -> setup_col @@ collector ~out:`Stderr ()
+  | `Stdout -> setup_col @@ collector ~out:`Stdout ()
+  | `File path -> setup_col @@ collector ~out:(`File path) ()
   | `Env ->
     (match Sys.getenv_opt "TRACE" with
     | Some ("1" | "true") ->
       let path = "trace.json" in
       let c = collector ~out:(`File path) () in
-      Trace_core.setup_collector c
-    | Some "stdout" -> Trace_core.setup_collector @@ collector ~out:`Stdout ()
-    | Some "stderr" -> Trace_core.setup_collector @@ collector ~out:`Stderr ()
+      setup_col c
+    | Some "stdout" -> setup_col @@ collector ~out:`Stdout ()
+    | Some "stderr" -> setup_col @@ collector ~out:`Stderr ()
     | Some path ->
       let c = collector ~out:(`File path) () in
-      Trace_core.setup_collector c
+      setup_col c
     | None -> ())
 
-let with_setup ?out () f =
-  setup ?out ();
-  protect ~finally:Trace_core.shutdown f
+let with_setup ?debug ?out () f =
+  setup ?debug ?out ();
+  Fun.protect ~finally:Trace_core.shutdown f
 
-module Internal_ = struct
-  let mock_all_ () = Mock_.enabled := true
-  let on_tracing_error = on_tracing_error
+module Private_ = struct
+  let mock_all_ () =
+    Trace_util.Mock_.mock_all ();
+    ()
+
+  let collector_jsonl ~finally ~out () : collector =
+    collector_ ~finally ~mode:`Jsonl ~out ()
+
+  module Event = Event
 end

src/tef/trace_tef.mli

@@ -1,7 +1,15 @@
-val collector :
-  out:[ `File of string | `Stderr | `Stdout ] -> unit -> Trace_core.collector
-(** Make a collector that writes into the given output.
-    See {!setup} for more details. *)
+(** TEF collector for Trace.
+
+    This emits chrome traces
+    (https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/),
+    which are very simple and a known quantity.
+
+    They can be opened in https://ui.perfetto.dev . *)
+
+module Collector_tef = Collector_tef
+module Exporter = Exporter
+module Writer = Writer
+module Types = Types
 
 type output =
   [ `Stdout
@@ -12,38 +20,47 @@ type output =
 
     - [`Stdout] will enable tracing and print events on stdout
     - [`Stderr] will enable tracing and print events on stderr
-    - [`File "foo"] will enable tracing and print events into file
-        named "foo"
+    - [`File "foo"] will enable tracing and print events into file named "foo"
 *)
 
-val setup : ?out:[ output | `Env ] -> unit -> unit
+val collector : out:[< output ] -> unit -> Trace_core.collector
+(** Make a collector that writes into the given output. See {!setup} for more
+    details. *)
+
+val setup : ?debug:bool -> ?out:[ output | `Env ] -> unit -> unit
 (** [setup ()] installs the collector depending on [out].
 
-    @param out can take different values:
-    - regular {!output} value to specify where events go
-    - [`Env] will enable tracing if the environment
-      variable "TRACE" is set.
+    @param out
+      can take different values:
+      - regular {!output} value to specify where events go
+      - [`Env] will enable tracing if the environment variable "TRACE" is set.
 
-      - If it's set to "1", then the file is "trace.json".
-      - If it's set to "stdout", then logging happens on stdout (since 0.2)
-      - If it's set to "stderr", then logging happens on stdout (since 0.2)
-      - Otherwise, if it's set to a non empty string, the value is taken
-        to be the file path into which to write.
-*)
+    - If it's set to "1", then the file is "trace.json".
+    - If it's set to "stdout", then logging happens on stdout (since 0.2)
+    - If it's set to "stderr", then logging happens on stdout (since 0.2)
+    - Otherwise, if it's set to a non empty string, the value is taken to be the
+      file path into which to write.
 
-val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a
-(** [with_setup () f] (optionally) sets a collector up, calls [f()],
-    and makes sure to shutdown before exiting.
-    since 0.2 a () argument was added.
-*)
+    @param debug if true, use {!Trace_debug}. Default [false]. *)
+
+val with_setup :
+  ?debug:bool -> ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a
+(** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes
+    sure to shutdown before exiting. since 0.2 a () argument was added. *)
 
 (**/**)
 
-module Internal_ : sig
+module Private_ : sig
   val mock_all_ : unit -> unit
   (** use fake, deterministic timestamps, TID, PID *)
 
-  val on_tracing_error : (string -> unit) ref
+  val collector_jsonl :
+    finally:(unit -> unit) ->
+    out:[ `File_append of string | `Output of out_channel ] ->
+    unit ->
+    Trace_core.collector
+
+  module Event = Event
 end
 
 (**/**)

src/tef/types.ml

@@ -0,0 +1,19 @@
+module Trace_id = Trace_util.Trace_id64
+
+type trace_id = Trace_id.t
+
+type Trace_core.span +=
+  | Span_tef_sync of {
+      pid: int;
+      tid: int;
+      name: string;
+      start_us: float;
+      mutable args: (string * Trace_core.user_data) list;
+    }
+  | Span_tef_async of {
+      pid: int;
+      tid: int;
+      name: string;
+      trace_id: trace_id;
+      mutable args: (string * Trace_core.user_data) list;
+    }

src/tef/writer.ml

@@ -0,0 +1,100 @@
+let char = Buffer.add_char
+let raw_string = Buffer.add_string
+
+let str_val (buf : Buffer.t) (s : string) =
+  char buf '"';
+  let encode_char c =
+    match c with
+    | '"' -> raw_string buf {|\"|}
+    | '\\' -> raw_string buf {|\\|}
+    | '\n' -> raw_string buf {|\n|}
+    | '\b' -> raw_string buf {|\b|}
+    | '\r' -> raw_string buf {|\r|}
+    | '\t' -> raw_string buf {|\t|}
+    | _ when Char.code c <= 0x1f ->
+      raw_string buf {|\u00|};
+      Printf.bprintf buf "%02x" (Char.code c)
+    | c -> char buf c
+  in
+  String.iter encode_char s;
+  char buf '"'
+
+let pp_user_data_ (out : Buffer.t) : Trace_core.user_data -> unit = function
+  | `None -> raw_string out "null"
+  | `Int i -> Printf.bprintf out "%d" i
+  | `Bool b -> Printf.bprintf out "%b" b
+  | `String s -> str_val out s
+  | `Float f -> Printf.bprintf out "%g" f
+
+(* emit args, if not empty. [ppv] is used to print values. *)
+let emit_args_o_ ppv (out : Buffer.t) args : unit =
+  if args <> [] then (
+    Printf.bprintf out {json|,"args": {|json};
+    List.iteri
+      (fun i (n, value) ->
+        if i > 0 then raw_string out ",";
+        Printf.bprintf out {json|"%s":%a|json} n ppv value)
+      args;
+    char out '}'
+  )
+
+let emit_duration_event ~pid ~tid ~name ~start ~end_ ~args buf : unit =
+  let dur = end_ -. start in
+  let ts = start in
+
+  Printf.bprintf buf
+    {json|{"pid":%d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json}
+    pid tid dur ts str_val name
+    (emit_args_o_ pp_user_data_)
+    args
+
+let emit_begin_async ~pid ~tid ~name ~trace_id ~ts ~args buf =
+  Printf.bprintf buf
+    {json|{"pid":%d,"cat":"trace","id":%Ld,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json}
+    pid trace_id tid ts str_val name 'b'
+    (emit_args_o_ pp_user_data_)
+    args
+
+let emit_end_async ~pid ~tid ~name ~(trace_id : int64) ~ts ~args buf : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"cat":"trace","id":%Ld,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json}
+    pid trace_id tid ts str_val name 'e'
+    (emit_args_o_ pp_user_data_)
+    args
+
+let emit_instant_event ~pid ~tid ~name ~ts ~args buf : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"I"%a}|json}
+    pid tid ts str_val name
+    (emit_args_o_ pp_user_data_)
+    args
+
+let emit_name_thread ~pid ~tid ~name buf : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"tid": %d,"name":"thread_name","ph":"M"%a}|json} pid tid
+    (emit_args_o_ pp_user_data_)
+    [ "name", `String name ]
+
+let emit_process_sort_index ~pid i buf : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"name":"process_sort_index","ph":"M"%a}|json} pid
+    (emit_args_o_ pp_user_data_)
+    [ "sort_index", `Int i ]
+
+let emit_thread_sort_index ~pid ~tid i buf : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"tid": %d,"name":"thread_sort_index","ph":"M"%a}|json} pid
+    tid
+    (emit_args_o_ pp_user_data_)
+    [ "sort_index", `Int i ]
+
+let emit_name_process ~pid ~name buf : unit =
+  Printf.bprintf buf {json|{"pid":%d,"name":"process_name","ph":"M"%a}|json} pid
+    (emit_args_o_ pp_user_data_)
+    [ "name", `String name ]
+
+let emit_counter ~pid ~tid ~name ~ts buf f : unit =
+  Printf.bprintf buf
+    {json|{"pid":%d,"tid":%d,"ts":%.2f,"name":"c","ph":"C"%a}|json} pid tid ts
+    (emit_args_o_ pp_user_data_)
+    [ name, `Float f ]

src/tef/writer.mli

@@ -0,0 +1,53 @@
+(** Write JSON events to a buffer.
+
+    This is the part of the code that knows how to emit TEF-compliant JSON from
+    raw event data. *)
+
+open Types
+
+val emit_duration_event :
+  pid:int ->
+  tid:int ->
+  name:string ->
+  start:float ->
+  end_:float ->
+  args:(string * Trace_core.user_data) list ->
+  Buffer.t ->
+  unit
+
+val emit_begin_async :
+  pid:int ->
+  tid:int ->
+  name:string ->
+  trace_id:trace_id ->
+  ts:float ->
+  args:(string * Trace_core.user_data) list ->
+  Buffer.t ->
+  unit
+
+val emit_end_async :
+  pid:int ->
+  tid:int ->
+  name:string ->
+  trace_id:trace_id ->
+  ts:float ->
+  args:(string * Trace_core.user_data) list ->
+  Buffer.t ->
+  unit
+
+val emit_instant_event :
+  pid:int ->
+  tid:int ->
+  name:string ->
+  ts:float ->
+  args:(string * Trace_core.user_data) list ->
+  Buffer.t ->
+  unit
+
+val emit_name_thread : pid:int -> tid:int -> name:string -> Buffer.t -> unit
+val emit_name_process : pid:int -> name:string -> Buffer.t -> unit
+val emit_process_sort_index : pid:int -> int -> Buffer.t -> unit
+val emit_thread_sort_index : pid:int -> tid:int -> int -> Buffer.t -> unit
+
+val emit_counter :
+  pid:int -> tid:int -> name:string -> ts:float -> Buffer.t -> float -> unit

src/tls/dune

@@ -0,0 +1,6 @@
+(library
+ (name trace_thread_local_storage)
+ (public_name trace.thread-local-storage)
+ (synopsis "Use thread-local-storage for ambient spans")
+ (optional) ; thread-local-storage
+ (libraries trace.core thread-local-storage))

src/tls/trace_thread_local_storage.ml

@@ -0,0 +1,29 @@
+open Trace_core
+
+let k_span : span Thread_local_storage.t = Thread_local_storage.create ()
+
+open struct
+  let get_current_span () = Thread_local_storage.get_opt k_span
+
+  let with_current_span_set_to () span f =
+    let prev_span =
+      try Thread_local_storage.get_exn k_span
+      with Thread_local_storage.Not_set -> Collector.dummy_span
+    in
+    Thread_local_storage.set k_span span;
+
+    match f span with
+    | res ->
+      Thread_local_storage.set k_span prev_span;
+      res
+    | exception exn ->
+      let bt = Printexc.get_raw_backtrace () in
+      Thread_local_storage.set k_span prev_span;
+      Printexc.raise_with_backtrace exn bt
+
+  let callbacks : unit Ambient_span_provider.Callbacks.t =
+    { get_current_span; with_current_span_set_to }
+end
+
+let provider : Ambient_span_provider.t = ASP_some ((), callbacks)
+let setup () = Trace_core.set_ambient_context_provider provider

src/tls/trace_thread_local_storage.mli

@@ -0,0 +1,19 @@
+(** use [thread-local-storage] to store ambient spans.
+
+    This doesn't work with cooperative concurrency (Eio, Lwt, etc) but is fine
+    in a threaded context.
+
+    @since 0.12 *)
+
+open Trace_core
+
+val k_span : span Thread_local_storage.t
+(** Key to access the current span *)
+
+val provider : Ambient_span_provider.t
+(** Provider that uses [Thread_local_storage] to store the current ambient span.
+    This works well when concurrency is based on thread, or if there is no
+    concurrency. *)
+
+val setup : unit -> unit
+(** Install the provider *)

src/trace.ml

@@ -1 +1,7 @@
+(** Shim that just forwards to {!Trace_core}.
+
+    The reason is, [Trace] is already defined in the compiler libs and can clash
+    with this module inside a toplevel. So it's safer to only depend on
+    [Trace_core] in libraries that might end up used in a toplevel. *)
+
 include Trace_core

src/util/domain_util.dummy.ml

@@ -0,0 +1,2 @@
+let cpu_relax () = ()
+let n_domains () = 1

src/util/domain_util.mli

@@ -0,0 +1,2 @@
+val cpu_relax : unit -> unit
+val n_domains : unit -> int

src/util/domain_util.real.ml

@@ -0,0 +1,2 @@
+let cpu_relax = Domain.cpu_relax
+let n_domains = Domain.recommended_domain_count

src/util/dune

@@ -0,0 +1,28 @@
+(library
+ (public_name trace.util)
+ (synopsis "Utilities for trace and for collectors")
+ (name trace_util)
+ (libraries
+  trace.core
+  (select
+   thread_util.ml
+   from
+   (threads -> thread_util.real.ml)
+   (-> thread_util.dummy.ml))
+  (select
+   time_util.ml
+   from
+   (mtime mtime.clock.os -> time_util.mtime.ml)
+   (mtime mtime.clock.jsoo -> time_util.mtime.ml)
+   (unix -> time_util.unix.ml)
+   (-> time_util.dummy.ml))
+  (select
+   unix_util.ml
+   from
+   (unix -> unix_util.real.ml)
+   (-> unix_util.dummy.ml))
+  (select
+   domain_util.ml
+   from
+   (base-domain -> domain_util.real.ml)
+   (-> domain_util.dummy.ml))))

src/util/mock_.ml

@@ -0,0 +1,46 @@
+(** Mocking for tests *)
+
+module Inner = struct
+  let mock = ref false
+  let get_now_ns_ref = ref Time_util.get_time_ns
+  let get_tid_ref = ref Thread_util.get_tid
+  let get_pid_ref = ref Unix_util.get_pid
+
+  (** used to mock timing *)
+  let make_time_mock () : unit -> int64 =
+    let time_ = ref 0 in
+
+    let get_now_ns () : int64 =
+      let x = !time_ in
+      incr time_;
+      Int64.(mul (of_int x) 1000L)
+    in
+    get_now_ns
+end
+
+(** Now, in nanoseconds. Uses {!get_now_ns_ref} *)
+let[@inline] now_ns () : int64 =
+  if !Inner.mock then
+    !Inner.get_now_ns_ref ()
+  else
+    Time_util.get_time_ns ()
+
+(** Current thread's ID. Uses {!get_tid_ref} *)
+let[@inline] get_tid () : int =
+  if !Inner.mock then
+    !Inner.get_tid_ref ()
+  else
+    Thread_util.get_tid ()
+
+let[@inline] get_pid () : int =
+  if !Inner.mock then
+    !Inner.get_pid_ref ()
+  else
+    Unix_util.get_pid ()
+
+let mock_all () : unit =
+  Inner.mock := true;
+  (Inner.get_pid_ref := fun () -> 2);
+  (Inner.get_tid_ref := fun () -> 3);
+  Inner.get_now_ns_ref := Inner.make_time_mock ();
+  ()

src/util/multi_collector.ml

@@ -0,0 +1,109 @@
+open Trace_core
+
+open struct
+  type st = Collector.t array
+  type span += Span_combine of span array
+
+  let init st =
+    for i = 0 to Array.length st - 1 do
+      let (Collector.C_some (st, cb)) = Array.get st i in
+      cb.init st
+    done
+    [@ocaml.warning "-8"]
+
+  let shutdown st =
+    for i = 0 to Array.length st - 1 do
+      let (Collector.C_some (st, cb)) = Array.get st i in
+      cb.shutdown st
+    done
+    [@ocaml.warning "-8"]
+
+  let enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params ~data
+      ~parent name : span =
+    let spans =
+      Array.map
+        (fun [@ocaml.warning "-8"] coll ->
+          let (Collector.C_some (st, cb)) = coll in
+          cb.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params
+            ~data ~parent name)
+        st
+    in
+    Span_combine spans
+
+  let exit_span st span =
+    match span with
+    | Span_combine spans ->
+      assert (Array.length spans = Array.length st);
+      for i = 0 to Array.length st - 1 do
+        let (Collector.C_some (st, cb)) = Array.get st i in
+        cb.exit_span st spans.(i)
+      done
+      [@ocaml.warning "-8"]
+    | _ -> ()
+
+  let add_data_to_span st span data =
+    match span with
+    | Span_combine spans when data <> [] ->
+      assert (Array.length spans = Array.length st);
+      for i = 0 to Array.length st - 1 do
+        let (Collector.C_some (st, cb)) = Array.get st i in
+        cb.add_data_to_span st spans.(i) data
+      done
+      [@ocaml.warning "-8"]
+    | _ -> ()
+
+  let message st ~level ~params ~data ~span msg =
+    for i = 0 to Array.length st - 1 do
+      let (Collector.C_some (st, cb)) = Array.get st i in
+      cb.message st ~level ~span ~params ~data msg
+    done
+    [@ocaml.warning "-8"]
+
+  let metric st ~level ~params ~data name m =
+    for i = 0 to Array.length st - 1 do
+      let (Collector.C_some (st, cb)) = Array.get st i in
+      cb.metric st ~level ~params ~data name m
+    done
+    [@ocaml.warning "-8"]
+
+  let extension st ~level ev : unit =
+    for i = 0 to Array.length st - 1 do
+      let (Collector.C_some (st, cb)) = Array.get st i in
+      cb.extension st ~level ev
+    done
+    [@ocaml.warning "-8"]
+
+  let enabled st level : bool =
+    Array.exists
+      (fun (Collector.C_some (st, cb)) -> cb.enabled st level)
+      st [@ocaml.warning "-8"]
+
+  let combine_cb : st Collector.Callbacks.t =
+    {
+      Collector.Callbacks.init;
+      enter_span;
+      exit_span;
+      enabled;
+      message;
+      add_data_to_span;
+      metric;
+      extension;
+      shutdown;
+    }
+end
+
+let combine_l (cs : Collector.t list) : Collector.t =
+  let cs =
+    List.filter
+      (function
+        | Collector.C_none -> false
+        | Collector.C_some _ -> true)
+      cs
+  in
+  match cs with
+  | [] -> C_none
+  | [ c ] -> c
+  | _ -> C_some (Array.of_list cs, combine_cb)
+
+let combine (s1 : Collector.t) (s2 : Collector.t) : Collector.t =
+  combine_l [ s1; s2 ]

src/util/multi_collector.mli

@@ -0,0 +1,11 @@
+(** Combine multiple collectors into one *)
+
+open Trace_core
+
+val combine_l : Collector.t list -> Collector.t
+(** Combine multiple collectors, ie return a collector that forwards to every
+    collector in the list. *)
+
+val combine : Collector.t -> Collector.t -> Collector.t
+(** [combine s1 s2] is a collector that forwards every call to [s1] and [s2]
+    both. *)

src/util/rpool.ml

@@ -0,0 +1,67 @@
+open struct
+  module A = Trace_core.Internal_.Atomic_
+end
+
+module List_with_len = struct
+  type +'a t =
+    | Nil
+    | Cons of int * 'a * 'a t
+
+  let empty : _ t = Nil
+
+  let[@inline] len = function
+    | Nil -> 0
+    | Cons (i, _, _) -> i
+
+  let[@inline] cons x self = Cons (len self + 1, x, self)
+end
+
+type 'a t = {
+  max_size: int;
+  create: unit -> 'a;
+  clear: 'a -> unit;
+  cached: 'a List_with_len.t A.t;
+}
+
+let create ~max_size ~create ~clear () : _ t =
+  { max_size; create; clear; cached = A.make List_with_len.empty }
+
+let alloc (type a) (self : a t) : a =
+  let module M = struct
+    exception Found of a
+  end in
+  try
+    while
+      match A.get self.cached with
+      | Nil -> false
+      | Cons (_, x, tl) as old ->
+        if A.compare_and_set self.cached old tl then
+          raise_notrace (M.Found x)
+        else
+          true
+    do
+      ()
+    done;
+    self.create ()
+  with M.Found x -> x
+
+let recycle (self : 'a t) (x : 'a) : unit =
+  self.clear x;
+  while
+    match A.get self.cached with
+    | Cons (i, _, _) when i >= self.max_size -> false (* drop buf *)
+    | old -> not (A.compare_and_set self.cached old (List_with_len.cons x old))
+  do
+    ()
+  done
+
+let with_ (self : 'a t) f =
+  let x = alloc self in
+  try
+    let res = f x in
+    recycle self x;
+    res
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    recycle self x;
+    Printexc.raise_with_backtrace e bt

src/util/rpool.mli

@@ -0,0 +1,10 @@
+(** A resource pool (for buffers) *)
+
+type 'a t
+
+val create :
+  max_size:int -> create:(unit -> 'a) -> clear:('a -> unit) -> unit -> 'a t
+
+val alloc : 'a t -> 'a
+val recycle : 'a t -> 'a -> unit
+val with_ : 'a t -> ('a -> 'b) -> 'b

src/util/span_id64.ml

@@ -0,0 +1,24 @@
+open struct
+  module A = Trace_core.Internal_.Atomic_
+end
+
+type t = int64
+
+module Gen : sig
+  type t
+
+  val create : unit -> t
+  val gen : t -> int64
+end = struct
+  type t = int A.t
+
+  let create () = A.make 0
+  let[@inline] gen self : int64 = A.fetch_and_add self 1 |> Int64.of_int
+end
+
+module Trace_id_generator = struct
+  type t = int A.t
+
+  let create () = A.make 0
+  let[@inline] gen self = A.fetch_and_add self 1 |> Int64.of_int
+end

src/util/thread_util.dummy.ml

@@ -0,0 +1 @@
+let[@inline] get_tid () = 0

src/util/thread_util.mli

@@ -0,0 +1,2 @@
+val get_tid : unit -> int
+(** Get current thread ID *)

src/util/thread_util.real.ml

@@ -0,0 +1 @@
+let[@inline] get_tid () = Thread.id @@ Thread.self ()

src/util/time_util.dummy.ml

@@ -0,0 +1 @@
+let[@inline] get_time_ns () : int64 = Sys.time () *. 1e9

src/util/time_util.mli

@@ -0,0 +1,3 @@
+val get_time_ns : unit -> int64
+(** Get current time in nanoseconds. The beginning point is unspecified, and
+    this is assumed to be best-effort monotonic. Ideally, use [mtime]. *)

src/util/time_util.mtime.ml

@@ -0,0 +1,3 @@
+let[@inline] get_time_ns () : int64 =
+  let t = Mtime_clock.now () in
+  Mtime.to_uint64_ns t

src/util/time_util.unix.ml

@@ -0,0 +1,3 @@
+let[@inline] get_time_ns () : int64 =
+  let t = Unix.gettimeofday () in
+  Int64.of_float (t *. 1e9)

src/util/trace_id64.ml

@@ -0,0 +1,17 @@
+open struct
+  module A = Trace_core.Internal_.Atomic_
+end
+
+type t = int64
+
+module Gen : sig
+  type t
+
+  val create : unit -> t
+  val gen : t -> int64
+end = struct
+  type t = int A.t
+
+  let create () = A.make 0
+  let[@inline] gen self : int64 = A.fetch_and_add self 1 |> Int64.of_int
+end

src/util/unix_util.dummy.ml

@@ -0,0 +1 @@
+let get_pid () = -1

src/util/unix_util.mli

@@ -0,0 +1 @@
+val get_pid : unit -> int

src/util/unix_util.real.ml

@@ -0,0 +1 @@
+let get_pid = Unix.getpid

test/domains/dune

@@ -0,0 +1,29 @@
+; Marker library: only present on OCaml 5+, used as a proxy for Domain availability.
+
+(library
+ (name ocaml5)
+ (modules ocaml5)
+ (enabled_if
+  (>= %{ocaml_version} 5)))
+
+(executable
+ (name t_domains)
+ (modules t_domains)
+ (libraries
+  trace
+  ; use the marker library to pick between the real test and the quine fallback.
+  (select
+   t_domains.ml
+   from
+   (ocaml5 threads -> t_domains.real.ml)
+   (-> t_domains.quine.ml))))
+
+(rule
+ (alias runtest)
+ (package trace)
+ (action
+  (progn
+   (with-stdout-to
+    t_domains.output
+    (run %{exe:t_domains.exe} %{dep:t_domains.expected}))
+   (diff t_domains.expected t_domains.output))))

test/domains/ocaml5.ml

@@ -0,0 +1 @@
+(* Marker module: presence indicates OCaml 5+ (and thus Domain availability). *)