From 00caf6aad52e6b7c5a18b4683a8200c29eb5a851 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 16:52:22 -0500 Subject: [PATCH] wip: collector for the fuchsia trace format --- dune | 2 +- dune-project | 13 + src/fuchsia/bg_thread.ml | 81 +++++ src/fuchsia/common_.ml | 10 + src/fuchsia/dune | 8 + src/fuchsia/span_info.ml | 0 src/fuchsia/time.ml | 20 ++ src/fuchsia/trace_fuchsia.ml | 424 +++++++++++++++++++++++ src/fuchsia/trace_fuchsia.mli | 49 +++ src/fuchsia/write/dune | 6 + src/fuchsia/write/trace_fuchsia_write.ml | 260 ++++++++++++++ trace-fuchsia.opam | 37 ++ 12 files changed, 909 insertions(+), 1 deletion(-) create mode 100644 src/fuchsia/bg_thread.ml create mode 100644 src/fuchsia/common_.ml create mode 100644 src/fuchsia/dune create mode 100644 src/fuchsia/span_info.ml create mode 100644 src/fuchsia/time.ml create mode 100644 src/fuchsia/trace_fuchsia.ml create mode 100644 src/fuchsia/trace_fuchsia.mli create mode 100644 src/fuchsia/write/dune create mode 100644 src/fuchsia/write/trace_fuchsia_write.ml create mode 100644 trace-fuchsia.opam diff --git a/dune b/dune index b6f39d0..1b45a87 100644 --- a/dune +++ b/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))) diff --git a/dune-project b/dune-project index c2f4f4b..b355550 100644 --- a/dune-project +++ b/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 diff --git a/src/fuchsia/bg_thread.ml b/src/fuchsia/bg_thread.ml new file mode 100644 index 0000000..e12767b --- /dev/null +++ b/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 -> () diff --git a/src/fuchsia/common_.ml b/src/fuchsia/common_.ml new file mode 100644 index 0000000..986880b --- /dev/null +++ b/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) diff --git a/src/fuchsia/dune b/src/fuchsia/dune new file mode 100644 index 0000000..32bd35e --- /dev/null +++ b/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)) diff --git a/src/fuchsia/span_info.ml b/src/fuchsia/span_info.ml new file mode 100644 index 0000000..e69de29 diff --git a/src/fuchsia/time.ml b/src/fuchsia/time.ml new file mode 100644 index 0000000..dd11ae5 --- /dev/null +++ b/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 + ) diff --git a/src/fuchsia/trace_fuchsia.ml b/src/fuchsia/trace_fuchsia.ml new file mode 100644 index 0000000..68e7c42 --- /dev/null +++ b/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 diff --git a/src/fuchsia/trace_fuchsia.mli b/src/fuchsia/trace_fuchsia.mli new file mode 100644 index 0000000..f6fa66e --- /dev/null +++ b/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 + +(**/**) diff --git a/src/fuchsia/write/dune b/src/fuchsia/write/dune new file mode 100644 index 0000000..c4d7ad1 --- /dev/null +++ b/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)) diff --git a/src/fuchsia/write/trace_fuchsia_write.ml b/src/fuchsia/write/trace_fuchsia_write.ml new file mode 100644 index 0000000..65a69a0 --- /dev/null +++ b/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 diff --git a/trace-fuchsia.opam b/trace-fuchsia.opam new file mode 100644 index 0000000..25428ba --- /dev/null +++ b/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"