From 7f9370e842bf782d23c48537f4f91f49ae71a566 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 16:51:52 -0500 Subject: [PATCH 01/21] refactor: split some parts of trace-tef into trace.private.util --- src/tef/dune | 5 +---- src/tef/trace_tef.ml | 17 ++++------------- src/{tef => util}/b_queue.ml | 0 src/{tef => util}/b_queue.mli | 0 .../relax_.dummy.ml => util/cpu_relax.dummy.ml} | 0 src/util/cpu_relax.mli | 1 + .../relax_.real.ml => util/cpu_relax.real.ml} | 0 src/util/dune | 9 +++++++++ src/{tef => util}/mpsc_bag.ml | 2 +- src/{tef => util}/mpsc_bag.mli | 0 10 files changed, 16 insertions(+), 18 deletions(-) rename src/{tef => util}/b_queue.ml (100%) rename src/{tef => util}/b_queue.mli (100%) rename src/{tef/relax_.dummy.ml => util/cpu_relax.dummy.ml} (100%) create mode 100644 src/util/cpu_relax.mli rename src/{tef/relax_.real.ml => util/cpu_relax.real.ml} (100%) create mode 100644 src/util/dune rename src/{tef => util}/mpsc_bag.ml (95%) rename src/{tef => util}/mpsc_bag.mli (100%) diff --git a/src/tef/dune b/src/tef/dune index acacd95..89b8e9a 100644 --- a/src/tef/dune +++ b/src/tef/dune @@ -3,7 +3,4 @@ (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 atomic unix threads - (select relax_.ml from - (base-domain -> relax_.real.ml) - ( -> relax_.dummy.ml)))) + (libraries trace.core trace.private.util mtime mtime.clock.os atomic unix threads)) diff --git a/src/tef/trace_tef.ml b/src/tef/trace_tef.ml index aed6653..bd36ecb 100644 --- a/src/tef/trace_tef.ml +++ b/src/tef/trace_tef.ml @@ -1,4 +1,5 @@ open Trace_core +open Trace_private_util module A = Trace_core.Internal_.Atomic_ module Mock_ = struct @@ -14,7 +15,7 @@ end let counter = Mtime_clock.counter () (** Now, in microseconds *) -let now_us () : float = +let[@inline] now_us () : float = if !Mock_.enabled then Mock_.now_us () else ( @@ -22,16 +23,6 @@ let now_us () : float = Mtime.Span.to_float_ns t /. 1e3 ) -let protect ~finally f = - try - let x = f () in - finally (); - x - with exn -> - let bt = Printexc.get_raw_backtrace () in - finally (); - Printexc.raise_with_backtrace exn bt - let on_tracing_error = ref (fun s -> Printf.eprintf "trace-tef error: %s\n%!" s) type event = @@ -144,7 +135,7 @@ module Writer = struct let with_ ~out f = let writer = create ~out () in - protect ~finally:(fun () -> close writer) (fun () -> f writer) + Fun.protect ~finally:(fun () -> close writer) (fun () -> f writer) let[@inline] flush (self : t) : unit = flush self.oc @@ -499,7 +490,7 @@ let setup ?(out = `Env) () = let with_setup ?out () f = setup ?out (); - protect ~finally:Trace_core.shutdown f + Fun.protect ~finally:Trace_core.shutdown f module Internal_ = struct let mock_all_ () = Mock_.enabled := true diff --git a/src/tef/b_queue.ml b/src/util/b_queue.ml similarity index 100% rename from src/tef/b_queue.ml rename to src/util/b_queue.ml diff --git a/src/tef/b_queue.mli b/src/util/b_queue.mli similarity index 100% rename from src/tef/b_queue.mli rename to src/util/b_queue.mli diff --git a/src/tef/relax_.dummy.ml b/src/util/cpu_relax.dummy.ml similarity index 100% rename from src/tef/relax_.dummy.ml rename to src/util/cpu_relax.dummy.ml diff --git a/src/util/cpu_relax.mli b/src/util/cpu_relax.mli new file mode 100644 index 0000000..17542a8 --- /dev/null +++ b/src/util/cpu_relax.mli @@ -0,0 +1 @@ +val cpu_relax : unit -> unit diff --git a/src/tef/relax_.real.ml b/src/util/cpu_relax.real.ml similarity index 100% rename from src/tef/relax_.real.ml rename to src/util/cpu_relax.real.ml diff --git a/src/util/dune b/src/util/dune new file mode 100644 index 0000000..fc5fb6f --- /dev/null +++ b/src/util/dune @@ -0,0 +1,9 @@ + +(library + (public_name trace.private.util) + (synopsis "internal utilities for trace. No guarantees of stability.") + (name trace_private_util) + (libraries trace.core mtime mtime.clock.os atomic unix threads + (select cpu_relax.ml from + (base-domain -> cpu_relax.real.ml) + ( -> cpu_relax.dummy.ml)))) diff --git a/src/tef/mpsc_bag.ml b/src/util/mpsc_bag.ml similarity index 95% rename from src/tef/mpsc_bag.ml rename to src/util/mpsc_bag.ml index 004e8f5..453357f 100644 --- a/src/tef/mpsc_bag.ml +++ b/src/util/mpsc_bag.ml @@ -11,7 +11,7 @@ module Backoff = struct let once (b : t) : t = for _i = 1 to b do - Relax_.cpu_relax () + Cpu_relax.cpu_relax () done; min (b * 2) 256 end diff --git a/src/tef/mpsc_bag.mli b/src/util/mpsc_bag.mli similarity index 100% rename from src/tef/mpsc_bag.mli rename to src/util/mpsc_bag.mli From 00caf6aad52e6b7c5a18b4683a8200c29eb5a851 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 16:52:22 -0500 Subject: [PATCH 02/21] 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" From 6eced76971485c01ca9dfe0f9a7edad2f874bbc9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 18:56:46 -0500 Subject: [PATCH 03/21] fuchsia: fixes (size is in words, not bytes) --- src/fuchsia/write/trace_fuchsia_write.ml | 111 ++++++++++++++++++----- 1 file changed, 86 insertions(+), 25 deletions(-) diff --git a/src/fuchsia/write/trace_fuchsia_write.ml b/src/fuchsia/write/trace_fuchsia_write.ml index 65a69a0..4bed4cb 100644 --- a/src/fuchsia/write/trace_fuchsia_write.ml +++ b/src/fuchsia/write/trace_fuchsia_write.ml @@ -90,10 +90,10 @@ module Thread_ref = struct invalid_arg "fuchsia: thread inline ref must be >0 < 256"; Ref x - let size_B (self : t) : int = + let size_word (self : t) : int = match self with | Ref _ -> 0 - | Inline _ -> 16 + | Inline _ -> 2 (** 8-bit int for the reference *) let as_i8 (self : t) : int = @@ -107,10 +107,39 @@ module Metadata = struct (** First record in the trace *) module Magic_record = struct let value = 0x0016547846040010L - let size_B = 8 + let size_word = 1 let encode (buf : Buf.t) = 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 (buf : Buf.t) ~ticks_per_secs () : unit = + 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 + (round_to_word (String.length name) lsr 3) + + let encode buf ~(id : int) ~name () : unit = + let size = size_word ~name () 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 (String.length 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 @@ -122,16 +151,17 @@ module Argument = struct let[@inline] is_i32_ (i : int) : bool = Int32.(to_int (of_int i) = i) - (** Size in bytes *) - let size_B (self : t) = + let size_word (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) + | `None | `Bool _ -> 1 + (round_to_word (String.length name) lsr 3) + | `Int i when is_i32_ i -> 1 + (round_to_word (String.length name) lsr 3) + | `Int _ -> (* int64 *) 2 + (round_to_word (String.length name) lsr 3) + | `Float _ -> 2 + (round_to_word (String.length name) lsr 3) | `String s -> - 8 + round_to_word (String.length s) + round_to_word (String.length name) + 1 + + (round_to_word (String.length s) lsr 3) + + (round_to_word (String.length name) lsr 3) open struct external int_of_bool : bool -> int = "%identity" @@ -139,7 +169,7 @@ module Argument = struct let encode (buf : Buf.t) (self : t) : unit = let name, data = self in - let size = size_B self in + let size = size_word self in (* part of header with argument name + size *) let hd_arg_size = @@ -193,8 +223,8 @@ module Arguments = struct 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[@inline] size_word (self : t) = + List.fold_left (fun n arg -> n + Argument.size_word arg) 0 self let encode (buf : Buf.t) (self : t) = let rec aux buf l = @@ -209,11 +239,13 @@ end (** record type = 3 *) module Thread_record = struct - let size_B : int = 24 + let size_word : int = 3 (** 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 + if as_ref <= 0 || as_ref > 255 then + invalid_arg "fuchsia: thread_record: invalid ref"; + 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) @@ -222,24 +254,52 @@ 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 size_word ~name ~t_ref ~args () : int = + 1 + Thread_ref.size_word t_ref + 1 + (* timestamp *) + (round_to_word (String.length name) / 8) + + Arguments.size_word 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 + let size = size_word ~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 + + module Duration_complete = struct + let size_word ~name ~t_ref ~args () : int = + 1 + Thread_ref.size_word t_ref + 1 + (* timestamp *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + 1 (* end timestamp *) + + let encode (buf : Buf.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~end_time_ns + ~args () : unit = + let size = size_word ~name ~t_ref ~args () in (* set category = 0 *) let hd = I64.( 4L lor (of_int size lsl 4) + lor (4L lsl 16) 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)) @@ -255,6 +315,7 @@ module Event = struct Buf.add_string buf name; Arguments.encode buf args; + Buf.add_i64 buf end_time_ns; () end end From f08850cda8730398ad129cfd880f178209e410f8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 18:56:57 -0500 Subject: [PATCH 04/21] some tests for fuchsia writer --- test/fuchsia/write/dune | 4 ++ test/fuchsia/write/t1.ml | 65 +++++++++++++++++++++++++++++ test/fuchsia/write/t2.expected | 4 ++ test/fuchsia/write/t2.ml | 75 ++++++++++++++++++++++++++++++++++ 4 files changed, 148 insertions(+) create mode 100644 test/fuchsia/write/dune create mode 100644 test/fuchsia/write/t1.ml create mode 100644 test/fuchsia/write/t2.expected create mode 100644 test/fuchsia/write/t2.ml diff --git a/test/fuchsia/write/dune b/test/fuchsia/write/dune new file mode 100644 index 0000000..e9f181a --- /dev/null +++ b/test/fuchsia/write/dune @@ -0,0 +1,4 @@ + +(tests + (names t1 t2) + (libraries trace-fuchsia.write)) diff --git a/test/fuchsia/write/t1.ml b/test/fuchsia/write/t1.ml new file mode 100644 index 0000000..8b59e85 --- /dev/null +++ b/test/fuchsia/write/t1.ml @@ -0,0 +1,65 @@ +open Trace_fuchsia_write + +module Str_ = struct + open String + + let to_hex (s : string) : string = + 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 of_hex_exn (s : string) : string = + let n_of_c = function + | '0' .. '9' as c -> Char.code c - Char.code '0' + | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a' + | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A' + | _ -> invalid_arg "string: invalid hex" + in + if String.length s mod 2 <> 0 then + invalid_arg "string: hex sequence must be of even length"; + let res = Bytes.make (String.length s / 2) '\x00' in + for i = 0 to (String.length s / 2) - 1 do + let n1 = n_of_c (String.get s (2 * i)) in + let n2 = n_of_c (String.get s ((2 * i) + 1)) in + let n = (n1 lsl 4) lor n2 in + Bytes.set res i (Char.chr n) + done; + Bytes.unsafe_to_string res +end + +let () = + let l = List.init 100 (fun i -> Util.round_to_word i) in + assert (List.for_all (fun x -> x mod 8 = 0) l) + +let () = + assert (Str_ref.inline 0 = 0b0000_0000_0000_0000); + assert (Str_ref.inline 1 = 0b1000_0000_0000_0001); + assert (Str_ref.inline 6 = 0b1000_0000_0000_0110); + assert (Str_ref.inline 31999 = 0b1111_1100_1111_1111); + () + +let () = + let buf = Buf.create 128 in + Buf.add_i64 buf 42L; + assert (Buf.to_string buf = "\x2a\x00\x00\x00\x00\x00\x00\x00") + +let () = + let buf = Buf.create 128 in + Buf.add_string buf ""; + assert (Buf.to_string buf = "") + +let () = + let buf = Buf.create 128 in + Buf.add_string buf "hello"; + assert (Buf.to_string buf = "hello\x00\x00\x00") diff --git a/test/fuchsia/write/t2.expected b/test/fuchsia/write/t2.expected new file mode 100644 index 0000000..24c3856 --- /dev/null +++ b/test/fuchsia/write/t2.expected @@ -0,0 +1,4 @@ +first trace +100004467854160033000500000000000100000000000000560000000000000054001005000005804e61bc000000000068656c6c6f000000210001802a0000007800000000000000 +second trace +1000044678541600210000000000000000ca9a3b00000000330005000000000001000000000000005600000000000000300011000000b0006f63616d6c2d747261636500000000004400040500000580a0860100000000006f75746572000000404b4c0000000000440004050000058020bf020000000000696e6e657200000020aa44000000000054001005000005804e61bc000000000068656c6c6f000000210001802a0000007800000000000000 diff --git a/test/fuchsia/write/t2.ml b/test/fuchsia/write/t2.ml new file mode 100644 index 0000000..9f08a70 --- /dev/null +++ b/test/fuchsia/write/t2.ml @@ -0,0 +1,75 @@ +open Trace_fuchsia_write + +let pf = Printf.printf + +module Str_ = struct + open String + + let to_hex (s : string) : string = + 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 of_hex_exn (s : string) : string = + let n_of_c = function + | '0' .. '9' as c -> Char.code c - Char.code '0' + | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a' + | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A' + | _ -> invalid_arg "string: invalid hex" + in + if String.length s mod 2 <> 0 then + invalid_arg "string: hex sequence must be of even length"; + let res = Bytes.make (String.length s / 2) '\x00' in + for i = 0 to (String.length s / 2) - 1 do + let n1 = n_of_c (String.get s (2 * i)) in + let n2 = n_of_c (String.get s ((2 * i) + 1)) in + let n = (n1 lsl 4) lor n2 in + Bytes.set res i (Char.chr n) + done; + Bytes.unsafe_to_string res +end + +let () = pf "first trace\n" + +let () = + let buf = Buf.create 128 in + Metadata.Magic_record.encode buf; + Thread_record.encode buf ~as_ref:5 ~pid:1 ~tid:86 (); + Event.Instant.encode buf ~name:"hello" ~time_ns:1234_5678L + ~t_ref:(Thread_ref.Ref 5) + ~args:[ "x", `Int 42 ] + (); + pf "%s\n" (Buf.to_string buf |> Str_.to_hex) + +let () = pf "second trace\n" + +let () = + let buf = Buf.create 512 in + Metadata.Magic_record.encode buf; + Metadata.Initialization_record.( + encode buf ~ticks_per_secs:default_ticks_per_sec ()); + Thread_record.encode buf ~as_ref:5 ~pid:1 ~tid:86 (); + Metadata.Provider_info.encode buf ~id:1 ~name:"ocaml-trace" (); + Event.Duration_complete.encode buf ~name:"outer" ~t_ref:(Thread_ref.Ref 5) + ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] (); + Event.Duration_complete.encode buf ~name:"inner" ~t_ref:(Thread_ref.Ref 5) + ~time_ns:180_000L ~end_time_ns:4_500_000L ~args:[] (); + Event.Instant.encode buf ~name:"hello" ~time_ns:1_234_567L + ~t_ref:(Thread_ref.Ref 5) + ~args:[ "x", `Int 42 ] + (); + (let oc = open_out "foo.fxt" in + output_string oc (Buf.to_string buf); + close_out oc); + pf "%s\n" (Buf.to_string buf |> Str_.to_hex) From 1277a648032b68f9e3055696b38bd7a28ae7f616 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 18:58:24 -0500 Subject: [PATCH 05/21] update test --- test/fuchsia/write/t2.expected | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/fuchsia/write/t2.expected b/test/fuchsia/write/t2.expected index 24c3856..7ea7404 100644 --- a/test/fuchsia/write/t2.expected +++ b/test/fuchsia/write/t2.expected @@ -1,4 +1,4 @@ first trace 100004467854160033000500000000000100000000000000560000000000000054001005000005804e61bc000000000068656c6c6f000000210001802a0000007800000000000000 second trace -1000044678541600210000000000000000ca9a3b00000000330005000000000001000000000000005600000000000000300011000000b0006f63616d6c2d747261636500000000004400040500000580a0860100000000006f75746572000000404b4c0000000000440004050000058020bf020000000000696e6e657200000020aa44000000000054001005000005804e61bc000000000068656c6c6f000000210001802a0000007800000000000000 +1000044678541600210000000000000000ca9a3b00000000330005000000000001000000000000005600000000000000300011000000b0006f63616d6c2d747261636500000000004400040500000580a0860100000000006f75746572000000404b4c0000000000440004050000058020bf020000000000696e6e657200000020aa440000000000540010050000058087d612000000000068656c6c6f000000210001802a0000007800000000000000 From 9567c1b4a7d4cd71f9dc9e0b2ee3cada57c810ff Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 22:23:09 -0500 Subject: [PATCH 06/21] =?UTF-8?q?ppx:=20add=20`let%trace=20=20?= =?UTF-8?q?=3D=20"name"=20in=20=E2=80=A6`?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit this allows the user to access the span within the scope. --- README.md | 15 +++++++++++++++ src/ppx/ppx_trace.ml | 27 ++++++++++++++++++++++----- 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 722a536..8657920 100644 --- a/README.md +++ b/README.md @@ -117,6 +117,21 @@ let f x y z = 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))`. diff --git a/src/ppx/ppx_trace.ml b/src/ppx/ppx_trace.ml index 8f59221..af2dab3 100644 --- a/src/ppx/ppx_trace.ml +++ b/src/ppx/ppx_trace.ml @@ -8,19 +8,30 @@ let location_errorf ~loc fmt = (** {2 let expression} *) -let expand_let ~ctxt (name : string) body = +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 _trace_span = + 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 _trace_span; + Trace_core.exit_span [%e var_exp]; res with exn -> - Trace_core.exit_span _trace_span; + Trace_core.exit_span [%e var_exp]; raise exn]) let extension_let = @@ -29,7 +40,13 @@ let extension_let = single_expr_payload (pexp_let nonrecursive (value_binding - ~pat:(ppat_construct (lident (string "()")) 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) __)) From 68d3969cde1facce3b2dfbd4b2f4bc28e8bbd754 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 22:52:50 -0500 Subject: [PATCH 07/21] good progress on fuchsia collector --- src/fuchsia/bg_thread.ml | 121 ++++--- src/fuchsia/common_.ml | 8 + src/fuchsia/dune | 2 + src/fuchsia/fcollector.ml | 265 +++++++++++++++ src/fuchsia/fcollector.mli | 3 + src/fuchsia/global_.ml.tmp | 4 + src/fuchsia/time.ml | 18 +- src/fuchsia/trace_fuchsia.ml | 408 +---------------------- src/fuchsia/trace_fuchsia.mli | 3 - src/fuchsia/write/buf.ml | 42 +++ src/fuchsia/write/buf_pool.ml | 58 ++++ src/fuchsia/write/dune | 3 + src/fuchsia/write/output.ml | 46 +++ src/fuchsia/write/trace_fuchsia_write.ml | 216 +++++++++--- src/fuchsia/write/util.ml | 5 + 15 files changed, 667 insertions(+), 535 deletions(-) create mode 100644 src/fuchsia/fcollector.ml create mode 100644 src/fuchsia/fcollector.mli create mode 100644 src/fuchsia/global_.ml.tmp create mode 100644 src/fuchsia/write/buf.ml create mode 100644 src/fuchsia/write/buf_pool.ml create mode 100644 src/fuchsia/write/output.ml create mode 100644 src/fuchsia/write/util.ml diff --git a/src/fuchsia/bg_thread.ml b/src/fuchsia/bg_thread.ml index e12767b..1ac6aa0 100644 --- a/src/fuchsia/bg_thread.ml +++ b/src/fuchsia/bg_thread.ml @@ -1,74 +1,67 @@ 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 +type out = + [ `Stdout + | `Stderr + | `File of string + ] - (* 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 +type event = + | E_write_buf of Buf.t + | E_tick + +type state = { + buf_pool: Buf_pool.t; + oc: out_channel; + events: event B_queue.t; +} - (* 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 +let with_out_ (out : out) f = + let oc, must_close = + match out with + | `Stdout -> stdout, false + | `Stderr -> stderr, false + | `File path -> open_out path, true 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; + if must_close then ( + let finally () = close_out_noerr oc in + Fun.protect ~finally (fun () -> f oc) + ) else + f oc + +let handle_ev (self : state) (ev : event) : unit = + match ev with + | E_tick -> flush self.oc + | E_write_buf buf -> + output self.oc buf.buf 0 buf.offset; + Buf_pool.recycle self.buf_pool buf + +let bg_loop (self : state) : unit = + let continue = ref true in + + while !continue do + match B_queue.pop_all self.events with + | exception B_queue.Closed -> continue := false + | evs -> List.iter (handle_ev self) evs + done + +let bg_thread ~buf_pool ~out ~(events : event B_queue.t) () : unit = + let@ oc = with_out_ out in + let st = { oc; buf_pool; events } in + bg_loop st + +(* TODO: + (* 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); - () + (* 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 *) diff --git a/src/fuchsia/common_.ml b/src/fuchsia/common_.ml index 986880b..38ded80 100644 --- a/src/fuchsia/common_.ml +++ b/src/fuchsia/common_.ml @@ -1,4 +1,9 @@ module A = Trace_core.Internal_.Atomic_ +module FWrite = Trace_fuchsia_write +module B_queue = Trace_private_util.B_queue +module Buf = FWrite.Buf +module Buf_pool = FWrite.Buf_pool +module Output = FWrite.Output module Span_tbl = Hashtbl.Make (struct include Int64 @@ -8,3 +13,6 @@ end) let on_tracing_error = ref (fun s -> Printf.eprintf "trace-fuchsia error: %s\n%!" s) + +let ( let@ ) = ( @@ ) +let spf = Printf.sprintf diff --git a/src/fuchsia/dune b/src/fuchsia/dune index 32bd35e..f8fd6c6 100644 --- a/src/fuchsia/dune +++ b/src/fuchsia/dune @@ -4,5 +4,7 @@ (name trace_fuchsia) (public_name trace-fuchsia) (synopsis "A high-performance backend for trace, emitting a Fuchsia trace into a file") + (flags :standard -w -27) ; TODO: remove (libraries trace.core trace.private.util thread-local-storage + (re_export trace-fuchsia.write) mtime mtime.clock.os atomic unix threads)) diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml new file mode 100644 index 0000000..ecfb046 --- /dev/null +++ b/src/fuchsia/fcollector.ml @@ -0,0 +1,265 @@ +open Trace_core +open Common_ +module TLS = Thread_local_storage + +let pid = Unix.getpid () + +type state = { + active: bool A.t; + events: Bg_thread.event B_queue.t; + span_id_gen: int A.t; (** Used for async spans *) + bg_thread: Thread.t; + buf_pool: Buf_pool.t; + next_thread_ref: int A.t; (** in [0x01 .. 0xff], to allocate thread refs *) +} + +type span_info = { + start_time_ns: int64; + name: string; + mutable data: (string * user_data) list; +} + +(* TODO: + (** 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 () +*) + +open struct + let state_id_ = A.make 0 + + (* re-raise exception with its backtrace *) + external reraise : exn -> 'a = "%reraise" +end + +type per_thread_state = { + tid: int; + state_id: int; (** ID of the current collector state *) + local_span_id_gen: int A.t; (** Used for thread-local spans *) + mutable thread_ref: FWrite.Thread_ref.t; + mutable out: Output.t option; + spans: span_info Span_tbl.t; (** In-flight spans *) +} + +let key_thread_local_st : per_thread_state TLS.key = + TLS.new_key (fun () -> + let tid = Thread.id @@ Thread.self () in + { + tid; + state_id = A.get state_id_; + thread_ref = FWrite.Thread_ref.inline ~pid ~tid; + local_span_id_gen = A.make 0; + out = None; + spans = Span_tbl.create 32; + }) + +let out_of_st (st : state) : Output.t = + FWrite.Output.create () ~buf_pool:st.buf_pool ~send_buf:(fun buf -> + if A.get st.active then ( + try B_queue.push st.events (E_write_buf buf) with B_queue.Closed -> () + )) + +module C (St : sig + val st : state +end) +() = +struct + open St + + let state_id = 1 + A.fetch_and_add state_id_ 1 + + (** prepare the thread's state *) + let[@inline never] update_local_state (self : per_thread_state) : unit = + (* get an output *) + let out = out_of_st st in + self.out <- Some out; + + (* try to allocate a thread ref for current thread *) + let th_ref = A.fetch_and_add st.next_thread_ref 1 in + if th_ref <= 0xff then ( + self.thread_ref <- FWrite.Thread_ref.ref th_ref; + FWrite.Thread_record.encode out ~as_ref:th_ref ~tid:self.tid ~pid () + ); + () + + (** Obtain the output for the current thread *) + let[@inline] get_thread_output () : Output.t * per_thread_state = + let st = TLS.get key_thread_local_st in + if st.state_id != state_id || st.out == None then update_local_state st; + Option.get st.out, st + + let shutdown () = + if A.exchange st.active false then ( + B_queue.close st.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 st.bg_thread + ) + + let enter_span ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~data name : span = + let tls = TLS.get key_thread_local_st in + let span = Int64.of_int (A.fetch_and_add tls.local_span_id_gen 1) in + let time_ns = Time.now_ns () in + Span_tbl.add tls.spans span { name; data; start_time_ns = time_ns }; + span + + let exit_span span : unit = + let out, tls = get_thread_output () in + let end_time_ns = Time.now_ns () in + match Span_tbl.find_opt tls.spans span with + | None -> !on_tracing_error (spf "unknown span %Ld" span) + | Some info -> + Span_tbl.remove tls.spans span; + FWrite.Event.Duration_complete.encode out ~name:info.name + ~t_ref:tls.thread_ref ~time_ns:info.start_time_ns ~end_time_ns + ~args:info.data () + + let with_span ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~data name f = + let out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + let span = Int64.of_int (A.fetch_and_add tls.local_span_id_gen 1) in + let info = { start_time_ns = time_ns; data; name } in + Span_tbl.add tls.spans span info; + + let[@inline] exit () : unit = + let end_time_ns = Time.now_ns () in + Span_tbl.remove tls.spans span; + FWrite.Event.Duration_complete.encode out ~name ~time_ns ~end_time_ns + ~t_ref:tls.thread_ref ~args:info.data () + in + + try + let x = f span in + exit (); + x + with exn -> + exit (); + reraise exn + + let add_data_to_span span data = + let tls = TLS.get key_thread_local_st in + match Span_tbl.find_opt tls.spans span with + | None -> !on_tracing_error (spf "unknown span %Ld" span) + | Some info -> info.data <- List.rev_append data info.data + + let enter_manual_span ~(parent : explicit_span option) ~flavor + ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name : explicit_span + = + assert false + (* TODO: + (* 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 = assert false + (* TODO: + 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 = assert false + (* TODO: + 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 out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + FWrite.Event.Instant.encode out ~name:msg ~time_ns ~t_ref:tls.thread_ref + ~args:data () + + let counter_float ~data name f = + let out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + FWrite.Event.Counter.encode out ~name:"c" ~time_ns ~t_ref:tls.thread_ref + ~args:((name, `Float f) :: data) + () + + let counter_int ~data name i = + let out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + FWrite.Event.Counter.encode out ~name:"c" ~time_ns ~t_ref:tls.thread_ref + ~args:((name, `Int i) :: data) + () + + let name_process name : unit = () + (* TODO: B_queue.push events (E_name_process { name }) *) + + let name_thread name : unit = () + (* TODO: + let tid = get_tid_ () in + B_queue.push events (E_name_thread { tid; name }) + *) +end + +let create ~out () : collector = + let buf_pool = Buf_pool.create () in + let events = B_queue.create () in + + let bg_thread = + Thread.create (Bg_thread.bg_thread ~buf_pool ~out ~events) () + in + let _tick_thread = Thread.create Bg_thread.tick_thread events in + + let st = + { + active = A.make true; + buf_pool; + bg_thread; + events; + span_id_gen = A.make 0; + next_thread_ref = A.make 1; + } + in + + (* write header *) + let out = out_of_st st in + FWrite.Metadata.Magic_record.encode out; + FWrite.Metadata.Initialization_record.( + encode out ~ticks_per_secs:default_ticks_per_sec ()); + FWrite.Metadata.Provider_info.encode out ~id:0 ~name:"ocaml-trace" (); + Output.flush out; + Output.dispose out; + + let module Coll = + C + (struct + let st = st + end) + () + in + (module Coll) diff --git a/src/fuchsia/fcollector.mli b/src/fuchsia/fcollector.mli new file mode 100644 index 0000000..780b3f1 --- /dev/null +++ b/src/fuchsia/fcollector.mli @@ -0,0 +1,3 @@ +open Trace_core + +val create : out:Bg_thread.out -> unit -> collector diff --git a/src/fuchsia/global_.ml.tmp b/src/fuchsia/global_.ml.tmp new file mode 100644 index 0000000..49df805 --- /dev/null +++ b/src/fuchsia/global_.ml.tmp @@ -0,0 +1,4 @@ +(** A bit of global state that can be reached + from each thread without too much overhead *) + +open Common_ diff --git a/src/fuchsia/time.ml b/src/fuchsia/time.ml index dd11ae5..d988369 100644 --- a/src/fuchsia/time.ml +++ b/src/fuchsia/time.ml @@ -1,20 +1,6 @@ -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 - ) + 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 index 68e7c42..102a744 100644 --- a/src/fuchsia/trace_fuchsia.ml +++ b/src/fuchsia/trace_fuchsia.ml @@ -1,416 +1,31 @@ -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 collector = Fcollector.create 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 -> Trace_core.setup_collector @@ Fcollector.create ~out:`Stderr () + | `Stdout -> Trace_core.setup_collector @@ Fcollector.create ~out:`Stdout () + | `File path -> + Trace_core.setup_collector @@ Fcollector.create ~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 + let c = Fcollector.create ~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 "stdout" -> + Trace_core.setup_collector @@ Fcollector.create ~out:`Stdout () + | Some "stderr" -> + Trace_core.setup_collector @@ Fcollector.create ~out:`Stderr () | Some path -> - let c = collector ~out:(`File path) () in + let c = Fcollector.create ~out:(`File path) () in Trace_core.setup_collector c | None -> ()) @@ -419,6 +34,5 @@ let with_setup ?out () f = 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 index f6fa66e..b08620a 100644 --- a/src/fuchsia/trace_fuchsia.mli +++ b/src/fuchsia/trace_fuchsia.mli @@ -40,9 +40,6 @@ val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a (**/**) 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/buf.ml b/src/fuchsia/write/buf.ml new file mode 100644 index 0000000..2b13b34 --- /dev/null +++ b/src/fuchsia/write/buf.ml @@ -0,0 +1,42 @@ +open Util + +type t = { + buf: bytes; + mutable offset: int; +} + +let empty : t = { buf = Bytes.empty; offset = 0 } + +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] available self = Bytes.length self.buf - self.offset +let[@inline] size self = self.offset + +(* 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 *) + assert (len + missing + self.offset < Bytes.length self.buf); + Bytes.unsafe_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 diff --git a/src/fuchsia/write/buf_pool.ml b/src/fuchsia/write/buf_pool.ml new file mode 100644 index 0000000..fc9cf45 --- /dev/null +++ b/src/fuchsia/write/buf_pool.ml @@ -0,0 +1,58 @@ +open struct + module A = Atomic + + exception Got_buf of Buf.t +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 t = { + max_len: int; + buf_size: int; + bufs: Buf.t List_with_len.t A.t; +} + +let create ?(max_len = 64) ?(buf_size = 1 lsl 16) () : t = + let buf_size = min (1 lsl 22) (max buf_size (1 lsl 15)) in + { max_len; buf_size; bufs = A.make List_with_len.empty } + +let alloc (self : t) : Buf.t = + try + while + match A.get self.bufs with + | Nil -> false + | Cons (_, buf, tl) as old -> + if A.compare_and_set self.bufs old tl then + raise (Got_buf buf) + else + false + do + () + done; + Buf.create self.buf_size + with Got_buf b -> b + +let recycle (self : t) (buf : Buf.t) : unit = + Buf.clear buf; + try + while + match A.get self.bufs with + | Cons (i, _, _) when i >= self.max_len -> raise Exit + | old -> + not (A.compare_and_set self.bufs old (List_with_len.cons buf old)) + do + () + done + with Exit -> () (* do not recycle *) diff --git a/src/fuchsia/write/dune b/src/fuchsia/write/dune index c4d7ad1..9b8634d 100644 --- a/src/fuchsia/write/dune +++ b/src/fuchsia/write/dune @@ -3,4 +3,7 @@ (name trace_fuchsia_write) (public_name trace-fuchsia.write) (synopsis "Serialization part of trace-fuchsia") + (ocamlopt_flags :standard -S + ;-dlambda + ) (libraries trace.core atomic threads)) diff --git a/src/fuchsia/write/output.ml b/src/fuchsia/write/output.ml new file mode 100644 index 0000000..3911192 --- /dev/null +++ b/src/fuchsia/write/output.ml @@ -0,0 +1,46 @@ +type t = { + mutable buf: Buf.t; + mutable send_buf: Buf.t -> unit; + buf_pool: Buf_pool.t; +} + +let create ~(buf_pool : Buf_pool.t) ~send_buf () : t = + let buf_size = buf_pool.buf_size in + let buf = Buf.create buf_size in + { buf; send_buf; buf_pool } + +open struct + let flush_ (self : t) : unit = + self.send_buf self.buf; + let buf = Buf_pool.alloc self.buf_pool in + self.buf <- buf + + let[@inline never] cycle_buf (self : t) ~available : Buf.t = + flush_ self; + let buf = self.buf in + + if Buf.available buf < available then + failwith "fuchsia: buffer is too small"; + buf +end + +let[@inline] flush (self : t) : unit = if Buf.size self.buf > 0 then flush_ self + +(** Obtain a buffer with at least [available] bytes *) +let[@inline] get_buf (self : t) ~(available_word : int) : Buf.t = + let available = available_word lsl 3 in + if Buf.available self.buf >= available then + self.buf + else + cycle_buf self ~available + +let into_buffer ~buf_pool (buffer : Buffer.t) : t = + let send_buf (buf : Buf.t) = + Buffer.add_subbytes buffer buf.buf 0 buf.offset + in + create ~buf_pool ~send_buf () + +let dispose (self : t) : unit = + flush_ self; + Buf_pool.recycle self.buf_pool self.buf; + self.buf <- Buf.empty diff --git a/src/fuchsia/write/trace_fuchsia_write.ml b/src/fuchsia/write/trace_fuchsia_write.ml index 4bed4cb..8791f9a 100644 --- a/src/fuchsia/write/trace_fuchsia_write.ml +++ b/src/fuchsia/write/trace_fuchsia_write.ml @@ -2,53 +2,17 @@ Reference: https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format *) -module B = Bytes +module Util = Util +module Buf = Buf +module Output = Output +module Buf_pool = Buf_pool 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 @@ -85,6 +49,8 @@ module Thread_ref = struct 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"; @@ -108,7 +74,10 @@ module Metadata = struct module Magic_record = struct let value = 0x0016547846040010L let size_word = 1 - let encode (buf : Buf.t) = Buf.add_i64 buf value + + let encode (out : Output.t) = + let buf = Output.get_buf out ~available_word:size_word in + Buf.add_i64 buf value end module Initialization_record = struct @@ -117,7 +86,8 @@ module Metadata = struct (** Default: 1 tick = 1 ns *) let default_ticks_per_sec = 1_000_000_000L - let encode (buf : Buf.t) ~ticks_per_secs () : unit = + let encode (out : Output.t) ~ticks_per_secs () : unit = + let buf = Output.get_buf out ~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 @@ -126,8 +96,9 @@ module Metadata = struct module Provider_info = struct let size_word ~name () = 1 + (round_to_word (String.length name) lsr 3) - let encode buf ~(id : int) ~name () : unit = + let encode (out : Output.t) ~(id : int) ~name () : unit = let size = size_word ~name () in + let buf = Output.get_buf out ~available_word:size in let hd = I64.( (of_int size lsl 4) @@ -216,17 +187,30 @@ 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 = List.length self in + 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) = - List.fold_left (fun n arg -> n + Argument.size_word arg) 0 self - - let encode (buf : Buf.t) (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 | [] -> () @@ -234,7 +218,13 @@ module Arguments = struct Argument.encode buf x; aux buf tl in - aux buf self + + match self with + | [] -> () + | [ x ] -> Argument.encode buf x + | x :: tl -> + Argument.encode buf x; + aux buf tl end (** record type = 3 *) @@ -242,9 +232,12 @@ module Thread_record = struct let size_word : int = 3 (** Record that [Thread_ref.ref as_ref] represents the pair [pid, tid] *) - let encode (buf : Buf.t) ~as_ref ~pid ~tid () : unit = + let encode (out : Output.t) ~as_ref ~pid ~tid () : unit = if as_ref <= 0 || as_ref > 255 then invalid_arg "fuchsia: thread_record: invalid ref"; + + let buf = Output.get_buf out ~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); @@ -253,21 +246,59 @@ 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 *) + (round_to_word (String.length name) / 8) + Arguments.size_word args - let encode (buf : Buf.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () : - unit = + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () + : unit = let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~available_word:size 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 (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 *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + 1 (* counter id *) + + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () + : unit = + let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~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 @@ -282,25 +313,100 @@ module Event = struct 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 *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () + : unit = + let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~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 *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args () + : unit = + let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~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 *) + (round_to_word (String.length name) lsr 3) + Arguments.size_word args + 1 (* end timestamp *) - let encode (buf : Buf.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~end_time_ns - ~args () : unit = + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns + ~end_time_ns ~args () : unit = let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~available_word:size in + (* set category = 0 *) let hd = I64.( 4L lor (of_int size lsl 4) lor (4L lsl 16) - lor (of_int (List.length args) lsl 20) + 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 diff --git a/src/fuchsia/write/util.ml b/src/fuchsia/write/util.ml new file mode 100644 index 0000000..7af7dec --- /dev/null +++ b/src/fuchsia/write/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) From a1fa6e267b575d4a991fbbf4ae8e775a10781047 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 22:53:18 -0500 Subject: [PATCH 08/21] gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 9a70a80..da14214 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ _opam _build *.json *.exe +perf.* +*.fxt From f34671b05cd07f890308a2100fa4f10dedd436bf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 25 Dec 2023 22:53:25 -0500 Subject: [PATCH 09/21] bench and tests for fuchsia --- bench/bench_fuchsia_write.ml | 58 +++++++++++++++++++++++++++++++++ bench/dune | 12 +++++++ bench/trace_fx.ml | 42 ++++++++++++++++++++++++ bench_fx.sh | 3 ++ dune | 2 +- test/fuchsia/write/t2.ml | 62 ++++++++++++++++++++++-------------- 6 files changed, 154 insertions(+), 25 deletions(-) create mode 100644 bench/bench_fuchsia_write.ml create mode 100644 bench/trace_fx.ml create mode 100755 bench_fx.sh diff --git a/bench/bench_fuchsia_write.ml b/bench/bench_fuchsia_write.ml new file mode 100644 index 0000000..a62149e --- /dev/null +++ b/bench/bench_fuchsia_write.ml @@ -0,0 +1,58 @@ +open Trace_fuchsia_write +module B = Benchmark + +let pf = Printf.printf + +let encode_1_span (out : Output.t) () = + Event.Duration_complete.encode out ~name:"span" ~t_ref:(Thread_ref.Ref 5) + ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] () + +let encode_3_span (out : Output.t) () = + Event.Duration_complete.encode out ~name:"outer" ~t_ref:(Thread_ref.Ref 5) + ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] (); + Event.Duration_complete.encode out ~name:"inner" ~t_ref:(Thread_ref.Ref 5) + ~time_ns:180_000L ~end_time_ns:4_500_000L ~args:[] (); + Event.Instant.encode out ~name:"hello" ~time_ns:1_234_567L + ~t_ref:(Thread_ref.Ref 5) + ~args:[ "x", `Int 42 ] + () + +let time_per_iter_ns (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 + +let () = + let buf_pool = Buf_pool.create () in + let out = + Output.create ~buf_pool + ~send_buf:(fun buf -> Buf_pool.recycle buf_pool buf) + () + in + + let samples = B.throughput1 4 ~name:"encode_1_span" (encode_1_span out) () in + B.print_gc samples; + + let [ (_, samples) ] = samples [@@warning "-8"] in + + let iter_per_ns = time_per_iter_ns samples in + pf "%.3f ns/iter\n" iter_per_ns; + + () + +let () = + let buf_pool = Buf_pool.create () in + let out = + Output.create ~buf_pool + ~send_buf:(fun buf -> Buf_pool.recycle buf_pool buf) + () + in + + let samples = B.throughput1 4 ~name:"encode_3_span" (encode_3_span out) () in + B.print_gc samples; + () diff --git a/bench/dune b/bench/dune index c6fec56..ade51c9 100644 --- a/bench/dune +++ b/bench/dune @@ -1,4 +1,16 @@ (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 bench_fuchsia_write) + (modules bench_fuchsia_write) + (libraries benchmark trace-fuchsia.write)) diff --git a/bench/trace_fx.ml b/bench/trace_fx.ml new file mode 100644 index 0000000..aea9221 --- /dev/null +++ b/bench/trace_fx.ml @@ -0,0 +1,42 @@ +module Trace = Trace_core + +let ( let@ ) = ( @@ ) + +let work ~dom_idx ~n () : unit = + 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 ( + 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 + Array.iter Domain.join domains + +let () = + let@ () = Trace_fuchsia.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 () diff --git a/bench_fx.sh b/bench_fx.sh new file mode 100755 index 0000000..f2ba8ae --- /dev/null +++ b/bench_fx.sh @@ -0,0 +1,3 @@ +#!/bin/sh +DUNE_OPTS="--profile=release --display=quiet" +exec dune exec $DUNE_OPTS bench/trace_fx.exe -- $@ diff --git a/dune b/dune index 1b45a87..db65d82 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ (env - (_ (flags :standard -strict-sequence -warn-error -a+8+26+27 -w +a-4-40-44-70))) + (_ (flags :standard -strict-sequence -warn-error -a+8+26+27 -w +a-4-40-42-44-70))) diff --git a/test/fuchsia/write/t2.ml b/test/fuchsia/write/t2.ml index 9f08a70..0dcc5e9 100644 --- a/test/fuchsia/write/t2.ml +++ b/test/fuchsia/write/t2.ml @@ -40,36 +40,50 @@ module Str_ = struct Bytes.unsafe_to_string res end +let with_buf_output (f : Output.t -> unit) : string = + let buf_pool = Buf_pool.create () in + let buffer = Buffer.create 32 in + let out = Output.into_buffer ~buf_pool buffer in + f out; + Output.flush out; + Buffer.contents buffer + let () = pf "first trace\n" let () = - let buf = Buf.create 128 in - Metadata.Magic_record.encode buf; - Thread_record.encode buf ~as_ref:5 ~pid:1 ~tid:86 (); - Event.Instant.encode buf ~name:"hello" ~time_ns:1234_5678L - ~t_ref:(Thread_ref.Ref 5) - ~args:[ "x", `Int 42 ] - (); - pf "%s\n" (Buf.to_string buf |> Str_.to_hex) + let str = + with_buf_output (fun out -> + Metadata.Magic_record.encode out; + Thread_record.encode out ~as_ref:5 ~pid:1 ~tid:86 (); + Event.Instant.encode out ~name:"hello" ~time_ns:1234_5678L + ~t_ref:(Thread_ref.Ref 5) + ~args:[ "x", `Int 42 ] + ()) + in + pf "%s\n" (Str_.to_hex str) let () = pf "second trace\n" let () = - let buf = Buf.create 512 in - Metadata.Magic_record.encode buf; - Metadata.Initialization_record.( - encode buf ~ticks_per_secs:default_ticks_per_sec ()); - Thread_record.encode buf ~as_ref:5 ~pid:1 ~tid:86 (); - Metadata.Provider_info.encode buf ~id:1 ~name:"ocaml-trace" (); - Event.Duration_complete.encode buf ~name:"outer" ~t_ref:(Thread_ref.Ref 5) - ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] (); - Event.Duration_complete.encode buf ~name:"inner" ~t_ref:(Thread_ref.Ref 5) - ~time_ns:180_000L ~end_time_ns:4_500_000L ~args:[] (); - Event.Instant.encode buf ~name:"hello" ~time_ns:1_234_567L - ~t_ref:(Thread_ref.Ref 5) - ~args:[ "x", `Int 42 ] - (); + let str = + with_buf_output (fun out -> + Metadata.Magic_record.encode out; + Metadata.Initialization_record.( + encode out ~ticks_per_secs:default_ticks_per_sec ()); + Thread_record.encode out ~as_ref:5 ~pid:1 ~tid:86 (); + Metadata.Provider_info.encode out ~id:1 ~name:"ocaml-trace" (); + Event.Duration_complete.encode out ~name:"outer" + ~t_ref:(Thread_ref.Ref 5) ~time_ns:100_000L ~end_time_ns:5_000_000L + ~args:[] (); + Event.Duration_complete.encode out ~name:"inner" + ~t_ref:(Thread_ref.Ref 5) ~time_ns:180_000L ~end_time_ns:4_500_000L + ~args:[] (); + Event.Instant.encode out ~name:"hello" ~time_ns:1_234_567L + ~t_ref:(Thread_ref.Ref 5) + ~args:[ "x", `Int 42 ] + ()) + in (let oc = open_out "foo.fxt" in - output_string oc (Buf.to_string buf); + output_string oc str; close_out oc); - pf "%s\n" (Buf.to_string buf |> Str_.to_hex) + pf "%s\n" (Str_.to_hex str) From 713cf6b4cff9c254590d2010f66ff09d2f8f059c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 00:56:49 -0500 Subject: [PATCH 10/21] fuchsia: metadata events --- bench/trace_fx.ml | 6 + src/fuchsia/bg_thread.ml | 8 +- src/fuchsia/fcollector.ml | 165 ++++++++++++----------- src/fuchsia/write/trace_fuchsia_write.ml | 107 +++++++++++++++ 4 files changed, 206 insertions(+), 80 deletions(-) diff --git a/bench/trace_fx.ml b/bench/trace_fx.ml index aea9221..fdf65c9 100644 --- a/bench/trace_fx.ml +++ b/bench/trace_fx.ml @@ -3,6 +3,7 @@ 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 ]; @@ -23,10 +24,15 @@ 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_fxt"; + + let%trace () = "main" in let n = ref 10_000 in let j = ref 4 in diff --git a/src/fuchsia/bg_thread.ml b/src/fuchsia/bg_thread.ml index 1ac6aa0..8664452 100644 --- a/src/fuchsia/bg_thread.ml +++ b/src/fuchsia/bg_thread.ml @@ -64,11 +64,13 @@ let bg_thread ~buf_pool ~out ~(events : event B_queue.t) () : unit = *) (** 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 = + the background thread so it has a chance to write to the file, + and call [f()] *) +let tick_thread events ~f : unit = try while true do Thread.delay 0.5; - B_queue.push events E_tick + B_queue.push events E_tick; + f () done with B_queue.Closed -> () diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index ecfb046..5c661c2 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -1,34 +1,24 @@ open Trace_core open Common_ module TLS = Thread_local_storage +module Int_map = Map.Make (Int) let pid = Unix.getpid () -type state = { - active: bool A.t; - events: Bg_thread.event B_queue.t; - span_id_gen: int A.t; (** Used for async spans *) - bg_thread: Thread.t; - buf_pool: Buf_pool.t; - next_thread_ref: int A.t; (** in [0x01 .. 0xff], to allocate thread refs *) -} - type span_info = { start_time_ns: int64; name: string; mutable data: (string * user_data) list; } -(* TODO: - (** 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 () +type async_span_info = { + async_id: int; + flavor: [ `Sync | `Async ] option; + name: string; + mutable data: (string * user_data) list; +} - let key_data : (string * user_data) list ref Meta_map.Key.t = - Meta_map.Key.create () -*) +let key_async_data : async_span_info Meta_map.Key.t = Meta_map.Key.create () open struct let state_id_ = A.make 0 @@ -46,6 +36,16 @@ type per_thread_state = { spans: span_info Span_tbl.t; (** In-flight spans *) } +type state = { + active: bool A.t; + events: Bg_thread.event B_queue.t; + span_id_gen: int A.t; (** Used for async spans *) + bg_thread: Thread.t; + buf_pool: Buf_pool.t; + next_thread_ref: int A.t; (** in [0x01 .. 0xff], to allocate thread refs *) + threads: per_thread_state Int_map.t A.t; +} + let key_thread_local_st : per_thread_state TLS.key = TLS.new_key (fun () -> let tid = Thread.id @@ Thread.self () in @@ -64,6 +64,12 @@ let out_of_st (st : state) : Output.t = try B_queue.push st.events (E_write_buf buf) with B_queue.Closed -> () )) +let flush_all_ (st : state) = + let outs = A.get st.threads in + + Int_map.iter (fun _tid (tls : per_thread_state) -> ()) outs; + () + module C (St : sig val st : state end) @@ -85,16 +91,28 @@ struct self.thread_ref <- FWrite.Thread_ref.ref th_ref; FWrite.Thread_record.encode out ~as_ref:th_ref ~tid:self.tid ~pid () ); + + (* add to [st]'s list of threads *) + while + let old = A.get st.threads in + not (A.compare_and_set st.threads old (Int_map.add self.tid self old)) + do + () + done; + () (** Obtain the output for the current thread *) let[@inline] get_thread_output () : Output.t * per_thread_state = - let st = TLS.get key_thread_local_st in - if st.state_id != state_id || st.out == None then update_local_state st; - Option.get st.out, st + let tls = TLS.get key_thread_local_st in + if tls.state_id != state_id || tls.out == None then update_local_state tls; + Option.get tls.out, tls let shutdown () = if A.exchange st.active false then ( + (* flush all outputs *) + flush_all_ st; + B_queue.close st.events; (* wait for writer thread to be done. The writer thread will exit after processing remaining events because the queue is now closed *) @@ -147,54 +165,40 @@ struct | None -> !on_tracing_error (spf "unknown span %Ld" span) | Some info -> info.data <- List.rev_append data info.data - let enter_manual_span ~(parent : explicit_span option) ~flavor - ~__FUNCTION__:fun_name ~__FILE__:_ ~__LINE__:_ ~data name : explicit_span - = - assert false - (* TODO: - (* 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 = assert false - (* TODO: - 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 = assert false - (* TODO: - 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 enter_manual_span ~(parent : explicit_span option) ~flavor ~__FUNCTION__:_ + ~__FILE__:_ ~__LINE__:_ ~data name : explicit_span = + let out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + + (* get the id, or make a new one *) + let async_id = + match parent with + | Some m -> (Meta_map.find_exn key_async_data m.meta).async_id + | None -> A.fetch_and_add st.span_id_gen 1 + in + + FWrite.Event.Async_begin.encode out ~name ~args:data ~t_ref:tls.thread_ref + ~time_ns ~async_id (); + { + span = 0L; + meta = + Meta_map.( + empty |> add key_async_data { async_id; name; flavor; data = [] }); + } + + let exit_manual_span (es : explicit_span) : unit = + let { async_id; name; data; flavor = _ } = + Meta_map.find_exn key_async_data es.meta + in + let out, tls = get_thread_output () in + let time_ns = Time.now_ns () in + + FWrite.Event.Async_end.encode out ~name ~t_ref:tls.thread_ref ~time_ns + ~args:data ~async_id () + + let add_data_to_manual_span (es : explicit_span) data = + let m = Meta_map.find_exn key_async_data es.meta in + m.data <- List.rev_append data m.data let message ?span:_ ~data msg : unit = let out, tls = get_thread_output () in @@ -216,14 +220,16 @@ struct ~args:((name, `Int i) :: data) () - let name_process name : unit = () - (* TODO: B_queue.push events (E_name_process { name }) *) + let name_process name : unit = + let out, tls = get_thread_output () in + FWrite.Kernel_object.(encode out ~name ~ty:ty_process ~kid:pid ~args:[] ()) - let name_thread name : unit = () - (* TODO: - let tid = get_tid_ () in - B_queue.push events (E_name_thread { tid; name }) - *) + let name_thread name : unit = + let out, tls = get_thread_output () in + FWrite.Kernel_object.( + encode out ~name ~ty:ty_thread ~kid:tls.tid + ~args:[ "process", `Int pid ] + ()) end let create ~out () : collector = @@ -233,7 +239,6 @@ let create ~out () : collector = let bg_thread = Thread.create (Bg_thread.bg_thread ~buf_pool ~out ~events) () in - let _tick_thread = Thread.create Bg_thread.tick_thread events in let st = { @@ -243,9 +248,15 @@ let create ~out () : collector = events; span_id_gen = A.make 0; next_thread_ref = A.make 1; + threads = A.make Int_map.empty; } in + let _tick_thread = + Thread.create (fun () -> + Bg_thread.tick_thread events ~f:(fun () -> flush_all_ st)) + in + (* write header *) let out = out_of_st st in FWrite.Metadata.Magic_record.encode out; diff --git a/src/fuchsia/write/trace_fuchsia_write.ml b/src/fuchsia/write/trace_fuchsia_write.ml index 8791f9a..723b3c4 100644 --- a/src/fuchsia/write/trace_fuchsia_write.ml +++ b/src/fuchsia/write/trace_fuchsia_write.ml @@ -424,4 +424,111 @@ module Event = struct 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 *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + 1 (* async id *) + + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns + ~(async_id : int) ~args () : unit = + let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~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 (I64.of_int 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 *) + (round_to_word (String.length name) lsr 3) + + Arguments.size_word args + 1 (* async id *) + + let encode (out : Output.t) ~name ~(t_ref : Thread_ref.t) ~time_ns + ~(async_id : int) ~args () : unit = + let size = size_word ~name ~t_ref ~args () in + let buf = Output.get_buf out ~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 (I64.of_int async_id); + () + end +end + +(** record type = 7 *) +module Kernel_object = struct + let size_word ~name ~args () : int = + 1 + 1 + (* id *) + (round_to_word (String.length name) lsr 3) + + 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 (out : Output.t) ~name ~(ty : ty) ~(kid : int) ~args () : unit = + let size = size_word ~name ~args () in + let buf = Output.get_buf out ~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 From 56d3117d06c8c5a598ea01e17dd61a68655ac29f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 01:14:14 -0500 Subject: [PATCH 11/21] do not drop events still in buffers at exit --- src/fuchsia/bg_thread.ml | 5 +- src/fuchsia/fcollector.ml | 47 ++++++++++++------- src/util/cpu_relax.real.ml | 1 - ...pu_relax.dummy.ml => domain_util.dummy.ml} | 1 + src/util/{cpu_relax.mli => domain_util.mli} | 1 + src/util/domain_util.real.ml | 2 + src/util/dune | 6 +-- src/util/mpsc_bag.ml | 2 +- 8 files changed, 39 insertions(+), 26 deletions(-) delete mode 100644 src/util/cpu_relax.real.ml rename src/util/{cpu_relax.dummy.ml => domain_util.dummy.ml} (51%) rename src/util/{cpu_relax.mli => domain_util.mli} (50%) create mode 100644 src/util/domain_util.real.ml diff --git a/src/fuchsia/bg_thread.ml b/src/fuchsia/bg_thread.ml index 8664452..b8c9100 100644 --- a/src/fuchsia/bg_thread.ml +++ b/src/fuchsia/bg_thread.ml @@ -66,11 +66,10 @@ let bg_thread ~buf_pool ~out ~(events : event B_queue.t) () : unit = (** Thread that simply regularly "ticks", sending events to the background thread so it has a chance to write to the file, and call [f()] *) -let tick_thread events ~f : unit = +let tick_thread events : unit = try while true do Thread.delay 0.5; - B_queue.push events E_tick; - f () + B_queue.push events E_tick done with B_queue.Closed -> () diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index 5c661c2..d66a822 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -43,7 +43,9 @@ type state = { bg_thread: Thread.t; buf_pool: Buf_pool.t; next_thread_ref: int A.t; (** in [0x01 .. 0xff], to allocate thread refs *) - threads: per_thread_state Int_map.t A.t; + per_thread: per_thread_state Int_map.t A.t; + (** the state keeps tabs on thread-local state, so it can flush writers + at the end *) } let key_thread_local_st : per_thread_state TLS.key = @@ -60,15 +62,7 @@ let key_thread_local_st : per_thread_state TLS.key = let out_of_st (st : state) : Output.t = FWrite.Output.create () ~buf_pool:st.buf_pool ~send_buf:(fun buf -> - if A.get st.active then ( - try B_queue.push st.events (E_write_buf buf) with B_queue.Closed -> () - )) - -let flush_all_ (st : state) = - let outs = A.get st.threads in - - Int_map.iter (fun _tid (tls : per_thread_state) -> ()) outs; - () + try B_queue.push st.events (E_write_buf buf) with B_queue.Closed -> ()) module C (St : sig val st : state @@ -94,12 +88,24 @@ struct (* add to [st]'s list of threads *) while - let old = A.get st.threads in - not (A.compare_and_set st.threads old (Int_map.add self.tid self old)) + let old = A.get st.per_thread in + not (A.compare_and_set st.per_thread old (Int_map.add self.tid self old)) do () done; + let on_exit _ = + while + let old = A.get st.per_thread in + not (A.compare_and_set st.per_thread old (Int_map.remove self.tid old)) + do + () + done; + Option.iter Output.flush self.out + in + + (* after thread exits, flush output and remove from global list *) + Gc.finalise on_exit (Thread.self ()); () (** Obtain the output for the current thread *) @@ -111,7 +117,15 @@ struct let shutdown () = if A.exchange st.active false then ( (* flush all outputs *) - flush_all_ st; + let tls_l = A.get st.per_thread in + + (* FIXME: there's a potential race condition here. How to fix it + without overhead on every regular event? *) + Int_map.iter + (fun _tid (tls : per_thread_state) -> + Printf.eprintf "flush for %d\n%!" tls.tid; + Option.iter Output.flush tls.out) + tls_l; B_queue.close st.events; (* wait for writer thread to be done. The writer thread will exit @@ -248,14 +262,11 @@ let create ~out () : collector = events; span_id_gen = A.make 0; next_thread_ref = A.make 1; - threads = A.make Int_map.empty; + per_thread = A.make Int_map.empty; } in - let _tick_thread = - Thread.create (fun () -> - Bg_thread.tick_thread events ~f:(fun () -> flush_all_ st)) - in + let _tick_thread = Thread.create (fun () -> Bg_thread.tick_thread events) in (* write header *) let out = out_of_st st in diff --git a/src/util/cpu_relax.real.ml b/src/util/cpu_relax.real.ml deleted file mode 100644 index f3dab5c..0000000 --- a/src/util/cpu_relax.real.ml +++ /dev/null @@ -1 +0,0 @@ -let cpu_relax = Domain.cpu_relax diff --git a/src/util/cpu_relax.dummy.ml b/src/util/domain_util.dummy.ml similarity index 51% rename from src/util/cpu_relax.dummy.ml rename to src/util/domain_util.dummy.ml index 3c5fd6f..2a59baf 100644 --- a/src/util/cpu_relax.dummy.ml +++ b/src/util/domain_util.dummy.ml @@ -1 +1,2 @@ let cpu_relax () = () +let n_domains () = 1 diff --git a/src/util/cpu_relax.mli b/src/util/domain_util.mli similarity index 50% rename from src/util/cpu_relax.mli rename to src/util/domain_util.mli index 17542a8..666b1f5 100644 --- a/src/util/cpu_relax.mli +++ b/src/util/domain_util.mli @@ -1 +1,2 @@ val cpu_relax : unit -> unit +val n_domains : unit -> int diff --git a/src/util/domain_util.real.ml b/src/util/domain_util.real.ml new file mode 100644 index 0000000..ea4c225 --- /dev/null +++ b/src/util/domain_util.real.ml @@ -0,0 +1,2 @@ +let cpu_relax = Domain.cpu_relax +let n_domains = Domain.recommended_domain_count diff --git a/src/util/dune b/src/util/dune index fc5fb6f..7d7f2a4 100644 --- a/src/util/dune +++ b/src/util/dune @@ -4,6 +4,6 @@ (synopsis "internal utilities for trace. No guarantees of stability.") (name trace_private_util) (libraries trace.core mtime mtime.clock.os atomic unix threads - (select cpu_relax.ml from - (base-domain -> cpu_relax.real.ml) - ( -> cpu_relax.dummy.ml)))) + (select domain_util.ml from + (base-domain -> domain_util.real.ml) + ( -> domain_util.dummy.ml)))) diff --git a/src/util/mpsc_bag.ml b/src/util/mpsc_bag.ml index 453357f..a8f49aa 100644 --- a/src/util/mpsc_bag.ml +++ b/src/util/mpsc_bag.ml @@ -11,7 +11,7 @@ module Backoff = struct let once (b : t) : t = for _i = 1 to b do - Cpu_relax.cpu_relax () + Domain_util.cpu_relax () done; min (b * 2) 256 end From ca22f07ca310d9bbee281753016c042d299ef394 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 21:20:43 -0500 Subject: [PATCH 12/21] fix fuchsia: proper implem for setting thread name --- bench/trace_fx.ml | 3 ++- src/fuchsia/fcollector.ml | 2 +- src/fuchsia/write/trace_fuchsia_write.ml | 25 +++++++++++++++--------- 3 files changed, 19 insertions(+), 11 deletions(-) diff --git a/bench/trace_fx.ml b/bench/trace_fx.ml index fdf65c9..cf55da8 100644 --- a/bench/trace_fx.ml +++ b/bench/trace_fx.ml @@ -30,7 +30,8 @@ let main ~n ~j () : unit = let () = let@ () = Trace_fuchsia.with_setup () in - Trace_core.set_process_name "trace_fxt"; + Trace_core.set_process_name "trace_fxt1"; + Trace_core.set_thread_name "main"; let%trace () = "main" in diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index d66a822..f7219d3 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -242,7 +242,7 @@ struct let out, tls = get_thread_output () in FWrite.Kernel_object.( encode out ~name ~ty:ty_thread ~kid:tls.tid - ~args:[ "process", `Int pid ] + ~args:[ "process", `Kid pid ] ()) end diff --git a/src/fuchsia/write/trace_fuchsia_write.ml b/src/fuchsia/write/trace_fuchsia_write.ml index 723b3c4..ebcc8cf 100644 --- a/src/fuchsia/write/trace_fuchsia_write.ml +++ b/src/fuchsia/write/trace_fuchsia_write.ml @@ -115,14 +115,14 @@ module Metadata = struct end module Argument = struct - type t = string * user_data + type 'a t = string * ([< user_data | `Kid of int ] as 'a) let check_valid _ = () (* TODO: check string length *) let[@inline] is_i32_ (i : int) : bool = Int32.(to_int (of_int i) = i) - let size_word (self : t) = + let size_word (self : _ t) = let name, data = self in match data with | `None | `Bool _ -> 1 + (round_to_word (String.length name) lsr 3) @@ -133,12 +133,13 @@ module Argument = struct 1 + (round_to_word (String.length s) lsr 3) + (round_to_word (String.length name) lsr 3) + | `Kid _ -> 2 + (round_to_word (String.length name) lsr 3) open struct external int_of_bool : bool -> int = "%identity" end - let encode (buf : Buf.t) (self : t) : unit = + let encode (buf : Buf.t) (self : _ t) : unit = let name, data = self in let size = size_word self in @@ -182,25 +183,31 @@ module Argument = struct 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 + | `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 (I64.of_int kid) end module Arguments = struct - type t = Argument.t list + type 'a t = 'a Argument.t list - let[@inline] len (self : t) : int = + let[@inline] len (self : _ t) : int = match self with | [] -> 0 | [ _ ] -> 1 | _ :: _ :: tl -> 2 + List.length tl - let check_valid (self : t) = + 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) = + let[@inline] size_word (self : _ t) = match self with | [] -> 0 | [ a ] -> Argument.size_word a @@ -210,7 +217,7 @@ module Arguments = struct (Argument.size_word a + Argument.size_word b) tl - let[@inline] encode (buf : Buf.t) (self : t) = + let[@inline] encode (buf : Buf.t) (self : _ t) = let rec aux buf l = match l with | [] -> () @@ -502,7 +509,7 @@ end module Kernel_object = struct let size_word ~name ~args () : int = 1 + 1 - (* id *) + (round_to_word (String.length name) lsr 3) + + (round_to_word (String.length name) lsr 3) + Arguments.size_word args (* see: From c2551a7e4b12781d5b3d2c08fcdaf1b7b26bf066 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 21:21:23 -0500 Subject: [PATCH 13/21] fix warning --- src/fuchsia/dune | 1 - src/fuchsia/fcollector.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/fuchsia/dune b/src/fuchsia/dune index f8fd6c6..aedeea1 100644 --- a/src/fuchsia/dune +++ b/src/fuchsia/dune @@ -4,7 +4,6 @@ (name trace_fuchsia) (public_name trace-fuchsia) (synopsis "A high-performance backend for trace, emitting a Fuchsia trace into a file") - (flags :standard -w -27) ; TODO: remove (libraries trace.core trace.private.util thread-local-storage (re_export trace-fuchsia.write) mtime mtime.clock.os atomic unix threads)) diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index f7219d3..aa43342 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -235,7 +235,7 @@ struct () let name_process name : unit = - let out, tls = get_thread_output () in + let out, _tls = get_thread_output () in FWrite.Kernel_object.(encode out ~name ~ty:ty_process ~kid:pid ~args:[] ()) let name_thread name : unit = From 2e4971d23ddbf385eb734f9cbdcf7aa998ff4657 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 21:27:31 -0500 Subject: [PATCH 14/21] chore: we don't actually depend on `atomic` --- dune-project | 2 -- src/fuchsia/write/buf_pool.ml | 2 +- src/fuchsia/write/dune | 2 +- src/tef/dune | 2 +- trace-fuchsia.opam | 1 - trace-tef.opam | 1 - 6 files changed, 3 insertions(+), 7 deletions(-) diff --git a/dune-project b/dune-project index b355550..c65eada 100644 --- a/dune-project +++ b/dune-project @@ -41,7 +41,6 @@ (trace (= :version)) (mtime (>= 2.0)) base-unix - atomic dune) (tags (trace tracing catapult))) @@ -54,7 +53,6 @@ (trace (= :version)) (mtime (>= 2.0)) base-unix - atomic dune) (tags (trace tracing fuchsia))) diff --git a/src/fuchsia/write/buf_pool.ml b/src/fuchsia/write/buf_pool.ml index fc9cf45..961a2d3 100644 --- a/src/fuchsia/write/buf_pool.ml +++ b/src/fuchsia/write/buf_pool.ml @@ -1,5 +1,5 @@ open struct - module A = Atomic + module A = Trace_core.Internal_.Atomic_ exception Got_buf of Buf.t end diff --git a/src/fuchsia/write/dune b/src/fuchsia/write/dune index 9b8634d..b728e53 100644 --- a/src/fuchsia/write/dune +++ b/src/fuchsia/write/dune @@ -6,4 +6,4 @@ (ocamlopt_flags :standard -S ;-dlambda ) - (libraries trace.core atomic threads)) + (libraries trace.core threads)) diff --git a/src/tef/dune b/src/tef/dune index 89b8e9a..156eec1 100644 --- a/src/tef/dune +++ b/src/tef/dune @@ -3,4 +3,4 @@ (name trace_tef) (public_name trace-tef) (synopsis "Simple and lightweight tracing using TEF/Catapult format, in-process") - (libraries trace.core trace.private.util mtime mtime.clock.os atomic unix threads)) + (libraries trace.core trace.private.util mtime mtime.clock.os unix threads)) diff --git a/trace-fuchsia.opam b/trace-fuchsia.opam index 25428ba..20fa305 100644 --- a/trace-fuchsia.opam +++ b/trace-fuchsia.opam @@ -14,7 +14,6 @@ depends: [ "trace" {= version} "mtime" {>= "2.0"} "base-unix" - "atomic" "dune" {>= "2.9"} "odoc" {with-doc} ] diff --git a/trace-tef.opam b/trace-tef.opam index 464cee8..d984efa 100644 --- a/trace-tef.opam +++ b/trace-tef.opam @@ -14,7 +14,6 @@ depends: [ "trace" {= version} "mtime" {>= "2.0"} "base-unix" - "atomic" "dune" {>= "2.9"} "odoc" {with-doc} ] From bc92d97a76e65d9dc8afc93690e981ba70224491 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 26 Dec 2023 22:10:17 -0500 Subject: [PATCH 15/21] perf fuchsia: use a stack to hold in-flight spans, not a hashtable --- dune-project | 1 + src/fuchsia/bg_thread.ml | 12 --- src/fuchsia/common_.ml | 6 -- src/fuchsia/dune | 2 +- src/fuchsia/fcollector.ml | 188 ++++++++++++++++++++++++++++-------- src/fuchsia/write/output.ml | 16 ++- trace-fuchsia.opam | 1 + 7 files changed, 163 insertions(+), 63 deletions(-) diff --git a/dune-project b/dune-project index c65eada..0c7e4d7 100644 --- a/dune-project +++ b/dune-project @@ -52,6 +52,7 @@ (ocaml (>= 4.08)) (trace (= :version)) (mtime (>= 2.0)) + base-bigarray base-unix dune) (tags diff --git a/src/fuchsia/bg_thread.ml b/src/fuchsia/bg_thread.ml index b8c9100..ecaf1c0 100644 --- a/src/fuchsia/bg_thread.ml +++ b/src/fuchsia/bg_thread.ml @@ -51,18 +51,6 @@ let bg_thread ~buf_pool ~out ~(events : event B_queue.t) () : unit = let st = { oc; buf_pool; events } in bg_loop st -(* TODO: - (* 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, and call [f()] *) diff --git a/src/fuchsia/common_.ml b/src/fuchsia/common_.ml index 38ded80..14b78bf 100644 --- a/src/fuchsia/common_.ml +++ b/src/fuchsia/common_.ml @@ -5,12 +5,6 @@ module Buf = FWrite.Buf module Buf_pool = FWrite.Buf_pool module Output = FWrite.Output -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 index aedeea1..f67f2d4 100644 --- a/src/fuchsia/dune +++ b/src/fuchsia/dune @@ -5,5 +5,5 @@ (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 - (re_export trace-fuchsia.write) + (re_export trace-fuchsia.write) bigarray mtime mtime.clock.os atomic unix threads)) diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index aa43342..223def1 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -5,11 +5,101 @@ module Int_map = Map.Make (Int) let pid = Unix.getpid () -type span_info = { - start_time_ns: int64; - name: string; - mutable data: (string * user_data) list; -} +(** Thread-local stack of span info *) +module Span_info_stack : sig + type t + + val create : unit -> t + + val push : + t -> + span -> + name:string -> + start_time_ns:int64 -> + data:(string * user_data) list -> + unit + + val pop : t -> int64 * string * int64 * (string * user_data) list + val find_ : t -> span -> int option + val add_data : t -> int -> (string * user_data) list -> unit +end = struct + module BA = Bigarray + module BA1 = Bigarray.Array1 + + type int64arr = (int64, BA.int64_elt, BA.c_layout) BA1.t + + type t = { + mutable len: int; + mutable span: int64arr; + mutable start_time_ns: int64arr; + mutable name: string array; + mutable data: (string * user_data) list array; + } + + let create () : t = + { + len = 0; + span = BA1.create BA.Int64 BA.C_layout 64; + start_time_ns = BA1.create BA.Int64 BA.C_layout 64; + name = Array.make 64 ""; + data = Array.make 64 []; + } + + let[@inline] cap self = Array.length self.name + + let grow_ (self : t) : unit = + let new_cap = 2 * cap self in + let new_span = BA1.create BA.Int64 BA.C_layout new_cap in + BA1.blit self.span (BA1.sub new_span 0 self.len); + let new_startime_ns = BA1.create BA.Int64 BA.C_layout new_cap in + BA1.blit self.start_time_ns (BA1.sub new_startime_ns 0 self.len); + let new_name = Array.make new_cap "" in + Array.blit self.name 0 new_name 0 self.len; + let new_data = Array.make new_cap [] in + Array.blit self.data 0 new_data 0 self.len; + self.span <- new_span; + self.start_time_ns <- new_startime_ns; + self.name <- new_name; + self.data <- new_data + + let push (self : t) (span : int64) ~name ~start_time_ns ~data = + if cap self = self.len then grow_ self; + BA1.set self.span self.len span; + BA1.set self.start_time_ns self.len start_time_ns; + Array.set self.name self.len name; + Array.set self.data self.len data; + self.len <- self.len + 1 + + let pop (self : t) = + assert (self.len > 0); + self.len <- self.len - 1; + + let span = BA1.get self.span self.len in + let name = self.name.(self.len) in + let start_time_ns = BA1.get self.start_time_ns self.len in + let data = self.data.(self.len) in + + (* avoid holding onto old values *) + Array.set self.name self.len ""; + Array.set self.data self.len []; + + span, name, start_time_ns, data + + let[@inline] add_data self i d : unit = + assert (i < self.len); + self.data.(i) <- List.rev_append d self.data.(i) + + exception Found of int + + let[@inline] find_ (self : t) span : _ option = + try + for i = self.len - 1 downto 0 do + if Int64.equal (BA1.get self.span i) span then raise_notrace (Found i) + done; + + None + with Found i -> Some i +end type async_span_info = { async_id: int; @@ -33,7 +123,7 @@ type per_thread_state = { local_span_id_gen: int A.t; (** Used for thread-local spans *) mutable thread_ref: FWrite.Thread_ref.t; mutable out: Output.t option; - spans: span_info Span_tbl.t; (** In-flight spans *) + spans: Span_info_stack.t; (** In-flight spans *) } type state = { @@ -43,9 +133,9 @@ type state = { bg_thread: Thread.t; buf_pool: Buf_pool.t; next_thread_ref: int A.t; (** in [0x01 .. 0xff], to allocate thread refs *) - per_thread: per_thread_state Int_map.t A.t; + per_thread: per_thread_state Int_map.t A.t array; (** the state keeps tabs on thread-local state, so it can flush writers - at the end *) + at the end. This is a tid-sharded array of maps. *) } let key_thread_local_st : per_thread_state TLS.key = @@ -57,7 +147,7 @@ let key_thread_local_st : per_thread_state TLS.key = thread_ref = FWrite.Thread_ref.inline ~pid ~tid; local_span_id_gen = A.make 0; out = None; - spans = Span_tbl.create 32; + spans = Span_info_stack.create (); }) let out_of_st (st : state) : Output.t = @@ -74,7 +164,8 @@ struct let state_id = 1 + A.fetch_and_add state_id_ 1 (** prepare the thread's state *) - let[@inline never] update_local_state (self : per_thread_state) : unit = + let[@inline never] update_or_init_local_state (self : per_thread_state) : unit + = (* get an output *) let out = out_of_st st in self.out <- Some out; @@ -87,17 +178,22 @@ struct ); (* add to [st]'s list of threads *) + let shard_of_per_thread = st.per_thread.(self.tid land 0b1111) in while - let old = A.get st.per_thread in - not (A.compare_and_set st.per_thread old (Int_map.add self.tid self old)) + let old = A.get shard_of_per_thread in + not + (A.compare_and_set shard_of_per_thread old + (Int_map.add self.tid self old)) do () done; let on_exit _ = while - let old = A.get st.per_thread in - not (A.compare_and_set st.per_thread old (Int_map.remove self.tid old)) + let old = A.get shard_of_per_thread in + not + (A.compare_and_set shard_of_per_thread old + (Int_map.remove self.tid old)) do () done; @@ -111,21 +207,29 @@ struct (** Obtain the output for the current thread *) let[@inline] get_thread_output () : Output.t * per_thread_state = let tls = TLS.get key_thread_local_st in - if tls.state_id != state_id || tls.out == None then update_local_state tls; - Option.get tls.out, tls + if tls.state_id != state_id || tls.out == None then + update_or_init_local_state tls; + let out = + match tls.out with + | None -> assert false + | Some o -> o + in + out, tls + + let close_per_thread (tls : per_thread_state) = + Option.iter Output.flush tls.out + + (** flush all outputs *) + let flush_all_outputs_ () = + Array.iter + (fun shard -> + let tls_l = A.get shard in + Int_map.iter (fun _tid tls -> close_per_thread tls) tls_l) + st.per_thread let shutdown () = if A.exchange st.active false then ( - (* flush all outputs *) - let tls_l = A.get st.per_thread in - - (* FIXME: there's a potential race condition here. How to fix it - without overhead on every regular event? *) - Int_map.iter - (fun _tid (tls : per_thread_state) -> - Printf.eprintf "flush for %d\n%!" tls.tid; - Option.iter Output.flush tls.out) - tls_l; + flush_all_outputs_ (); B_queue.close st.events; (* wait for writer thread to be done. The writer thread will exit @@ -137,32 +241,34 @@ struct let tls = TLS.get key_thread_local_st in let span = Int64.of_int (A.fetch_and_add tls.local_span_id_gen 1) in let time_ns = Time.now_ns () in - Span_tbl.add tls.spans span { name; data; start_time_ns = time_ns }; + Span_info_stack.push tls.spans span ~name ~data ~start_time_ns:time_ns; span let exit_span span : unit = let out, tls = get_thread_output () in let end_time_ns = Time.now_ns () in - match Span_tbl.find_opt tls.spans span with - | None -> !on_tracing_error (spf "unknown span %Ld" span) - | Some info -> - Span_tbl.remove tls.spans span; - FWrite.Event.Duration_complete.encode out ~name:info.name - ~t_ref:tls.thread_ref ~time_ns:info.start_time_ns ~end_time_ns - ~args:info.data () + + let span', name, start_time_ns, data = Span_info_stack.pop tls.spans in + if span <> span' then + !on_tracing_error + (spf "span mismatch: top is %Ld, expected %Ld" span' span) + else + FWrite.Event.Duration_complete.encode out ~name ~t_ref:tls.thread_ref + ~time_ns:start_time_ns ~end_time_ns ~args:data () let with_span ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~data name f = let out, tls = get_thread_output () in let time_ns = Time.now_ns () in let span = Int64.of_int (A.fetch_and_add tls.local_span_id_gen 1) in - let info = { start_time_ns = time_ns; data; name } in - Span_tbl.add tls.spans span info; + Span_info_stack.push tls.spans span ~start_time_ns:time_ns ~data ~name; let[@inline] exit () : unit = let end_time_ns = Time.now_ns () in - Span_tbl.remove tls.spans span; + + let _span', _, _, data = Span_info_stack.pop tls.spans in + assert (span = _span'); FWrite.Event.Duration_complete.encode out ~name ~time_ns ~end_time_ns - ~t_ref:tls.thread_ref ~args:info.data () + ~t_ref:tls.thread_ref ~args:data () in try @@ -175,9 +281,9 @@ struct let add_data_to_span span data = let tls = TLS.get key_thread_local_st in - match Span_tbl.find_opt tls.spans span with + match Span_info_stack.find_ tls.spans span with | None -> !on_tracing_error (spf "unknown span %Ld" span) - | Some info -> info.data <- List.rev_append data info.data + | Some idx -> Span_info_stack.add_data tls.spans idx data let enter_manual_span ~(parent : explicit_span option) ~flavor ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~data name : explicit_span = @@ -262,7 +368,7 @@ let create ~out () : collector = events; span_id_gen = A.make 0; next_thread_ref = A.make 1; - per_thread = A.make Int_map.empty; + per_thread = Array.init 16 (fun _ -> A.make Int_map.empty); } in diff --git a/src/fuchsia/write/output.ml b/src/fuchsia/write/output.ml index 3911192..0ee6be7 100644 --- a/src/fuchsia/write/output.ml +++ b/src/fuchsia/write/output.ml @@ -10,10 +10,20 @@ let create ~(buf_pool : Buf_pool.t) ~send_buf () : t = { buf; send_buf; buf_pool } open struct + (* NOTE: there is a potential race condition if an output is + flushed from the main thread upon closing, while + the local thread is blissfully writing new records to it + as we're winding down the collector. This is trying to reduce + the likelyhood of a race happening. *) + let[@poll error] replace_buf_ (self : t) (new_buf : Buf.t) : Buf.t = + let old_buf = self.buf in + self.buf <- new_buf; + old_buf + let flush_ (self : t) : unit = - self.send_buf self.buf; - let buf = Buf_pool.alloc self.buf_pool in - self.buf <- buf + let new_buf = Buf_pool.alloc self.buf_pool in + let old_buf = replace_buf_ self new_buf in + self.send_buf old_buf let[@inline never] cycle_buf (self : t) ~available : Buf.t = flush_ self; diff --git a/trace-fuchsia.opam b/trace-fuchsia.opam index 20fa305..62ef782 100644 --- a/trace-fuchsia.opam +++ b/trace-fuchsia.opam @@ -13,6 +13,7 @@ depends: [ "ocaml" {>= "4.08"} "trace" {= version} "mtime" {>= "2.0"} + "base-bigarray" "base-unix" "dune" {>= "2.9"} "odoc" {with-doc} From eaa76ecb4cc8ffe3ad846139dc21b5ab550d0e35 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Dec 2023 17:29:10 -0500 Subject: [PATCH 16/21] details --- bench/trace_fx.ml | 1 + src/fuchsia/fcollector.ml | 10 ++++++---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/bench/trace_fx.ml b/bench/trace_fx.ml index cf55da8..b2c0b8f 100644 --- a/bench/trace_fx.ml +++ b/bench/trace_fx.ml @@ -14,6 +14,7 @@ let work ~dom_idx ~n () : unit = (* 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) diff --git a/src/fuchsia/fcollector.ml b/src/fuchsia/fcollector.ml index 223def1..0f5b486 100644 --- a/src/fuchsia/fcollector.ml +++ b/src/fuchsia/fcollector.ml @@ -36,13 +36,15 @@ end = struct mutable data: (string * user_data) list array; } + let init_size_ = 1 + let create () : t = { len = 0; - span = BA1.create BA.Int64 BA.C_layout 64; - start_time_ns = BA1.create BA.Int64 BA.C_layout 64; - name = Array.make 64 ""; - data = Array.make 64 []; + span = BA1.create BA.Int64 BA.C_layout init_size_; + start_time_ns = BA1.create BA.Int64 BA.C_layout init_size_; + name = Array.make init_size_ ""; + data = Array.make init_size_ []; } let[@inline] cap self = Array.length self.name From 622770808dded757094e4b3f1b84e9b5a363dbf1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Dec 2023 17:34:13 -0500 Subject: [PATCH 17/21] fix too strict assertion --- src/fuchsia/write/buf.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fuchsia/write/buf.ml b/src/fuchsia/write/buf.ml index 2b13b34..52ac55a 100644 --- a/src/fuchsia/write/buf.ml +++ b/src/fuchsia/write/buf.ml @@ -29,7 +29,7 @@ let[@inline] add_string (self : t) (s : string) : unit = let missing = missing_to_round len in (* bound check *) - assert (len + missing + self.offset < Bytes.length self.buf); + assert (len + missing + self.offset <= Bytes.length self.buf); Bytes.unsafe_blit_string s 0 self.buf self.offset len; self.offset <- self.offset + len; From 6aeb1ea007652d3cbcdaa28d1c63c97a5ffa8842 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Dec 2023 21:20:08 -0500 Subject: [PATCH 18/21] remove unused dep --- src/util/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/dune b/src/util/dune index 7d7f2a4..39f8bcb 100644 --- a/src/util/dune +++ b/src/util/dune @@ -3,7 +3,7 @@ (public_name trace.private.util) (synopsis "internal utilities for trace. No guarantees of stability.") (name trace_private_util) - (libraries trace.core mtime mtime.clock.os atomic unix threads + (libraries trace.core mtime mtime.clock.os unix threads (select domain_util.ml from (base-domain -> domain_util.real.ml) ( -> domain_util.dummy.ml)))) From 5571751f3eb4a50ca87a0fd0b16518dd1eb00c99 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Dec 2023 21:33:04 -0500 Subject: [PATCH 19/21] missed some uses of `Atomic` --- src/util/b_queue.ml | 14 ++++++++------ src/util/mpsc_bag.ml | 12 +++++++----- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/src/util/b_queue.ml b/src/util/b_queue.ml index 1a77aa3..f5ee5f3 100644 --- a/src/util/b_queue.ml +++ b/src/util/b_queue.ml @@ -1,9 +1,11 @@ +module A = Trace_core.Internal_.Atomic_ + type 'a t = { mutex: Mutex.t; cond: Condition.t; q: 'a Mpsc_bag.t; mutable closed: bool; - consumer_waiting: bool Atomic.t; + consumer_waiting: bool A.t; } exception Closed @@ -14,7 +16,7 @@ let create () : _ t = cond = Condition.create (); q = Mpsc_bag.create (); closed = false; - consumer_waiting = Atomic.make false; + consumer_waiting = A.make false; } let close (self : _ t) = @@ -29,7 +31,7 @@ let push (self : _ t) x : unit = if self.closed then raise Closed; Mpsc_bag.add self.q x; if self.closed then raise Closed; - if Atomic.get self.consumer_waiting then ( + if A.get self.consumer_waiting then ( (* wakeup consumer *) Mutex.lock self.mutex; Condition.broadcast self.cond; @@ -42,14 +44,14 @@ let rec pop_all (self : 'a t) : 'a list = | None -> if self.closed then raise Closed; Mutex.lock self.mutex; - Atomic.set self.consumer_waiting true; + A.set self.consumer_waiting true; (* check again, a producer might have pushed an element since we last checked. However if we still find nothing, because this comes after [consumer_waiting:=true], any producer arriving after that will know to wake us up. *) (match Mpsc_bag.pop_all self.q with | Some l -> - Atomic.set self.consumer_waiting false; + A.set self.consumer_waiting false; Mutex.unlock self.mutex; l | None -> @@ -58,6 +60,6 @@ let rec pop_all (self : 'a t) : 'a list = raise Closed ); Condition.wait self.cond self.mutex; - Atomic.set self.consumer_waiting false; + A.set self.consumer_waiting false; Mutex.unlock self.mutex; pop_all self) diff --git a/src/util/mpsc_bag.ml b/src/util/mpsc_bag.ml index a8f49aa..02aeadf 100644 --- a/src/util/mpsc_bag.ml +++ b/src/util/mpsc_bag.ml @@ -1,7 +1,9 @@ -type 'a t = { bag: 'a list Atomic.t } [@@unboxed] +module A = Trace_core.Internal_.Atomic_ + +type 'a t = { bag: 'a list A.t } [@@unboxed] let create () = - let bag = Atomic.make [] in + let bag = A.make [] in { bag } module Backoff = struct @@ -17,14 +19,14 @@ module Backoff = struct end let rec add backoff t x = - let before = Atomic.get t.bag in + let before = A.get t.bag in let after = x :: before in - if not (Atomic.compare_and_set t.bag before after) then + if not (A.compare_and_set t.bag before after) then add (Backoff.once backoff) t x let[@inline] add t x = add Backoff.default t x let[@inline] pop_all t : _ list option = - match Atomic.exchange t.bag [] with + match A.exchange t.bag [] with | [] -> None | l -> Some (List.rev l) From bc41a53f6c4612a0397d1b7fd40297889c41ac1a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Dec 2023 21:37:34 -0500 Subject: [PATCH 20/21] limit test to package --- test/fuchsia/write/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/test/fuchsia/write/dune b/test/fuchsia/write/dune index e9f181a..1261c4b 100644 --- a/test/fuchsia/write/dune +++ b/test/fuchsia/write/dune @@ -1,4 +1,5 @@ (tests (names t1 t2) + (package trace-fuchsia) (libraries trace-fuchsia.write)) From 434972bc2667693a3dbd021bf85d382a0591a6d7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 2 Jan 2024 12:32:51 -0500 Subject: [PATCH 21/21] remove dead code --- src/fuchsia/global_.ml.tmp | 4 ---- src/fuchsia/span_info.ml | 0 2 files changed, 4 deletions(-) delete mode 100644 src/fuchsia/global_.ml.tmp delete mode 100644 src/fuchsia/span_info.ml diff --git a/src/fuchsia/global_.ml.tmp b/src/fuchsia/global_.ml.tmp deleted file mode 100644 index 49df805..0000000 --- a/src/fuchsia/global_.ml.tmp +++ /dev/null @@ -1,4 +0,0 @@ -(** A bit of global state that can be reached - from each thread without too much overhead *) - -open Common_ diff --git a/src/fuchsia/span_info.ml b/src/fuchsia/span_info.ml deleted file mode 100644 index e69de29..0000000