wip: collector for the fuchsia trace format

dune

@@ -1,4 +1,4 @@
 
 (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-44-70)))
 

dune-project

@@ -46,4 +46,17 @@
  (tags
   (trace tracing catapult)))
 
+(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-unix
+   atomic
+   dune)
+ (tags
+  (trace tracing fuchsia)))
+
 ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

src/fuchsia/bg_thread.ml

@@ -0,0 +1,81 @@
+open Common_
+
+(** 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
+
+  (* 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
+      (* get all the events in the incoming blocking queue, in
+         one single critical section. *)
+      let local = B_queue.pop_all events in
+      List.iter handle_ev local
+    done
+  with B_queue.Closed ->
+    (* write a message about us closing *)
+    Writer.emit_instant_event ~name:"tef-worker.exit"
+      ~tid:(Thread.id @@ Thread.self ())
+      ~ts:(now_us ()) ~args:[] writer;
+
+    (* 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 -> ()

src/fuchsia/common_.ml

@@ -0,0 +1,10 @@
+module A = Trace_core.Internal_.Atomic_
+
+module Span_tbl = Hashtbl.Make (struct
+  include Int64
+
+  let hash : t -> int = Hashtbl.hash
+end)
+
+let on_tracing_error =
+  ref (fun s -> Printf.eprintf "trace-fuchsia error: %s\n%!" s)

src/fuchsia/dune

@@ -0,0 +1,8 @@
+
+
+(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.private.util thread-local-storage
+             mtime mtime.clock.os atomic unix threads))

src/fuchsia/time.ml

@@ -0,0 +1,20 @@
+module Mock_ = struct
+  let enabled = ref false
+  let now = ref 0
+
+  let[@inline never] now_us () : int64 =
+    let x = !now in
+    incr now;
+    Int64.of_int x
+end
+
+let counter = Mtime_clock.counter ()
+
+(** Now, in nanoseconds *)
+let[@inline] now_ns () : int64 =
+  if !Mock_.enabled then
+    Mock_.now_us ()
+  else (
+    let t = Mtime_clock.count counter in
+    Mtime.Span.to_uint64_ns t
+  )

src/fuchsia/trace_fuchsia.ml

@@ -0,0 +1,424 @@
+open Trace_core
+open Trace_private_util
+open Common_
+
+(*
+type span_info = {
+  tid: int;
+  name: string;
+  start_ns: 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 ()
+  *)
+
+(* TODO:
+   (** 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? *)
+       buf: Buffer.t;  (** Buffer to write into *)
+       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; buf = Buffer.create 2_048 }
+
+     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
+       Fun.protect ~finally:(fun () -> close writer) (fun () -> f writer)
+
+     let[@inline] flush (self : t) : unit = flush self.oc
+
+     (** Emit "," if we need, and get the buffer ready *)
+     let emit_sep_and_start_ (self : t) =
+       Buffer.reset self.buf;
+       if self.first then
+         self.first <- false
+       else
+         Buffer.add_string self.buf ",\n"
+
+     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) : [< 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 ~tid ~name ~start ~end_ ~args (self : t) : unit =
+       let dur = end_ -. start in
+       let ts = start in
+
+       emit_sep_and_start_ self;
+
+       Printf.bprintf self.buf
+         {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;
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_manual_begin ~tid ~name ~id ~ts ~args ~flavor (self : t) : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {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;
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_manual_end ~tid ~name ~id ~ts ~flavor ~args (self : t) : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {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;
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_instant_event ~tid ~name ~ts ~args (self : t) : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {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;
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_name_thread ~tid ~name (self : t) : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {json|{"pid":%d,"tid": %d,"name":"thread_name","ph":"M"%a}|json} self.pid
+         tid
+         (emit_args_o_ pp_user_data_)
+         [ "name", `String name ];
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_name_process ~name (self : t) : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {json|{"pid":%d,"name":"process_name","ph":"M"%a}|json} self.pid
+         (emit_args_o_ pp_user_data_)
+         [ "name", `String name ];
+       Buffer.output_buffer self.oc self.buf
+
+     let emit_counter ~name ~tid ~ts (self : t) f : unit =
+       emit_sep_and_start_ self;
+       Printf.bprintf self.buf
+         {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 ];
+       Buffer.output_buffer self.oc self.buf
+   end
+*)
+
+(* TODO:
+   (** 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
+
+     (* 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
+         (* get all the events in the incoming blocking queue, in
+            one single critical section. *)
+         let local = B_queue.pop_all events in
+         List.iter handle_ev local
+       done
+     with B_queue.Closed ->
+       (* write a message about us closing *)
+       Writer.emit_instant_event ~name:"tef-worker.exit"
+         ~tid:(Thread.id @@ Thread.self ())
+         ~ts:(now_us ()) ~args:[] writer;
+
+       (* 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 -> ()
+*)
+
+type output =
+  [ `Stdout
+  | `Stderr
+  | `File of string
+  ]
+
+let collector ~out () : collector = assert false
+(* TODO:
+   let module M = struct
+     let active = A.make true
+
+     (** generator for span ids *)
+     let span_id_gen_ = A.make 0
+
+     (* queue of messages to write *)
+     let events : event B_queue.t = B_queue.create ()
+
+     (** 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
+       )
+
+     let get_tid_ () : int =
+       if !Mock_.enabled then
+         3
+       else
+         Thread.id (Thread.self ())
+
+     let[@inline] enter_span_ ~fun_name ~data name : span =
+       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 });
+       span
+
+     let enter_span ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name :
+         span =
+       enter_span_ ~fun_name ~data name
+
+     let exit_span span : unit =
+       let time_us = now_us () in
+       B_queue.push events (E_exit_span { id = span; time_us })
+
+     (* re-raise exception with its backtrace *)
+     external reraise : exn -> 'a = "%reraise"
+
+     let with_span ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name f =
+       let span = enter_span_ ~fun_name ~data name in
+       try
+         let x = f span in
+         exit_span span;
+         x
+       with exn ->
+         exit_span span;
+         reraise exn
+
+     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) ()
+  | `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 "stdout" -> Trace_core.setup_collector @@ collector ~out:`Stdout ()
+    | Some "stderr" -> Trace_core.setup_collector @@ collector ~out:`Stderr ()
+    | 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_ () = Mock_.enabled := true
+  let on_tracing_error = on_tracing_error
+end

src/fuchsia/trace_fuchsia.mli

@@ -0,0 +1,49 @@
+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. *)
+
+type output =
+  [ `Stdout
+  | `Stderr
+  | `File of string
+  ]
+(** Output for tracing.
+
+    - [`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"
+*)
+
+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".
+      - 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.
+*)
+
+(**/**)
+
+module Internal_ : sig
+  val mock_all_ : unit -> unit
+  (** use fake, deterministic timestamps, TID, PID *)
+
+  val on_tracing_error : (string -> unit) ref
+end
+
+(**/**)

src/fuchsia/write/dune

@@ -0,0 +1,6 @@
+
+(library
+  (name trace_fuchsia_write)
+  (public_name trace-fuchsia.write)
+  (synopsis "Serialization part of trace-fuchsia")
+  (libraries trace.core atomic threads))

src/fuchsia/write/trace_fuchsia_write.ml

@@ -0,0 +1,260 @@
+(** Write fuchsia events into buffers.
+
+Reference: https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format *)
+
+module B = Bytes
+
+open struct
+  let spf = Printf.sprintf
+end
+
+module Util = struct
+  (** 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)
+end
+
+open Util
+
+module Buf = struct
+  type t = {
+    buf: bytes;
+    mutable offset: int;
+  }
+
+  let create (n : int) : t =
+    let buf = Bytes.create (round_to_word n) in
+    { buf; offset = 0 }
+
+  let[@inline] clear self = self.offset <- 0
+
+  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 add_string (self : t) (s : string) : unit =
+    let len = String.length s in
+    Bytes.blit_string s 0 self.buf self.offset len;
+    self.offset <- self.offset + len;
+
+    (* add 0-padding *)
+    let missing = missing_to_round len in
+    Bytes.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
+end
+
+type user_data = Trace_core.user_data
+
+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
+
+module Str_ref = struct
+  type t = int
+  (** 16 bits *)
+
+  let inline (size : int) : t =
+    if size > 32_000 then invalid_arg "fuchsia: max length of strings is 20_000";
+    if size = 0 then
+      0
+    else
+      (1 lsl 15) lor size
+end
+
+module Thread_ref = struct
+  type t =
+    | Ref of int
+    | Inline of {
+        pid: int;
+        tid: int;
+      }
+
+  let ref x : t =
+    if x = 0 || x > 255 then
+      invalid_arg "fuchsia: thread inline ref must be >0 < 256";
+    Ref x
+
+  let size_B (self : t) : int =
+    match self with
+    | Ref _ -> 0
+    | Inline _ -> 16
+
+  (** 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_B = 8
+    let encode (buf : Buf.t) = Buf.add_i64 buf value
+  end
+
+  module Trace_info = struct end
+end
+
+module Argument = struct
+  type t = string * user_data
+
+  let check_valid _ = ()
+  (* TODO: check string length *)
+
+  let[@inline] is_i32_ (i : int) : bool = Int32.(to_int (of_int i) = i)
+
+  (** Size in bytes *)
+  let size_B (self : t) =
+    let name, data = self in
+    match data with
+    | `None | `Bool _ -> 8 + round_to_word (String.length name)
+    | `Int i when is_i32_ i -> 8 + round_to_word (String.length name)
+    | `Int _ -> (* int64 *) 16 + round_to_word (String.length name)
+    | `Float _ -> 16 + round_to_word (String.length name)
+    | `String s ->
+      8 + round_to_word (String.length s) + round_to_word (String.length 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 size = size_B 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
+    | `None ->
+      let hd = hd_arg_size in
+      Buf.add_i64 buf hd;
+      Buf.add_string buf name
+    | `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
+    | `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)
+    | `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)
+    | `String s ->
+      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
+    | `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
+end
+
+module Arguments = struct
+  type t = Argument.t list
+
+  let check_valid (self : t) =
+    let len = List.length 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_B (self : t) =
+    List.fold_left (fun n arg -> n + Argument.size_B arg) 0 self
+
+  let encode (buf : Buf.t) (self : t) =
+    let rec aux buf l =
+      match l with
+      | [] -> ()
+      | x :: tl ->
+        Argument.encode buf x;
+        aux buf tl
+    in
+    aux buf self
+end
+
+(** record type = 3 *)
+module Thread_record = struct
+  let size_B : int = 24
+
+  (** Record that [Thread_ref.ref as_ref] represents the pair [pid, tid] *)
+  let encode (buf : Buf.t) ~as_ref ~pid ~tid () : unit =
+    let hd = I64.(3L lor (of_int size_B 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
+  module Instant = struct
+    (* TODO: find out how to encode tid/pid (are they both in64?)
+
+       then compute size; then add encoder
+    *)
+
+    let size_B ~name ~t_ref ~args () : int =
+      8 + Thread_ref.size_B t_ref + 8
+      (* timestamp *) + round_to_word (String.length name)
+      + Arguments.size_B args
+
+    let encode (buf : Buf.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () :
+        unit =
+      let size = size_B ~name ~t_ref ~args () in
+      (* set category = 0 *)
+      let hd =
+        I64.(
+          4L
+          lor (of_int size lsl 4)
+          lor (of_int (List.length 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
+end

trace-fuchsia.opam

@@ -0,0 +1,37 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.5"
+synopsis:
+  "A high-performance backend for trace, emitting a Fuchsia trace into a file"
+maintainer: ["Simon Cruanes"]
+authors: ["Simon Cruanes"]
+license: "MIT"
+tags: ["trace" "tracing" "fuchsia"]
+homepage: "https://github.com/c-cube/ocaml-trace"
+bug-reports: "https://github.com/c-cube/ocaml-trace/issues"
+depends: [
+  "ocaml" {>= "4.08"}
+  "trace" {= version}
+  "mtime" {>= "2.0"}
+  "base-unix"
+  "atomic"
+  "dune" {>= "2.9"}
+  "odoc" {with-doc}
+]
+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/c-cube/ocaml-trace.git"