├── src ├── tef │ ├── emit_tef.ml │ ├── common_.ml │ ├── dune │ ├── subscriber.mli │ ├── writer.mli │ ├── trace_tef.mli │ ├── exporter.ml │ ├── writer.ml │ ├── trace_tef.ml │ └── subscriber.ml ├── trace.ml ├── subscriber │ ├── span_tbl.ml │ ├── thread_.dummy.ml │ ├── time_.mli │ ├── time_.dummy.ml │ ├── thread_.real.ml │ ├── thread_.mli │ ├── time_.mtime.ml │ ├── time_.unix.ml │ ├── tbl_.mli │ ├── tbl_.basic.ml │ ├── tbl_.picos.ml │ ├── dune │ ├── span_tbl.mli │ ├── tbl_.thread.ml │ ├── trace_subscriber.mli │ ├── subscriber.ml │ ├── trace_subscriber.ml │ └── callbacks.ml ├── core │ ├── gen │ │ ├── dune │ │ └── gen.ml │ ├── meta_map.hmap.ml │ ├── dune │ ├── level.ml │ ├── types.ml │ ├── meta_map.ourown.ml │ ├── collector.ml │ ├── trace_core.ml │ └── trace_core.mli ├── util │ ├── domain_util.dummy.ml │ ├── domain_util.mli │ ├── domain_util.real.ml │ ├── rpool.mli │ ├── dune │ └── rpool.ml ├── dune ├── fuchsia │ ├── time.ml │ ├── util.ml │ ├── lock.mli │ ├── dune │ ├── subscriber.mli │ ├── common_.ml │ ├── buf_pool.ml │ ├── lock.ml │ ├── buf.ml │ ├── trace_fuchsia.mli │ ├── exporter.ml │ ├── trace_fuchsia.ml │ ├── buf_chain.ml │ ├── subscriber.ml │ └── writer.ml ├── ppx │ ├── dune │ └── ppx_trace.ml ├── event │ ├── dune │ ├── event.ml │ └── subscriber.ml └── tef-tldrs │ ├── dune │ ├── trace_tef_tldrs.mli │ └── trace_tef_tldrs.ml ├── test ├── fuchsia │ ├── t1.expected │ ├── write │ │ ├── dune │ │ ├── t2.expected │ │ ├── t1.ml │ │ └── t2.ml │ ├── dune │ └── t1.ml ├── dune ├── t2.ml └── t1.ml ├── trace-fuchsia.opam.template ├── media └── ui.png ├── .gitignore ├── bench1.sh ├── bench_fx.sh ├── bench_tldrs.sh ├── dune ├── .ocamlformat ├── bench ├── dune ├── trace1.ml ├── trace_fx.ml ├── trace_tldrs.ml └── bench_fuchsia_write.ml ├── Makefile ├── ppx_trace.opam ├── trace.opam ├── trace-tef.opam ├── .github └── workflows │ ├── gh-pages.yml │ └── main.yml ├── trace-fuchsia.opam ├── dune-project ├── CHANGES.md └── README.md /src/tef/emit_tef.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/trace.ml: -------------------------------------------------------------------------------- 1 | include Trace_core 2 | -------------------------------------------------------------------------------- /src/subscriber/span_tbl.ml: -------------------------------------------------------------------------------- 1 | include Tbl_ 2 | -------------------------------------------------------------------------------- /test/fuchsia/t1.expected: -------------------------------------------------------------------------------- 1 | data: 62120 bytes 2 | -------------------------------------------------------------------------------- /src/core/gen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen)) 3 | -------------------------------------------------------------------------------- /trace-fuchsia.opam.template: -------------------------------------------------------------------------------- 1 | available: arch != "s390x" 2 | -------------------------------------------------------------------------------- /src/subscriber/thread_.dummy.ml: -------------------------------------------------------------------------------- 1 | let[@inline] get_tid () = 0 2 | -------------------------------------------------------------------------------- /src/subscriber/time_.mli: -------------------------------------------------------------------------------- 1 | val get_time_ns : unit -> int64 2 | -------------------------------------------------------------------------------- /src/core/meta_map.hmap.ml: -------------------------------------------------------------------------------- 1 | include Hmap 2 | 3 | let find_exn = get 4 | -------------------------------------------------------------------------------- /media/ui.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/c-cube/ocaml-trace/HEAD/media/ui.png -------------------------------------------------------------------------------- /src/subscriber/time_.dummy.ml: -------------------------------------------------------------------------------- 1 | let[@inline] get_time_ns () : int64 = 0L 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | _build 3 | *.json 4 | *.exe 5 | perf.* 6 | *.fxt 7 | *.tmp 8 | -------------------------------------------------------------------------------- /src/util/domain_util.dummy.ml: -------------------------------------------------------------------------------- 1 | let cpu_relax () = () 2 | let n_domains () = 1 3 | -------------------------------------------------------------------------------- /src/subscriber/thread_.real.ml: -------------------------------------------------------------------------------- 1 | let[@inline] get_tid () = Thread.id @@ Thread.self () 2 | -------------------------------------------------------------------------------- /src/subscriber/thread_.mli: -------------------------------------------------------------------------------- 1 | val get_tid : unit -> int 2 | (** Get current thread ID *) 3 | -------------------------------------------------------------------------------- /src/util/domain_util.mli: -------------------------------------------------------------------------------- 1 | val cpu_relax : unit -> unit 2 | val n_domains : unit -> int 3 | -------------------------------------------------------------------------------- /src/util/domain_util.real.ml: -------------------------------------------------------------------------------- 1 | let cpu_relax = Domain.cpu_relax 2 | let n_domains = Domain.recommended_domain_count 3 | -------------------------------------------------------------------------------- /test/fuchsia/write/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names t1 t2) 3 | (package trace-fuchsia) 4 | (libraries trace-fuchsia)) 5 | -------------------------------------------------------------------------------- /bench1.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | DUNE_OPTS="--profile=release --display=quiet" 3 | exec dune exec $DUNE_OPTS bench/trace1.exe -- $@ 4 | -------------------------------------------------------------------------------- /src/tef/common_.ml: -------------------------------------------------------------------------------- 1 | module Sub = Trace_subscriber 2 | module A = Trace_core.Internal_.Atomic_ 3 | 4 | let ( let@ ) = ( @@ ) 5 | -------------------------------------------------------------------------------- /test/fuchsia/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t1) 3 | (package trace-fuchsia) 4 | (modules t1) 5 | (libraries trace trace-fuchsia)) 6 | -------------------------------------------------------------------------------- /bench_fx.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | DUNE_OPTS="--profile=release --display=quiet" 3 | exec dune exec $DUNE_OPTS bench/trace_fx.exe -- $@ 4 | -------------------------------------------------------------------------------- /bench_tldrs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | DUNE_OPTS="--profile=release --display=quiet" 3 | exec dune exec $DUNE_OPTS bench/trace_tldrs.exe -- $@ 4 | -------------------------------------------------------------------------------- /src/subscriber/time_.mtime.ml: -------------------------------------------------------------------------------- 1 | let[@inline] get_time_ns () : int64 = 2 | let t = Mtime_clock.now () in 3 | Mtime.to_uint64_ns t 4 | -------------------------------------------------------------------------------- /src/subscriber/time_.unix.ml: -------------------------------------------------------------------------------- 1 | let[@inline] get_time_ns () : int64 = 2 | let t = Unix.gettimeofday () in 3 | Int64.of_float (t *. 1e9) 4 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace) 3 | (public_name trace) 4 | (synopsis "Lightweight stub for tracing") 5 | (libraries 6 | (re_export trace.core))) 7 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | :standard 5 | -strict-sequence 6 | -warn-error 7 | -a+8+26+27 8 | -w 9 | +a-4-40-42-44-70))) 10 | -------------------------------------------------------------------------------- /src/fuchsia/time.ml: -------------------------------------------------------------------------------- 1 | let counter = Mtime_clock.counter () 2 | 3 | (** Now, in nanoseconds *) 4 | let[@inline] now_ns () : int64 = 5 | let t = Mtime_clock.count counter in 6 | Mtime.Span.to_uint64_ns t 7 | -------------------------------------------------------------------------------- /src/ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_trace) 3 | (public_name ppx_trace) 4 | (kind ppx_rewriter) 5 | (preprocess 6 | (pps ppxlib.metaquot)) 7 | (ppx_runtime_libraries trace.core) 8 | (libraries ppxlib)) 9 | -------------------------------------------------------------------------------- /src/event/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_event) 3 | (public_name trace.event) 4 | (synopsis "Turns subscriber callbacks into an event type") 5 | (libraries 6 | (re_export trace.core) 7 | (re_export trace.subscriber))) 8 | -------------------------------------------------------------------------------- /src/subscriber/tbl_.mli: -------------------------------------------------------------------------------- 1 | type 'v t 2 | 3 | val create : unit -> 'v t 4 | val add : 'v t -> int64 -> 'v -> unit 5 | val find_exn : 'v t -> int64 -> 'v 6 | val remove : _ t -> int64 -> unit 7 | val to_list : 'v t -> (int64 * 'v) list 8 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t1) 3 | (package trace-tef) 4 | (modules t1) 5 | (libraries trace trace-tef)) 6 | 7 | (test 8 | (name t2) 9 | (package ppx_trace) 10 | (modules t2) 11 | (preprocess 12 | (pps ppx_trace)) 13 | (libraries trace-tef)) 14 | -------------------------------------------------------------------------------- /src/fuchsia/util.ml: -------------------------------------------------------------------------------- 1 | (** How many bytes are missing for [n] to be a multiple of 8 *) 2 | let[@inline] missing_to_round (n : int) : int = lnot (n - 1) land 0b111 3 | 4 | (** Round up to a multiple of 8 *) 5 | let[@inline] round_to_word (n : int) : int = n + (lnot (n - 1) land 0b111) 6 | -------------------------------------------------------------------------------- /src/tef-tldrs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_tef_tldrs) 3 | (public_name trace-tef.tldrs) 4 | (synopsis "Multiprocess tracing using the `tldrs` daemon") 5 | (libraries 6 | trace.core 7 | trace.private.util 8 | trace.subscriber 9 | trace-tef 10 | unix 11 | threads)) 12 | -------------------------------------------------------------------------------- /src/util/rpool.mli: -------------------------------------------------------------------------------- 1 | (** A resource pool (for buffers) *) 2 | 3 | type 'a t 4 | 5 | val create : 6 | max_size:int -> create:(unit -> 'a) -> clear:('a -> unit) -> unit -> 'a t 7 | 8 | val alloc : 'a t -> 'a 9 | val recycle : 'a t -> 'a -> unit 10 | val with_ : 'a t -> ('a -> 'b) -> 'b 11 | -------------------------------------------------------------------------------- /src/tef/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_tef) 3 | (public_name trace-tef) 4 | (synopsis 5 | "Simple and lightweight tracing using TEF/Catapult format, in-process") 6 | (libraries 7 | trace.core 8 | trace.private.util 9 | trace.subscriber 10 | mtime 11 | mtime.clock.os 12 | unix 13 | threads)) 14 | -------------------------------------------------------------------------------- /src/subscriber/tbl_.basic.ml: -------------------------------------------------------------------------------- 1 | module T = Hashtbl.Make (struct 2 | include Int64 3 | 4 | let hash = Hashtbl.hash 5 | end) 6 | 7 | type 'v t = 'v T.t 8 | 9 | let create () : _ t = T.create 32 10 | let find_exn = T.find 11 | let remove = T.remove 12 | let add = T.replace 13 | let to_list self : _ list = T.fold (fun k v l -> (k, v) :: l) self [] 14 | -------------------------------------------------------------------------------- /src/fuchsia/lock.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | (** A value protected by a mutex *) 3 | 4 | val create : 'a -> 'a t 5 | val with_ : 'a t -> ('a -> 'b) -> 'b 6 | val update : 'a t -> ('a -> 'a) -> unit 7 | val update_map : 'a t -> ('a -> 'a * 'b) -> 'b 8 | 9 | val set_while_locked : 'a t -> 'a -> unit 10 | (** Change the value while inside [with_] or similar. *) 11 | -------------------------------------------------------------------------------- /src/fuchsia/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_fuchsia) 3 | (public_name trace-fuchsia) 4 | (synopsis 5 | "A high-performance backend for trace, emitting a Fuchsia trace into a file") 6 | (libraries 7 | trace.core 8 | trace.private.util 9 | trace.subscriber 10 | thread-local-storage 11 | bigarray 12 | mtime 13 | mtime.clock.os 14 | unix 15 | threads)) 16 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.27.0 2 | profile=conventional 3 | margin=80 4 | if-then-else=k-r 5 | parens-ite=true 6 | parens-tuple=multi-line-only 7 | sequence-style=terminator 8 | type-decl=sparse 9 | break-cases=toplevel 10 | cases-exp-indent=2 11 | field-space=tight-decl 12 | leading-nested-match-parens=true 13 | module-item-spacing=compact 14 | quiet=true 15 | ocaml-version=4.08.0 16 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_core) 3 | (public_name trace.core) 4 | (libraries 5 | (select 6 | meta_map.ml 7 | from 8 | (hmap -> meta_map.hmap.ml) 9 | (-> meta_map.ourown.ml))) 10 | (synopsis "Lightweight stub for tracing")) 11 | 12 | (rule 13 | (targets atomic_.ml) 14 | (action 15 | (with-stdout-to 16 | %{targets} 17 | (run ./gen/gen.exe --ocaml %{ocaml_version} --atomic)))) 18 | -------------------------------------------------------------------------------- /src/util/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name trace.private.util) 3 | (synopsis "internal utilities for trace. No guarantees of stability.") 4 | (name trace_private_util) 5 | (optional) ; depends on mtime 6 | (libraries 7 | trace.core 8 | mtime 9 | mtime.clock.os 10 | unix 11 | threads 12 | (select 13 | domain_util.ml 14 | from 15 | (base-domain -> domain_util.real.ml) 16 | (-> domain_util.dummy.ml)))) 17 | -------------------------------------------------------------------------------- /src/subscriber/tbl_.picos.ml: -------------------------------------------------------------------------------- 1 | module H = Picos_aux_htbl 2 | 3 | module Key = struct 4 | include Int64 5 | 6 | let hash = Hashtbl.hash 7 | end 8 | 9 | type 'v t = (int64, 'v) H.t 10 | 11 | let create () : _ t = H.create ~hashed_type:(module Key) () 12 | let find_exn = H.find_exn 13 | let[@inline] remove self k = ignore (H.try_remove self k : bool) 14 | 15 | let[@inline] add self k v = 16 | if not (H.try_add self k v) then ignore (H.try_set self k v) 17 | 18 | let[@inline] to_list self = H.to_seq self |> List.of_seq 19 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name trace1) 3 | (modules trace1) 4 | (libraries trace.core trace-tef)) 5 | 6 | (executable 7 | (name trace_fx) 8 | (modules trace_fx) 9 | (preprocess 10 | (pps ppx_trace)) 11 | (libraries trace.core trace-fuchsia)) 12 | 13 | (executable 14 | (name trace_tldrs) 15 | (modules trace_tldrs) 16 | (preprocess 17 | (pps ppx_trace)) 18 | (libraries trace.core trace-tef.tldrs)) 19 | 20 | (executable 21 | (name bench_fuchsia_write) 22 | (modules bench_fuchsia_write) 23 | (libraries benchmark trace-fuchsia)) 24 | -------------------------------------------------------------------------------- /src/fuchsia/subscriber.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** Main subscriber state. *) 3 | 4 | val create : ?buf_pool:Buf_pool.t -> pid:int -> exporter:Exporter.t -> unit -> t 5 | (** Create a subscriber state. *) 6 | 7 | val flush : t -> unit 8 | val close : t -> unit 9 | val active : t -> bool 10 | 11 | module Callbacks : Trace_subscriber.Callbacks.S with type st = t 12 | 13 | val subscriber : t -> Trace_subscriber.t 14 | (** Subscriber that writes json into this writer *) 15 | 16 | (**/**) 17 | 18 | val on_tracing_error : (string -> unit) ref 19 | 20 | (**/**) 21 | -------------------------------------------------------------------------------- /test/fuchsia/write/t2.expected: -------------------------------------------------------------------------------- 1 | first trace 2 | 100004467854160033000500000000000100000000000000560000000000000054001005000005804e61bc000000000068656c6c6f000000210001802a0000007800000000000000 3 | second trace 4 | 1000044678541600210000000000000000ca9a3b0000000033000500000000000100000000000000560000000000000030001100000020006f63616d6c2d747261636500000000004400040500000580a0860100000000006f75746572000000404b4c0000000000440004050000058020bf020000000000696e6e657200000020aa440000000000540010050000058087d612000000000068656c6c6f000000210001802a0000007800000000000000 5 | -------------------------------------------------------------------------------- /src/fuchsia/common_.ml: -------------------------------------------------------------------------------- 1 | module A = Trace_core.Internal_.Atomic_ 2 | module Sub = Trace_subscriber 3 | 4 | let on_tracing_error = 5 | ref (fun s -> Printf.eprintf "trace-fuchsia error: %s\n%!" s) 6 | 7 | let ( let@ ) = ( @@ ) 8 | let spf = Printf.sprintf 9 | 10 | let with_lock lock f = 11 | Mutex.lock lock; 12 | try 13 | let res = f () in 14 | Mutex.unlock lock; 15 | res 16 | with e -> 17 | let bt = Printexc.get_raw_backtrace () in 18 | Mutex.unlock lock; 19 | Printexc.raise_with_backtrace e bt 20 | 21 | (** Buffer size we use. *) 22 | let fuchsia_buf_size = 1 lsl 16 23 | -------------------------------------------------------------------------------- /test/t2.ml: -------------------------------------------------------------------------------- 1 | let ( let@ ) = ( @@ ) 2 | 3 | let rec fib x = 4 | let%trace () = "fib" in 5 | if x <= 2 then 6 | 1 7 | else 8 | fib (x - 1) + fib (x - 2) 9 | 10 | let%trace rec fib2 x = 11 | if x <= 2 then 12 | 1 13 | else 14 | fib2 (x - 1) + fib2 (x - 2) 15 | 16 | let () = 17 | Trace_tef.Private_.mock_all_ (); 18 | let@ () = Trace_tef.with_setup ~out:`Stdout () in 19 | 20 | Trace_core.set_process_name "main"; 21 | Trace_core.set_thread_name "t1"; 22 | 23 | let x = fib 13 in 24 | assert (x = 233); 25 | 26 | let x = fib2 13 in 27 | assert (x = 233); 28 | () 29 | -------------------------------------------------------------------------------- /src/fuchsia/buf_pool.ml: -------------------------------------------------------------------------------- 1 | open Common_ 2 | open Trace_private_util 3 | 4 | type t = Buf.t Rpool.t 5 | 6 | let create ?(max_size = 64) () : t = 7 | Rpool.create ~max_size ~clear:Buf.clear 8 | ~create:(fun () -> Buf.create fuchsia_buf_size) 9 | () 10 | 11 | let alloc = Rpool.alloc 12 | let[@inline] recycle self buf = if buf != Buf.empty then Rpool.recycle self buf 13 | 14 | let with_ (self : t) f = 15 | let x = alloc self in 16 | try 17 | let res = f x in 18 | recycle self x; 19 | res 20 | with e -> 21 | let bt = Printexc.get_raw_backtrace () in 22 | recycle self x; 23 | Printexc.raise_with_backtrace e bt 24 | -------------------------------------------------------------------------------- /src/subscriber/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name trace_subscriber) 3 | (public_name trace.subscriber) 4 | (private_modules time_ thread_ tbl_) 5 | (libraries 6 | (re_export trace.core) 7 | (select 8 | thread_.ml 9 | from 10 | (threads -> thread_.real.ml) 11 | (-> thread_.dummy.ml)) 12 | (select 13 | tbl_.ml 14 | from 15 | (picos_aux.htbl -> tbl_.picos.ml) 16 | (threads -> tbl_.thread.ml) 17 | (-> tbl_.basic.ml)) 18 | (select 19 | time_.ml 20 | from 21 | (mtime mtime.clock.os -> time_.mtime.ml) 22 | (mtime mtime.clock.jsoo -> time_.mtime.ml) 23 | (unix -> time_.unix.ml) 24 | (-> time_.dummy.ml)))) 25 | -------------------------------------------------------------------------------- /src/subscriber/span_tbl.mli: -------------------------------------------------------------------------------- 1 | (** A table that can be used to remember information about spans. 2 | 3 | This is convenient when we want to rememner information from a span begin, 4 | when dealing with the corresponding span end. 5 | 6 | {b NOTE}: this is thread safe when threads are enabled. *) 7 | 8 | open Trace_core 9 | 10 | type 'v t 11 | 12 | val create : unit -> 'v t 13 | val add : 'v t -> span -> 'v -> unit 14 | 15 | val find_exn : 'v t -> span -> 'v 16 | (** @raise Not_found if information isn't found *) 17 | 18 | val remove : _ t -> span -> unit 19 | (** Remove the span if present *) 20 | 21 | val to_list : 'v t -> (span * 'v) list 22 | -------------------------------------------------------------------------------- /src/tef/subscriber.mli: -------------------------------------------------------------------------------- 1 | open Common_ 2 | 3 | module Buf_pool : sig 4 | type t 5 | 6 | val create : ?max_size:int -> ?buf_size:int -> unit -> t 7 | end 8 | 9 | type t 10 | (** Main subscriber state. *) 11 | 12 | val create : ?buf_pool:Buf_pool.t -> pid:int -> exporter:Exporter.t -> unit -> t 13 | (** Create a subscriber state. *) 14 | 15 | val flush : t -> unit 16 | val close : t -> unit 17 | val active : t -> bool 18 | 19 | module Callbacks : Sub.Callbacks.S with type st = t 20 | 21 | val subscriber : t -> Sub.t 22 | (** Subscriber that writes json into this writer *) 23 | 24 | (**/**) 25 | 26 | val on_tracing_error : (string -> unit) ref 27 | 28 | (**/**) 29 | -------------------------------------------------------------------------------- /src/fuchsia/lock.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { 2 | mutex: Mutex.t; 3 | mutable content: 'a; 4 | } 5 | 6 | let create content : _ t = { mutex = Mutex.create (); content } 7 | 8 | let with_ (self : _ t) f = 9 | Mutex.lock self.mutex; 10 | try 11 | let x = f self.content in 12 | Mutex.unlock self.mutex; 13 | x 14 | with e -> 15 | let bt = Printexc.get_raw_backtrace () in 16 | Mutex.unlock self.mutex; 17 | Printexc.raise_with_backtrace e bt 18 | 19 | let[@inline] update self f = with_ self (fun x -> self.content <- f x) 20 | 21 | let[@inline] update_map l f = 22 | with_ l (fun x -> 23 | let x', y = f x in 24 | l.content <- x'; 25 | y) 26 | 27 | let[@inline] set_while_locked (self : 'a t) (x : 'a) = self.content <- x 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | DUNE_OPTS?= 3 | all: 4 | dune build @all $(DUNE_OPTS) 5 | 6 | clean: 7 | @dune clean 8 | 9 | test: 10 | @dune runtest $(DUNE_OPTS) 11 | test-autopromote: 12 | @dune runtest $(DUNE_OPTS) --auto-promote 13 | 14 | doc: 15 | @dune build $(DUNE_OPTS) @doc 16 | 17 | WATCH?= @install @runtest 18 | watch: 19 | dune build $(DUNE_OPTS) -w $(WATCH) 20 | 21 | .PHONY: test clean watch 22 | 23 | VERSION=$(shell awk '/^version:/ {print $$2}' trace.opam) 24 | 25 | update_next_tag: 26 | @echo "update version to $(VERSION)..." 27 | sed --follow-symlinks -i "s/NEXT_VERSION/$(VERSION)/g" $(wildcard src/**.ml) $(wildcard src/**.mli) \ 28 | $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 29 | sed --follow-symlinks -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/**.ml) $(wildcard src/**.mli) \ 30 | $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 31 | -------------------------------------------------------------------------------- /src/subscriber/tbl_.thread.ml: -------------------------------------------------------------------------------- 1 | module T = Hashtbl.Make (struct 2 | include Int64 3 | 4 | let hash = Hashtbl.hash 5 | end) 6 | 7 | type 'v t = { 8 | tbl: 'v T.t; 9 | lock: Mutex.t; 10 | } 11 | 12 | let create () : _ t = { tbl = T.create 32; lock = Mutex.create () } 13 | 14 | let find_exn self k = 15 | Mutex.lock self.lock; 16 | try 17 | let v = T.find self.tbl k in 18 | Mutex.unlock self.lock; 19 | v 20 | with e -> 21 | Mutex.unlock self.lock; 22 | raise e 23 | 24 | let remove self k = 25 | Mutex.lock self.lock; 26 | T.remove self.tbl k; 27 | Mutex.unlock self.lock 28 | 29 | let add self k v = 30 | Mutex.lock self.lock; 31 | T.replace self.tbl k v; 32 | Mutex.unlock self.lock 33 | 34 | let to_list self : _ list = 35 | Mutex.lock self.lock; 36 | let l = T.fold (fun k v l -> (k, v) :: l) self.tbl [] in 37 | Mutex.unlock self.lock; 38 | l 39 | -------------------------------------------------------------------------------- /bench/trace1.ml: -------------------------------------------------------------------------------- 1 | module Trace = Trace_core 2 | 3 | let ( let@ ) = ( @@ ) 4 | 5 | let work ~n () : unit = 6 | for _i = 1 to n do 7 | let@ _sp = 8 | Trace.with_span ~__FILE__ ~__LINE__ "outer" ~data:(fun () -> 9 | [ "i", `Int _i ]) 10 | in 11 | for _k = 1 to 10 do 12 | let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "inner" in 13 | () 14 | done 15 | (* Thread.delay 1e-6 *) 16 | done 17 | 18 | let main ~n ~j () : unit = 19 | let domains = Array.init j (fun _ -> Domain.spawn (fun () -> work ~n ())) in 20 | Array.iter Domain.join domains 21 | 22 | let () = 23 | let@ () = Trace_tef.with_setup () in 24 | 25 | let n = ref 10_000 in 26 | let j = ref 4 in 27 | 28 | let args = 29 | [ 30 | "-n", Arg.Set_int n, " number of iterations"; 31 | "-j", Arg.Set_int j, " set number of workers"; 32 | ] 33 | |> Arg.align 34 | in 35 | Arg.parse args ignore "bench1"; 36 | main ~n:!n ~j:!j () 37 | -------------------------------------------------------------------------------- /ppx_trace.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.10" 4 | synopsis: "A ppx-based preprocessor for trace" 5 | maintainer: ["Simon Cruanes"] 6 | authors: ["Simon Cruanes"] 7 | license: "MIT" 8 | tags: ["trace" "ppx"] 9 | homepage: "https://github.com/c-cube/ocaml-trace" 10 | bug-reports: "https://github.com/c-cube/ocaml-trace/issues" 11 | depends: [ 12 | "ocaml" {>= "4.12"} 13 | "ppxlib" {>= "0.37" & < "0.38"} 14 | "trace" {= version} 15 | "trace-tef" {= version & with-test} 16 | "dune" {>= "2.9"} 17 | "odoc" {with-doc} 18 | ] 19 | depopts: [ 20 | "mtime" {>= "2.0"} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "--promote-install-files=false" 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ["dune" "install" "-p" name "--create-install-files" name] 37 | ] 38 | dev-repo: "git+https://github.com/c-cube/ocaml-trace.git" 39 | -------------------------------------------------------------------------------- /trace.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.10" 4 | synopsis: 5 | "A stub for tracing/observability, agnostic in how data is collected" 6 | maintainer: ["Simon Cruanes"] 7 | authors: ["Simon Cruanes"] 8 | license: "MIT" 9 | tags: ["trace" "tracing" "observability" "profiling"] 10 | homepage: "https://github.com/c-cube/ocaml-trace" 11 | bug-reports: "https://github.com/c-cube/ocaml-trace/issues" 12 | depends: [ 13 | "ocaml" {>= "4.08"} 14 | "dune" {>= "2.9"} 15 | "odoc" {with-doc} 16 | ] 17 | depopts: [ 18 | "hmap" 19 | "unix" 20 | "picos_aux" {>= "0.6"} 21 | "mtime" {>= "2.0"} 22 | ] 23 | build: [ 24 | ["dune" "subst"] {dev} 25 | [ 26 | "dune" 27 | "build" 28 | "-p" 29 | name 30 | "-j" 31 | jobs 32 | "--promote-install-files=false" 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ["dune" "install" "-p" name "--create-install-files" name] 38 | ] 39 | dev-repo: "git+https://github.com/c-cube/ocaml-trace.git" 40 | -------------------------------------------------------------------------------- /trace-tef.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.10" 4 | synopsis: 5 | "A simple backend for trace, emitting Catapult/TEF JSON into a file" 6 | maintainer: ["Simon Cruanes"] 7 | authors: ["Simon Cruanes"] 8 | license: "MIT" 9 | tags: [ 10 | "trace" "tracing" "catapult" "TEF" "chrome-format" "chrome-trace" "json" 11 | ] 12 | homepage: "https://github.com/c-cube/ocaml-trace" 13 | bug-reports: "https://github.com/c-cube/ocaml-trace/issues" 14 | depends: [ 15 | "ocaml" {>= "4.08"} 16 | "trace" {= version} 17 | "mtime" {>= "2.0"} 18 | "base-unix" 19 | "dune" {>= "2.9"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "--promote-install-files=false" 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ["dune" "install" "-p" name "--create-install-files" name] 37 | ] 38 | dev-repo: "git+https://github.com/c-cube/ocaml-trace.git" 39 | -------------------------------------------------------------------------------- /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - main # Set a branch name to trigger deployment 7 | 8 | jobs: 9 | deploy: 10 | name: Deploy doc 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@main 14 | 15 | - name: Use OCaml 16 | uses: ocaml/setup-ocaml@v3 17 | with: 18 | ocaml-compiler: '5.1.x' 19 | allow-prerelease-opam: true 20 | dune-cache: true 21 | 22 | - run: opam pin odoc 3.1.0 -y -n 23 | # crash with 2.4, see https://github.com/ocaml/odoc/issues/1066 24 | - name: Deps 25 | run: opam install odig trace trace-tef trace-fuchsia ppx_trace 26 | 27 | - name: Build 28 | run: opam exec -- odig odoc --cache-dir=_doc/ trace trace-tef trace-fuchsia ppx_trace 29 | 30 | - name: Deploy 31 | uses: peaceiris/actions-gh-pages@v3 32 | with: 33 | github_token: ${{ secrets.GITHUB_TOKEN }} 34 | publish_dir: ./_doc/html 35 | destination_dir: . 36 | enable_jekyll: false 37 | -------------------------------------------------------------------------------- /trace-fuchsia.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.10" 4 | synopsis: 5 | "A high-performance backend for trace, emitting a Fuchsia trace into a file" 6 | maintainer: ["Simon Cruanes"] 7 | authors: ["Simon Cruanes"] 8 | license: "MIT" 9 | tags: ["trace" "tracing" "fuchsia"] 10 | homepage: "https://github.com/c-cube/ocaml-trace" 11 | bug-reports: "https://github.com/c-cube/ocaml-trace/issues" 12 | depends: [ 13 | "ocaml" {>= "4.08"} 14 | "trace" {= version} 15 | "mtime" {>= "2.0"} 16 | "thread-local-storage" {>= "0.2"} 17 | "base-bigarray" 18 | "base-unix" 19 | "dune" {>= "2.9"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "--promote-install-files=false" 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ["dune" "install" "-p" name "--create-install-files" name] 37 | ] 38 | dev-repo: "git+https://github.com/c-cube/ocaml-trace.git" 39 | available: arch != "s390x" 40 | -------------------------------------------------------------------------------- /src/core/level.ml: -------------------------------------------------------------------------------- 1 | (** Tracing levels. 2 | 3 | This is similar to log levels in, say, [Logs]. In a thoroughly instrumented 4 | program, there will be a {b lot} of spans, and enabling them all in 5 | production might slow down the application or overwhelm the tracing system; 6 | yet they might be useful in debug situations. 7 | 8 | @since 0.7 *) 9 | 10 | (** Level of tracing. These levels are in increasing order, i.e if level 11 | [Debug1] is enabled, everything below it (Error, Warning, Info, etc.) are 12 | also enabled. 13 | @since 0.7 *) 14 | type t = 15 | | Error (** Only errors *) 16 | | Warning (** Warnings *) 17 | | Info 18 | | Debug1 (** Least verbose debugging level *) 19 | | Debug2 (** Intermediate verbosity debugging level *) 20 | | Debug3 (** Maximum verbosity debugging level *) 21 | | Trace (** Enable everything (default level) *) 22 | 23 | (** @since 0.7 *) 24 | let to_string : t -> string = function 25 | | Error -> "error" 26 | | Warning -> "warning" 27 | | Info -> "info" 28 | | Debug1 -> "debug1" 29 | | Debug2 -> "debug2" 30 | | Debug3 -> "debug3" 31 | | Trace -> "trace" 32 | 33 | let[@inline] leq (a : t) (b : t) : bool = a <= b 34 | -------------------------------------------------------------------------------- /src/tef/writer.mli: -------------------------------------------------------------------------------- 1 | (** Write JSON events to a buffer. 2 | 3 | This is the part of the code that knows how to emit TEF-compliant JSON from 4 | raw event data. *) 5 | 6 | open Common_ 7 | open Trace_core 8 | 9 | val emit_duration_event : 10 | pid:int -> 11 | tid:int -> 12 | name:string -> 13 | start:float -> 14 | end_:float -> 15 | args:(string * Trace_core.user_data) list -> 16 | Buffer.t -> 17 | unit 18 | 19 | val emit_manual_begin : 20 | pid:int -> 21 | tid:int -> 22 | name:string -> 23 | id:span -> 24 | ts:float -> 25 | args:(string * Trace_core.user_data) list -> 26 | flavor:Trace_core.span_flavor option -> 27 | Buffer.t -> 28 | unit 29 | 30 | val emit_manual_end : 31 | pid:int -> 32 | tid:int -> 33 | name:string -> 34 | id:span -> 35 | ts:float -> 36 | flavor:Trace_core.span_flavor option -> 37 | args:(string * Trace_core.user_data) list -> 38 | Buffer.t -> 39 | unit 40 | 41 | val emit_instant_event : 42 | pid:int -> 43 | tid:int -> 44 | name:string -> 45 | ts:float -> 46 | args:(string * Trace_core.user_data) list -> 47 | Buffer.t -> 48 | unit 49 | 50 | val emit_name_thread : pid:int -> tid:int -> name:string -> Buffer.t -> unit 51 | val emit_name_process : pid:int -> name:string -> Buffer.t -> unit 52 | 53 | val emit_counter : 54 | pid:int -> tid:int -> name:string -> ts:float -> Buffer.t -> float -> unit 55 | -------------------------------------------------------------------------------- /src/fuchsia/buf.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = { 4 | buf: bytes; 5 | mutable offset: int; 6 | } 7 | 8 | let empty : t = { buf = Bytes.empty; offset = 0 } 9 | 10 | let create (n : int) : t = 11 | (* multiple of 8-bytes size *) 12 | let buf = Bytes.create (round_to_word n) in 13 | { buf; offset = 0 } 14 | 15 | let[@inline] clear self = self.offset <- 0 16 | let[@inline] available self = Bytes.length self.buf - self.offset 17 | let[@inline] size self = self.offset 18 | let[@inline] is_empty self = self.offset = 0 19 | 20 | (* see below: we assume little endian *) 21 | let () = assert (not Sys.big_endian) 22 | 23 | let[@inline] add_i64 (self : t) (i : int64) : unit = 24 | (* NOTE: we use LE, most systems are this way, even though fuchsia 25 | says we should use the system's native endianess *) 26 | Bytes.set_int64_le self.buf self.offset i; 27 | self.offset <- self.offset + 8 28 | 29 | let[@inline] add_string (self : t) (s : string) : unit = 30 | let len = String.length s in 31 | let missing = missing_to_round len in 32 | 33 | (* bound check *) 34 | Bytes.blit_string s 0 self.buf self.offset len; 35 | self.offset <- self.offset + len; 36 | 37 | (* add 0-padding *) 38 | if missing != 0 then ( 39 | Bytes.unsafe_fill self.buf self.offset missing '\x00'; 40 | self.offset <- self.offset + missing 41 | ) 42 | 43 | let to_string (self : t) : string = Bytes.sub_string self.buf 0 self.offset 44 | -------------------------------------------------------------------------------- /bench/trace_fx.ml: -------------------------------------------------------------------------------- 1 | module Trace = Trace_core 2 | 3 | let ( let@ ) = ( @@ ) 4 | 5 | let work ~dom_idx ~n () : unit = 6 | Trace_core.set_thread_name (Printf.sprintf "worker%d" dom_idx); 7 | for _i = 1 to n do 8 | let%trace _sp = "outer" in 9 | Trace_core.add_data_to_span _sp [ "i", `Int _i ]; 10 | for _k = 1 to 10 do 11 | let%trace _sp = "inner" in 12 | () 13 | done; 14 | 15 | (* Thread.delay 1e-6 *) 16 | if dom_idx = 0 && _i mod 4096 = 0 then ( 17 | Trace_core.message "gc stats"; 18 | let stat = Gc.quick_stat () in 19 | Trace_core.counter_float "gc.minor" (8. *. stat.minor_words); 20 | Trace_core.counter_float "gc.major" (8. *. stat.major_words) 21 | ) 22 | done 23 | 24 | let main ~n ~j () : unit = 25 | let domains = 26 | Array.init j (fun dom_idx -> Domain.spawn (fun () -> work ~dom_idx ~n ())) 27 | in 28 | 29 | let%trace () = "join" in 30 | Array.iter Domain.join domains 31 | 32 | let () = 33 | let@ () = Trace_fuchsia.with_setup () in 34 | Trace_core.set_process_name "trace_fxt1"; 35 | Trace_core.set_thread_name "main"; 36 | 37 | let%trace () = "main" in 38 | 39 | let n = ref 10_000 in 40 | let j = ref 4 in 41 | 42 | let args = 43 | [ 44 | "-n", Arg.Set_int n, " number of iterations"; 45 | "-j", Arg.Set_int j, " set number of workers"; 46 | ] 47 | |> Arg.align 48 | in 49 | Arg.parse args ignore "bench1"; 50 | main ~n:!n ~j:!j () 51 | -------------------------------------------------------------------------------- /src/core/gen/gen.ml: -------------------------------------------------------------------------------- 1 | let atomic_pre_412 = 2 | {| 3 | type 'a t = { mutable x: 'a } 4 | 5 | let[@inline] make x = { x } 6 | let[@inline] get { x } = x 7 | let[@inline] set r x = r.x <- x 8 | 9 | let[@inline never] exchange r x = 10 | (* atomic *) 11 | let y = r.x in 12 | r.x <- x; 13 | (* atomic *) 14 | y 15 | 16 | let[@inline never] compare_and_set r seen v = 17 | (* atomic *) 18 | if r.x == seen then ( 19 | r.x <- v; 20 | (* atomic *) 21 | true 22 | ) else 23 | false 24 | 25 | let[@inline never] fetch_and_add r x = 26 | (* atomic *) 27 | let v = r.x in 28 | r.x <- x + r.x; 29 | (* atomic *) 30 | v 31 | 32 | let[@inline never] incr r = 33 | (* atomic *) 34 | r.x <- 1 + r.x 35 | (* atomic *) 36 | 37 | let[@inline never] decr r = 38 | (* atomic *) 39 | r.x <- r.x - 1 40 | (* atomic *) 41 | 42 | |} 43 | 44 | let atomic_post_412 = {| 45 | include Atomic 46 | |} 47 | 48 | let p_version s = Scanf.sscanf s "%d.%d" (fun x y -> x, y) 49 | 50 | let () = 51 | let atomic = ref false in 52 | let ocaml = ref Sys.ocaml_version in 53 | Arg.parse 54 | [ 55 | "--atomic", Arg.Set atomic, " atomic"; 56 | "--ocaml", Arg.Set_string ocaml, " set ocaml version"; 57 | ] 58 | ignore ""; 59 | 60 | let major, minor = p_version !ocaml in 61 | 62 | if !atomic then ( 63 | let code = 64 | if (major, minor) < (4, 12) then 65 | atomic_pre_412 66 | else 67 | atomic_post_412 68 | in 69 | print_endline code 70 | ) 71 | -------------------------------------------------------------------------------- /test/t1.ml: -------------------------------------------------------------------------------- 1 | let run () = 2 | Trace.set_process_name "main"; 3 | Trace.set_thread_name "t1"; 4 | 5 | let n = ref 0 in 6 | 7 | for _i = 1 to 50 do 8 | Trace.with_span ~__FILE__ ~__LINE__ "outer.loop" @@ fun _sp -> 9 | let pseudo_async_sp = 10 | Trace.enter_manual_span ~parent:None ~__FILE__ ~__LINE__ "fake_sleep" 11 | in 12 | 13 | for _j = 2 to 5 do 14 | incr n; 15 | Trace.with_span ~__FILE__ ~__LINE__ "inner.loop" @@ fun _sp -> 16 | Trace.messagef (fun k -> k "hello %d %d" _i _j); 17 | Trace.message "world"; 18 | Trace.counter_int "n" !n; 19 | 20 | Trace.add_data_to_span _sp [ "i", `Int _i ]; 21 | 22 | if _j = 2 then ( 23 | Trace.add_data_to_span _sp [ "j", `Int _j ]; 24 | let _sp = 25 | Trace.enter_manual_span 26 | ~parent:(Some (Trace.ctx_of_span pseudo_async_sp)) 27 | ~flavor: 28 | (if _i mod 3 = 0 then 29 | `Sync 30 | else 31 | `Async) 32 | ~__FILE__ ~__LINE__ "sub-sleep" 33 | in 34 | 35 | (* fake micro sleep *) 36 | Thread.delay 0.005; 37 | Trace.exit_manual_span _sp 38 | ) else if _j = 3 then ( 39 | (* pretend some task finished. Note that this is not well scoped wrt other spans. *) 40 | Trace.add_data_to_manual_span pseudo_async_sp [ "slept", `Bool true ]; 41 | Trace.exit_manual_span pseudo_async_sp 42 | ) 43 | done 44 | done 45 | 46 | let () = 47 | Trace_tef.Private_.mock_all_ (); 48 | Trace_tef.with_setup ~out:`Stdout () @@ fun () -> run () 49 | -------------------------------------------------------------------------------- /src/util/rpool.ml: -------------------------------------------------------------------------------- 1 | open struct 2 | module A = Trace_core.Internal_.Atomic_ 3 | end 4 | 5 | module List_with_len = struct 6 | type +'a t = 7 | | Nil 8 | | Cons of int * 'a * 'a t 9 | 10 | let empty : _ t = Nil 11 | 12 | let[@inline] len = function 13 | | Nil -> 0 14 | | Cons (i, _, _) -> i 15 | 16 | let[@inline] cons x self = Cons (len self + 1, x, self) 17 | end 18 | 19 | type 'a t = { 20 | max_size: int; 21 | create: unit -> 'a; 22 | clear: 'a -> unit; 23 | cached: 'a List_with_len.t A.t; 24 | } 25 | 26 | let create ~max_size ~create ~clear () : _ t = 27 | { max_size; create; clear; cached = A.make List_with_len.empty } 28 | 29 | let alloc (type a) (self : a t) : a = 30 | let module M = struct 31 | exception Found of a 32 | end in 33 | try 34 | while 35 | match A.get self.cached with 36 | | Nil -> false 37 | | Cons (_, x, tl) as old -> 38 | if A.compare_and_set self.cached old tl then 39 | raise_notrace (M.Found x) 40 | else 41 | true 42 | do 43 | () 44 | done; 45 | self.create () 46 | with M.Found x -> x 47 | 48 | let recycle (self : 'a t) (x : 'a) : unit = 49 | self.clear x; 50 | while 51 | match A.get self.cached with 52 | | Cons (i, _, _) when i >= self.max_size -> false (* drop buf *) 53 | | old -> not (A.compare_and_set self.cached old (List_with_len.cons x old)) 54 | do 55 | () 56 | done 57 | 58 | let with_ (self : 'a t) f = 59 | let x = alloc self in 60 | try 61 | let res = f x in 62 | recycle self x; 63 | res 64 | with e -> 65 | let bt = Printexc.get_raw_backtrace () in 66 | recycle self x; 67 | Printexc.raise_with_backtrace e bt 68 | -------------------------------------------------------------------------------- /src/tef-tldrs/trace_tef_tldrs.mli: -------------------------------------------------------------------------------- 1 | (** Emit traces by talking to the {{:https://github.com/imandra-ai/tldrs} tldrs} 2 | daemon *) 3 | 4 | val collector : out:[ `File of string ] -> unit -> Trace_core.collector 5 | (** Make a collector that writes into the given output. See {!setup} for more 6 | details. *) 7 | 8 | val subscriber : out:[ `File of string ] -> unit -> Trace_subscriber.t 9 | (** Make a subscriber that writes into the given output. 10 | @since 0.8 *) 11 | 12 | type output = [ `File of string ] 13 | (** Output for tracing. 14 | - [`File "foo"] will enable tracing and print events into file named "foo". 15 | The file is only written at exit. *) 16 | 17 | val setup : ?out:[ output | `Env ] -> unit -> unit 18 | (** [setup ()] installs the collector depending on [out]. 19 | 20 | @param out 21 | can take different values: 22 | - regular {!output} value to specify where events go 23 | - [`Env] will enable tracing if the environment variable "TRACE" is set. 24 | 25 | - If it's set to "1", then the file is "trace.json". 26 | - If it's set to "stdout", then logging happens on stdout (since 0.2) 27 | - If it's set to "stderr", then logging happens on stdout (since 0.2) 28 | - Otherwise, if it's set to a non empty string, the value is taken to be the 29 | file path into which to write. *) 30 | 31 | val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a 32 | (** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes 33 | sure to shutdown before exiting. *) 34 | 35 | (**/**) 36 | 37 | module Private_ : sig 38 | val mock_all_ : unit -> unit 39 | (** use fake, deterministic timestamps, TID, PID *) 40 | 41 | val on_tracing_error : (string -> unit) ref 42 | end 43 | 44 | (**/**) 45 | -------------------------------------------------------------------------------- /src/event/event.ml: -------------------------------------------------------------------------------- 1 | (** Events. 2 | 3 | Each callback in a subscriber corresponds to an event, which can be for 4 | example queued somewhere or batched for further processing. *) 5 | 6 | open Trace_core 7 | module Sub = Trace_subscriber 8 | 9 | (** An event with TEF/fuchsia semantics *) 10 | type t = 11 | | E_tick 12 | | E_init of { time_ns: int64 } 13 | | E_shutdown of { time_ns: int64 } 14 | | E_message of { 15 | tid: int; 16 | msg: string; 17 | time_ns: int64; 18 | data: (string * user_data) list; 19 | } 20 | | E_define_span of { 21 | tid: int; 22 | name: string; 23 | time_ns: int64; 24 | id: span; 25 | fun_name: string option; 26 | data: (string * user_data) list; 27 | } 28 | | E_exit_span of { 29 | id: span; 30 | time_ns: int64; 31 | } 32 | | E_add_data of { 33 | id: span; 34 | data: (string * user_data) list; 35 | } 36 | | E_enter_manual_span of { 37 | tid: int; 38 | name: string; 39 | time_ns: int64; 40 | id: trace_id; 41 | flavor: span_flavor option; 42 | fun_name: string option; 43 | data: (string * user_data) list; 44 | } 45 | | E_exit_manual_span of { 46 | tid: int; 47 | name: string; 48 | time_ns: int64; 49 | flavor: span_flavor option; 50 | data: (string * user_data) list; 51 | id: trace_id; 52 | } 53 | | E_counter of { 54 | name: string; 55 | tid: int; 56 | time_ns: int64; 57 | n: float; 58 | } 59 | | E_name_process of { name: string } 60 | | E_name_thread of { 61 | tid: int; 62 | name: string; 63 | } 64 | | E_extension_event of { 65 | tid: int; 66 | time_ns: int64; 67 | ext: Trace_core.extension_event; 68 | } 69 | -------------------------------------------------------------------------------- /bench/trace_tldrs.ml: -------------------------------------------------------------------------------- 1 | module Trace = Trace_core 2 | 3 | let ( let@ ) = ( @@ ) 4 | 5 | let work ~n () : unit = 6 | for _i = 1 to n do 7 | let@ _sp = 8 | Trace.with_span ~__FILE__ ~__LINE__ "outer" ~data:(fun () -> 9 | [ "i", `Int _i ]) 10 | in 11 | for _k = 1 to 10 do 12 | let@ _sp = 13 | Trace.with_span ~__FILE__ ~__LINE__ "inner" ~data:(fun () -> 14 | (* add some big data sometimes *) 15 | if _i mod 100 = 0 && _k = 9 then 16 | [ "s", `String (String.make 5000 '-') ] 17 | else 18 | []) 19 | in 20 | () 21 | done; 22 | 23 | if _i mod 1000 = 0 then Thread.yield () 24 | (* Thread.delay 1e-6 *) 25 | done 26 | 27 | let main ~n ~j ~child () : unit = 28 | if child then 29 | work ~n () 30 | else 31 | let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "parent" in 32 | let cmd = 33 | Printf.sprintf "%s --child -n=%d" (Filename.quote Sys.argv.(0)) n 34 | in 35 | let procs = Array.init j (fun _ -> Unix.open_process_in cmd) in 36 | Array.iteri 37 | (fun idx _ic -> 38 | let@ _sp = 39 | Trace.with_span ~__FILE__ ~__LINE__ "wait.child" ~data:(fun () -> 40 | [ "i", `Int idx ]) 41 | in 42 | ignore @@ Unix.close_process_in _ic) 43 | procs 44 | 45 | let () = 46 | let@ () = Trace_tef_tldrs.with_setup () in 47 | 48 | let n = ref 10_000 in 49 | let j = ref 4 in 50 | let child = ref false in 51 | 52 | let args = 53 | [ 54 | "-n", Arg.Set_int n, " number of iterations"; 55 | "-j", Arg.Set_int j, " set number of workers"; 56 | "--child", Arg.Set child, " act as child process"; 57 | ] 58 | |> Arg.align 59 | in 60 | Arg.parse args ignore "bench1"; 61 | main ~n:!n ~j:!j ~child:!child () 62 | -------------------------------------------------------------------------------- /src/core/types.ml: -------------------------------------------------------------------------------- 1 | type span = int64 2 | (** A span identifier. 3 | 4 | The meaning of the identifier depends on the collector. *) 5 | 6 | type trace_id = string 7 | (** A bytestring representing a (possibly distributed) trace made of async 8 | spans. With opentelemetry this is 16 bytes. 9 | @since 0.10 *) 10 | 11 | type user_data = 12 | [ `Int of int 13 | | `String of string 14 | | `Bool of bool 15 | | `Float of float 16 | | `None 17 | ] 18 | (** User defined data, generally passed as key/value pairs to whatever collector 19 | is installed (if any). *) 20 | 21 | type span_flavor = 22 | [ `Sync 23 | | `Async 24 | ] 25 | (** Some information about the span. 26 | @since NEXT_RELEASE *) 27 | 28 | type explicit_span_ctx = { 29 | span: span; (** The current span *) 30 | trace_id: trace_id; (** The trace this belongs to *) 31 | } 32 | (** A context, passed around for async traces. 33 | @since 0.10 *) 34 | 35 | type explicit_span = { 36 | span: span; 37 | (** Identifier for this span. Several explicit spans might share the same 38 | identifier since we can differentiate between them via [meta]. *) 39 | trace_id: trace_id; (** The trace this belongs to *) 40 | mutable meta: Meta_map.t; 41 | (** Metadata for this span (and its context). This can be used by 42 | collectors to carry collector-specific information from the beginning 43 | of the span, to the end of the span. *) 44 | } 45 | (** Explicit span, with collector-specific metadata. This is richer than 46 | {!explicit_span_ctx} but not intended to be passed around (or sent across 47 | the wire), unlike {!explicit_span_ctx}. *) 48 | 49 | type extension_event = .. 50 | (** An extension event, used to add features that are backend specific or simply 51 | not envisioned by [trace]. 52 | @since 0.8 *) 53 | -------------------------------------------------------------------------------- /src/fuchsia/trace_fuchsia.mli: -------------------------------------------------------------------------------- 1 | (** Fuchsia trace collector. 2 | 3 | This provides a collector for traces that emits data into a file using the 4 | compact binary 5 | {{:https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format} Fuchsia 6 | trace format}. This reduces the tracing overhead compared to [trace-tef], 7 | at the expense of simplicity. *) 8 | 9 | module Buf = Buf 10 | module Buf_chain = Buf_chain 11 | module Buf_pool = Buf_pool 12 | module Exporter = Exporter 13 | module Subscriber = Subscriber 14 | module Writer = Writer 15 | 16 | type output = 17 | [ `File of string 18 | | `Exporter of Exporter.t 19 | ] 20 | 21 | val subscriber : out:[< output ] -> unit -> Trace_subscriber.t 22 | 23 | val collector : out:[< output ] -> unit -> Trace_core.collector 24 | (** Make a collector that writes into the given output. See {!setup} for more 25 | details. *) 26 | 27 | val setup : ?out:[ output | `Env ] -> unit -> unit 28 | (** [setup ()] installs the collector depending on [out]. 29 | 30 | @param out 31 | can take different values: 32 | - regular {!output} value to specify where events go 33 | - [`Env] will enable tracing if the environment variable "TRACE" is set. 34 | 35 | - If it's set to "1", then the file is "trace.fxt". 36 | - Otherwise, if it's set to a non empty string, the value is taken to be the 37 | file path into which to write. *) 38 | 39 | val with_setup : ?out:[< output | `Env > `Env ] -> unit -> (unit -> 'a) -> 'a 40 | (** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes 41 | sure to shutdown before exiting. *) 42 | 43 | (**/**) 44 | 45 | module Internal_ : sig 46 | val on_tracing_error : (string -> unit) ref 47 | 48 | val mock_all_ : unit -> unit 49 | (** use fake, deterministic timestamps, TID, PID *) 50 | end 51 | 52 | (**/**) 53 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | 3 | (name trace) 4 | 5 | (generate_opam_files true) 6 | 7 | (version 0.10) 8 | 9 | (source 10 | (github c-cube/ocaml-trace)) 11 | 12 | (authors "Simon Cruanes") 13 | 14 | (maintainers "Simon Cruanes") 15 | 16 | (license MIT) 17 | 18 | ;(documentation https://url/to/documentation) 19 | 20 | (package 21 | (name trace) 22 | (synopsis 23 | "A stub for tracing/observability, agnostic in how data is collected") 24 | (depends 25 | (ocaml 26 | (>= 4.08)) 27 | dune) 28 | (depopts 29 | hmap 30 | unix 31 | (picos_aux 32 | (>= 0.6)) 33 | (mtime 34 | (>= 2.0))) 35 | (tags 36 | (trace tracing observability profiling))) 37 | 38 | (package 39 | (name ppx_trace) 40 | (synopsis "A ppx-based preprocessor for trace") 41 | (depends 42 | (ocaml 43 | (>= 4.12)) 44 | ; we use __FUNCTION__ 45 | (ppxlib 46 | (and 47 | (>= 0.37) 48 | (< 0.38))) 49 | (trace 50 | (= :version)) 51 | (trace-tef 52 | (and 53 | (= :version) 54 | :with-test)) 55 | dune) 56 | (depopts 57 | (mtime 58 | (>= 2.0))) 59 | (tags 60 | (trace ppx))) 61 | 62 | (package 63 | (name trace-tef) 64 | (synopsis 65 | "A simple backend for trace, emitting Catapult/TEF JSON into a file") 66 | (depends 67 | (ocaml 68 | (>= 4.08)) 69 | (trace 70 | (= :version)) 71 | (mtime 72 | (>= 2.0)) 73 | base-unix 74 | dune) 75 | (tags 76 | (trace tracing catapult TEF chrome-format chrome-trace json))) 77 | 78 | (package 79 | (name trace-fuchsia) 80 | (synopsis 81 | "A high-performance backend for trace, emitting a Fuchsia trace into a file") 82 | (depends 83 | (ocaml 84 | (>= 4.08)) 85 | (trace 86 | (= :version)) 87 | (mtime 88 | (>= 2.0)) 89 | (thread-local-storage 90 | (>= 0.2)) 91 | base-bigarray 92 | base-unix 93 | dune) 94 | (tags 95 | (trace tracing fuchsia))) 96 | 97 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 98 | -------------------------------------------------------------------------------- /src/subscriber/trace_subscriber.mli: -------------------------------------------------------------------------------- 1 | (** Generic subscribers. 2 | 3 | This defines the notion of a {b subscriber}, a set of callbacks for every 4 | trace event. It also defines a collector that needs to be installed for the 5 | subscriber(s) to be called. 6 | 7 | Thanks to {!Subscriber.tee_l} it's possible to combine multiple subscribers 8 | into a single collector. 9 | 10 | @since 0.8 *) 11 | 12 | module Callbacks = Callbacks 13 | module Subscriber = Subscriber 14 | module Span_tbl = Span_tbl 15 | 16 | (** {2 Main API} *) 17 | 18 | type t = Subscriber.t 19 | (** A trace subscriber. It pairs a set of callbacks with the state they need 20 | (which can contain a file handle, a socket to write events to, config, 21 | etc.). 22 | 23 | The design goal for this is that it should be possible to avoid allocations 24 | whenever the trace collector invokes the callbacks. *) 25 | 26 | val collector : t -> Trace_core.collector 27 | (** A collector that calls the subscriber's callbacks. 28 | 29 | It uses [mtime] (if available) to obtain timestamps. *) 30 | 31 | (** A counter-based span generator. 32 | @since NEXT_RELEASE *) 33 | module Span_generator : sig 34 | type t 35 | 36 | val create : unit -> t 37 | val mk_span : t -> Trace_core.span 38 | end 39 | 40 | (** A counter-based trace ID generator, producing 8-byte trace IDs. 41 | @since NEXT_RELEASE *) 42 | module Trace_id_8B_generator : sig 43 | type t 44 | 45 | val create : unit -> t 46 | val mk_trace_id : t -> Trace_core.trace_id 47 | end 48 | 49 | (**/**) 50 | 51 | module Private_ : sig 52 | val mock : bool ref 53 | (** Global mock flag. If enable, all timestamps, tid, etc should be faked. *) 54 | 55 | val get_now_ns_ : (unit -> int64) ref 56 | (** The callback used to get the current timestamp *) 57 | 58 | val get_tid_ : (unit -> int) ref 59 | (** The callback used to get the current thread's id *) 60 | 61 | val now_ns : unit -> int64 62 | (** Get the current timestamp, or a mock version *) 63 | end 64 | 65 | (**/**) 66 | -------------------------------------------------------------------------------- /src/fuchsia/exporter.ml: -------------------------------------------------------------------------------- 1 | (** An exporter, takes buffers with fuchsia events, and writes them somewhere *) 2 | 3 | open Common_ 4 | 5 | type t = { 6 | write_bufs: Buf.t Queue.t -> unit; 7 | (** Takes buffers and writes them somewhere. The buffers are only valid 8 | during this call and must not be stored. The queue must not be 9 | modified. *) 10 | flush: unit -> unit; (** Force write *) 11 | close: unit -> unit; (** Close underlying resources *) 12 | } 13 | (** An exporter, takes buffers and writes them somewhere. This should be 14 | thread-safe if used in a threaded environment. *) 15 | 16 | open struct 17 | let with_lock lock f = 18 | Mutex.lock lock; 19 | try 20 | let res = f () in 21 | Mutex.unlock lock; 22 | res 23 | with e -> 24 | let bt = Printexc.get_raw_backtrace () in 25 | Mutex.unlock lock; 26 | Printexc.raise_with_backtrace e bt 27 | end 28 | 29 | (** Export to the channel 30 | @param close_channel if true, closing the exporter will close the channel *) 31 | let of_out_channel ~close_channel oc : t = 32 | let lock = Mutex.create () in 33 | let closed = ref false in 34 | let flush () = 35 | let@ () = with_lock lock in 36 | flush oc 37 | in 38 | let close () = 39 | let@ () = with_lock lock in 40 | if not !closed then ( 41 | closed := true; 42 | if close_channel then close_out_noerr oc 43 | ) 44 | in 45 | let write_bufs bufs = 46 | if not (Queue.is_empty bufs) then 47 | let@ () = with_lock lock in 48 | Queue.iter (fun (buf : Buf.t) -> output oc buf.buf 0 buf.offset) bufs 49 | in 50 | { flush; close; write_bufs } 51 | 52 | let of_buffer (buffer : Buffer.t) : t = 53 | let buffer = Lock.create buffer in 54 | let write_bufs bufs = 55 | if not (Queue.is_empty bufs) then 56 | let@ buffer = Lock.with_ buffer in 57 | Queue.iter 58 | (fun (buf : Buf.t) -> Buffer.add_subbytes buffer buf.buf 0 buf.offset) 59 | bufs 60 | in 61 | { flush = ignore; close = ignore; write_bufs } 62 | -------------------------------------------------------------------------------- /src/fuchsia/trace_fuchsia.ml: -------------------------------------------------------------------------------- 1 | open Common_ 2 | module Buf = Buf 3 | module Buf_chain = Buf_chain 4 | module Buf_pool = Buf_pool 5 | module Exporter = Exporter 6 | module Subscriber = Subscriber 7 | module Writer = Writer 8 | 9 | type output = 10 | [ `File of string 11 | | `Exporter of Exporter.t 12 | ] 13 | 14 | let get_out_ (out : [< output ]) : Exporter.t = 15 | match out with 16 | | `File path -> 17 | let oc = open_out path in 18 | Exporter.of_out_channel ~close_channel:true oc 19 | | `Exporter e -> e 20 | 21 | let subscriber ~out () : Sub.t = 22 | let exporter = get_out_ out in 23 | let pid = 24 | if !Trace_subscriber.Private_.mock then 25 | 2 26 | else 27 | Unix.getpid () 28 | in 29 | let sub = Subscriber.create ~pid ~exporter () in 30 | Subscriber.subscriber sub 31 | 32 | let collector ~out () = Sub.collector @@ subscriber ~out () 33 | 34 | let setup ?(out = `Env) () = 35 | match out with 36 | | `File path -> Trace_core.setup_collector @@ collector ~out:(`File path) () 37 | | `Exporter _ as out -> 38 | let sub = subscriber ~out () in 39 | Trace_core.setup_collector @@ Sub.collector sub 40 | | `Env -> 41 | (match Sys.getenv_opt "TRACE" with 42 | | Some ("1" | "true") -> 43 | let path = "trace.fxt" in 44 | let c = collector ~out:(`File path) () in 45 | Trace_core.setup_collector c 46 | | Some path -> 47 | let c = collector ~out:(`File path) () in 48 | Trace_core.setup_collector c 49 | | None -> ()) 50 | 51 | let with_setup ?out () f = 52 | setup ?out (); 53 | Fun.protect ~finally:Trace_core.shutdown f 54 | 55 | module Mock_ = struct 56 | let now = ref 0 57 | 58 | (* used to mock timing *) 59 | let get_now_ns () : int64 = 60 | let x = !now in 61 | incr now; 62 | Int64.(mul (of_int x) 1000L) 63 | 64 | let get_tid_ () : int = 3 65 | end 66 | 67 | module Internal_ = struct 68 | let mock_all_ () = 69 | Sub.Private_.mock := true; 70 | Sub.Private_.get_now_ns_ := Mock_.get_now_ns; 71 | Sub.Private_.get_tid_ := Mock_.get_tid_; 72 | () 73 | 74 | let on_tracing_error = on_tracing_error 75 | end 76 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Build and Test 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | 9 | jobs: 10 | run: 11 | name: build 12 | strategy: 13 | fail-fast: true 14 | matrix: 15 | os: 16 | - ubuntu-latest 17 | #- macos-latest 18 | #- windows-latest 19 | ocaml-compiler: 20 | - '4.08.x' 21 | - '4.12.x' 22 | - '4.14.x' 23 | - '5.1.x' 24 | 25 | runs-on: ${{ matrix.os }} 26 | steps: 27 | - uses: actions/checkout@main 28 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 29 | uses: ocaml/setup-ocaml@v3 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | dune-cache: true 33 | allow-prerelease-opam: true 34 | 35 | # check that trace compiles with no optional deps 36 | - run: opam install -t trace --deps-only 37 | - run: opam exec -- dune build '@install' -p trace 38 | 39 | # install all packages 40 | - run: opam install -t trace trace-tef trace-fuchsia --deps-only 41 | - run: opam install ppx_trace --deps-only # no tests 42 | if: matrix.ocaml-compiler != '4.08.x' 43 | - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia 44 | - run: opam exec -- dune build '@install' -p ppx_trace 45 | if: matrix.ocaml-compiler != '4.08.x' 46 | - run: opam exec -- dune runtest -p trace 47 | - run: opam install trace 48 | - run: opam exec -- dune runtest -p trace-tef,trace-fuchsia 49 | 50 | # with depopts 51 | - run: opam install hmap 52 | - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia 53 | 54 | - run: opam install picos_aux 55 | if: matrix.ocaml-compiler != '4.08.x' && matrix.ocaml-compiler != '4.12.x' 56 | - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia 57 | if: matrix.ocaml-compiler != '4.08.x' && matrix.ocaml-compiler != '4.12.x' 58 | 59 | - run: opam install mtime 60 | - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia 61 | 62 | -------------------------------------------------------------------------------- /test/fuchsia/write/t1.ml: -------------------------------------------------------------------------------- 1 | open Trace_fuchsia 2 | 3 | module Str_ = struct 4 | open String 5 | 6 | let to_hex (s : string) : string = 7 | let i_to_hex (i : int) = 8 | if i < 10 then 9 | Char.chr (i + Char.code '0') 10 | else 11 | Char.chr (i - 10 + Char.code 'a') 12 | in 13 | 14 | let res = Bytes.create (2 * length s) in 15 | for i = 0 to length s - 1 do 16 | let n = Char.code (get s i) in 17 | Bytes.set res (2 * i) (i_to_hex ((n land 0xf0) lsr 4)); 18 | Bytes.set res ((2 * i) + 1) (i_to_hex (n land 0x0f)) 19 | done; 20 | Bytes.unsafe_to_string res 21 | 22 | let of_hex_exn (s : string) : string = 23 | let n_of_c = function 24 | | '0' .. '9' as c -> Char.code c - Char.code '0' 25 | | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a' 26 | | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A' 27 | | _ -> invalid_arg "string: invalid hex" 28 | in 29 | if String.length s mod 2 <> 0 then 30 | invalid_arg "string: hex sequence must be of even length"; 31 | let res = Bytes.make (String.length s / 2) '\x00' in 32 | for i = 0 to (String.length s / 2) - 1 do 33 | let n1 = n_of_c (String.get s (2 * i)) in 34 | let n2 = n_of_c (String.get s ((2 * i) + 1)) in 35 | let n = (n1 lsl 4) lor n2 in 36 | Bytes.set res i (Char.chr n) 37 | done; 38 | Bytes.unsafe_to_string res 39 | end 40 | 41 | let () = 42 | let l = List.init 100 (fun i -> Writer.Util.round_to_word i) in 43 | assert (List.for_all (fun x -> x mod 8 = 0) l) 44 | 45 | let () = 46 | assert (Writer.Str_ref.inline 0 = 0b0000_0000_0000_0000); 47 | assert (Writer.Str_ref.inline 1 = 0b1000_0000_0000_0001); 48 | assert (Writer.Str_ref.inline 6 = 0b1000_0000_0000_0110); 49 | assert (Writer.Str_ref.inline 31999 = 0b1111_1100_1111_1111); 50 | () 51 | 52 | let () = 53 | let buf = Buf.create 128 in 54 | Buf.add_i64 buf 42L; 55 | assert (Buf.to_string buf = "\x2a\x00\x00\x00\x00\x00\x00\x00") 56 | 57 | let () = 58 | let buf = Buf.create 128 in 59 | Buf.add_string buf ""; 60 | assert (Buf.to_string buf = "") 61 | 62 | let () = 63 | let buf = Buf.create 128 in 64 | Buf.add_string buf "hello"; 65 | assert (Buf.to_string buf = "hello\x00\x00\x00") 66 | -------------------------------------------------------------------------------- /src/tef/trace_tef.mli: -------------------------------------------------------------------------------- 1 | module Subscriber = Subscriber 2 | module Exporter = Exporter 3 | module Writer = Writer 4 | 5 | type output = 6 | [ `Stdout 7 | | `Stderr 8 | | `File of string 9 | ] 10 | (** Output for tracing. 11 | 12 | - [`Stdout] will enable tracing and print events on stdout 13 | - [`Stderr] will enable tracing and print events on stderr 14 | - [`File "foo"] will enable tracing and print events into file named "foo" 15 | *) 16 | 17 | val subscriber : out:[< output ] -> unit -> Trace_subscriber.t 18 | (** A subscriber emitting TEF traces into [out]. 19 | @since 0.8 *) 20 | 21 | val collector : out:[< output ] -> unit -> Trace_core.collector 22 | (** Make a collector that writes into the given output. See {!setup} for more 23 | details. *) 24 | 25 | val setup : ?out:[ output | `Env ] -> unit -> unit 26 | (** [setup ()] installs the collector depending on [out]. 27 | 28 | @param out 29 | can take different values: 30 | - regular {!output} value to specify where events go 31 | - [`Env] will enable tracing if the environment variable "TRACE" is set. 32 | 33 | - If it's set to "1", then the file is "trace.json". 34 | - If it's set to "stdout", then logging happens on stdout (since 0.2) 35 | - If it's set to "stderr", then logging happens on stdout (since 0.2) 36 | - Otherwise, if it's set to a non empty string, the value is taken to be the 37 | file path into which to write. *) 38 | 39 | val with_setup : ?out:[ output | `Env ] -> unit -> (unit -> 'a) -> 'a 40 | (** [with_setup () f] (optionally) sets a collector up, calls [f()], and makes 41 | sure to shutdown before exiting. since 0.2 a () argument was added. *) 42 | 43 | (**/**) 44 | 45 | module Private_ : sig 46 | val mock_all_ : unit -> unit 47 | (** use fake, deterministic timestamps, TID, PID *) 48 | 49 | val on_tracing_error : (string -> unit) ref 50 | 51 | val subscriber_jsonl : 52 | finally:(unit -> unit) -> 53 | out:[ `File_append of string | `Output of out_channel ] -> 54 | unit -> 55 | Trace_subscriber.t 56 | 57 | val collector_jsonl : 58 | finally:(unit -> unit) -> 59 | out:[ `File_append of string | `Output of out_channel ] -> 60 | unit -> 61 | Trace_core.collector 62 | 63 | module Event = Event 64 | end 65 | 66 | (**/**) 67 | -------------------------------------------------------------------------------- /bench/bench_fuchsia_write.ml: -------------------------------------------------------------------------------- 1 | open Trace_fuchsia 2 | open Trace_fuchsia.Writer 3 | module B = Benchmark 4 | 5 | let pf = Printf.printf 6 | 7 | let encode_1000_span (bufs : Buf_chain.t) () = 8 | for _i = 1 to 1000 do 9 | Event.Duration_complete.encode bufs ~name:"span" ~t_ref:(Thread_ref.Ref 5) 10 | ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] () 11 | done; 12 | Buf_chain.ready_all_non_empty bufs; 13 | Buf_chain.pop_ready bufs ~f:ignore; 14 | () 15 | 16 | let encode_300_span (bufs : Buf_chain.t) () = 17 | for _i = 1 to 100 do 18 | Event.Duration_complete.encode bufs ~name:"outer" ~t_ref:(Thread_ref.Ref 5) 19 | ~time_ns:100_000L ~end_time_ns:5_000_000L ~args:[] (); 20 | Event.Duration_complete.encode bufs ~name:"inner" ~t_ref:(Thread_ref.Ref 5) 21 | ~time_ns:180_000L ~end_time_ns:4_500_000L ~args:[] (); 22 | Event.Instant.encode bufs ~name:"hello" ~time_ns:1_234_567L 23 | ~t_ref:(Thread_ref.Ref 5) 24 | ~args:[ "x", A_int 42 ] 25 | () 26 | done; 27 | Buf_chain.ready_all_non_empty bufs; 28 | Buf_chain.pop_ready bufs ~f:ignore; 29 | () 30 | 31 | let time_per_iter_ns n_per_iter (samples : B.t list) : float = 32 | let n_iters = ref 0L in 33 | let time = ref 0. in 34 | List.iter 35 | (fun (s : B.t) -> 36 | n_iters := Int64.add !n_iters s.iters; 37 | time := !time +. s.stime +. s.utime) 38 | samples; 39 | !time *. 1e9 /. (Int64.to_float !n_iters *. float n_per_iter) 40 | 41 | let () = 42 | let buf_pool = Buf_pool.create () in 43 | let bufs = Buf_chain.create ~sharded:false ~buf_pool () in 44 | 45 | let samples = 46 | B.throughput1 4 ~name:"encode_1000_span" (encode_1000_span bufs) () 47 | in 48 | B.print_gc samples; 49 | 50 | let [ (_, samples) ] = samples [@@warning "-8"] in 51 | let iter_per_ns = time_per_iter_ns 1000 samples in 52 | pf "%.3f ns/iter\n" iter_per_ns; 53 | 54 | () 55 | 56 | let () = 57 | let buf_pool = Buf_pool.create () in 58 | let bufs = Buf_chain.create ~sharded:false ~buf_pool () in 59 | let samples = 60 | B.throughput1 4 ~name:"encode_300_span" (encode_300_span bufs) () 61 | in 62 | B.print_gc samples; 63 | 64 | let [ (_, samples) ] = samples [@@warning "-8"] in 65 | let iter_per_ns = time_per_iter_ns 300 samples in 66 | pf "%.3f ns/iter\n" iter_per_ns; 67 | () 68 | -------------------------------------------------------------------------------- /src/core/meta_map.ourown.ml: -------------------------------------------------------------------------------- 1 | module type KEY_IMPL = sig 2 | type t 3 | 4 | exception Store of t 5 | 6 | val id : int 7 | end 8 | 9 | module Key = struct 10 | type 'a t = (module KEY_IMPL with type t = 'a) 11 | 12 | let _n = ref 0 13 | 14 | let create (type k) () = 15 | incr _n; 16 | let id = !_n in 17 | let module K = struct 18 | type t = k 19 | 20 | let id = id 21 | 22 | exception Store of k 23 | end in 24 | (module K : KEY_IMPL with type t = k) 25 | 26 | let[@inline] id (type k) (module K : KEY_IMPL with type t = k) = K.id 27 | 28 | let equal : type a b. a t -> b t -> bool = 29 | fun (module K1) (module K2) -> K1.id = K2.id 30 | end 31 | 32 | type 'a key = 'a Key.t 33 | type binding = B : 'a Key.t * 'a -> binding 34 | 35 | open struct 36 | type exn_pair = E_pair : 'a Key.t * exn -> exn_pair 37 | 38 | let pair_of_e_pair (E_pair (k, e)) = 39 | let module K = (val k) in 40 | match e with 41 | | K.Store v -> B (k, v) 42 | | _ -> assert false 43 | end 44 | 45 | module M = Map.Make (struct 46 | type t = int 47 | 48 | let compare (i : int) j = Stdlib.compare i j 49 | end) 50 | 51 | type t = { m: exn_pair M.t } [@@unboxed] 52 | 53 | let empty : t = { m = M.empty } 54 | let[@inline] mem k (self : t) = M.mem (Key.id k) self.m 55 | 56 | let find_exn (type a) (k : a Key.t) (self : t) : a = 57 | let module K = (val k) in 58 | let (E_pair (_, e)) = M.find K.id self.m in 59 | match e with 60 | | K.Store v -> v 61 | | _ -> assert false 62 | 63 | let find k (self : t) = try Some (find_exn k self) with Not_found -> None 64 | 65 | open struct 66 | let add_e_pair_ p self = 67 | let (E_pair ((module K), _)) = p in 68 | { m = M.add K.id p self.m } 69 | 70 | let add_pair_ p (self : t) : t = 71 | let (B (((module K) as k), v)) = p in 72 | let p = E_pair (k, K.Store v) in 73 | { m = M.add K.id p self.m } 74 | end 75 | 76 | let add (type a) (k : a Key.t) v (self : t) : t = 77 | let module K = (val k) in 78 | add_e_pair_ (E_pair (k, K.Store v)) self 79 | 80 | let remove (type a) (k : a Key.t) (self : t) : t = 81 | let module K = (val k) in 82 | { m = M.remove K.id self.m } 83 | 84 | let[@inline] cardinal (self : t) = M.cardinal self.m 85 | let length = cardinal 86 | let iter f (self : t) = M.iter (fun _ p -> f (pair_of_e_pair p)) self.m 87 | 88 | let to_list (self : t) : binding list = 89 | M.fold (fun _ p l -> pair_of_e_pair p :: l) self.m [] 90 | 91 | let add_list (self : t) l = List.fold_right add_pair_ l self 92 | -------------------------------------------------------------------------------- /test/fuchsia/t1.ml: -------------------------------------------------------------------------------- 1 | let run () = 2 | Trace.set_process_name "main"; 3 | Trace.set_thread_name "t1"; 4 | 5 | let n = ref 0 in 6 | 7 | for _i = 1 to 50 do 8 | Trace.with_span ~__FILE__ ~__LINE__ "outer.loop" @@ fun _sp -> 9 | let pseudo_async_sp = 10 | Trace.enter_manual_span ~parent:None ~__FILE__ ~__LINE__ "fake_sleep" 11 | in 12 | 13 | for _j = 2 to 5 do 14 | incr n; 15 | Trace.with_span ~__FILE__ ~__LINE__ "inner.loop" @@ fun _sp -> 16 | Trace.messagef (fun k -> k "hello %d %d" _i _j); 17 | Trace.message "world"; 18 | Trace.counter_int "n" !n; 19 | 20 | Trace.add_data_to_span _sp [ "i", `Int _i ]; 21 | 22 | if _j = 2 then ( 23 | Trace.add_data_to_span _sp [ "j", `Int _j ]; 24 | let _sp = 25 | Trace.enter_manual_span 26 | ~parent:(Some (Trace.ctx_of_span pseudo_async_sp)) 27 | ~flavor: 28 | (if _i mod 3 = 0 then 29 | `Sync 30 | else 31 | `Async) 32 | ~__FILE__ ~__LINE__ "sub-sleep" 33 | in 34 | 35 | (* fake micro sleep *) 36 | Thread.delay 0.005; 37 | Trace.exit_manual_span _sp 38 | ) else if _j = 3 then ( 39 | (* pretend some task finished. Note that this is not well scoped wrt other spans. *) 40 | Trace.add_data_to_manual_span pseudo_async_sp [ "slept", `Bool true ]; 41 | Trace.exit_manual_span pseudo_async_sp 42 | ) 43 | done 44 | done 45 | 46 | let to_hex (s : string) : string = 47 | let i_to_hex (i : int) = 48 | if i < 10 then 49 | Char.chr (i + Char.code '0') 50 | else 51 | Char.chr (i - 10 + Char.code 'a') 52 | in 53 | 54 | let res = Bytes.create (2 * String.length s) in 55 | for i = 0 to String.length s - 1 do 56 | let n = Char.code (String.get s i) in 57 | Bytes.set res (2 * i) (i_to_hex ((n land 0xf0) lsr 4)); 58 | Bytes.set res ((2 * i) + 1) (i_to_hex (n land 0x0f)) 59 | done; 60 | Bytes.unsafe_to_string res 61 | 62 | let () = 63 | Trace_fuchsia.Internal_.mock_all_ (); 64 | let buf = Buffer.create 32 in 65 | let exporter = Trace_fuchsia.Exporter.of_buffer buf in 66 | Trace_fuchsia.with_setup ~out:(`Exporter exporter) () run; 67 | exporter.close (); 68 | 69 | let data = Buffer.contents buf in 70 | (let oc = open_out_bin "t1.fxt" in 71 | output_string oc data; 72 | close_out_noerr oc); 73 | 74 | (* print_endline (to_hex data); *) 75 | Printf.printf "data: %d bytes\n" (String.length data); 76 | flush stdout 77 | -------------------------------------------------------------------------------- /src/tef/exporter.ml: -------------------------------------------------------------------------------- 1 | (** An exporter, takes JSON objects and writes them somewhere *) 2 | 3 | open Common_ 4 | 5 | type t = { 6 | on_json: Buffer.t -> unit; 7 | (** Takes a buffer and writes it somewhere. The buffer is only valid 8 | during this call and must not be stored. *) 9 | flush: unit -> unit; (** Force write *) 10 | close: unit -> unit; (** Close underlying resources *) 11 | } 12 | (** An exporter, takes JSON objects and writes them somewhere. 13 | 14 | This should be thread-safe if used in a threaded environment. *) 15 | 16 | open struct 17 | let with_lock lock f = 18 | Mutex.lock lock; 19 | try 20 | let res = f () in 21 | Mutex.unlock lock; 22 | res 23 | with e -> 24 | let bt = Printexc.get_raw_backtrace () in 25 | Mutex.unlock lock; 26 | Printexc.raise_with_backtrace e bt 27 | end 28 | 29 | (** Export to the channel 30 | @param jsonl 31 | if true, export as a JSON object per line, otherwise export as a single 32 | big JSON array. 33 | @param close_channel if true, closing the exporter will close the channel *) 34 | let of_out_channel ~close_channel ~jsonl oc : t = 35 | let lock = Mutex.create () in 36 | let first = ref true in 37 | let closed = ref false in 38 | let flush () = 39 | let@ () = with_lock lock in 40 | flush oc 41 | in 42 | let close () = 43 | let@ () = with_lock lock in 44 | if not !closed then ( 45 | closed := true; 46 | if not jsonl then output_char oc ']'; 47 | if close_channel then close_out_noerr oc 48 | ) 49 | in 50 | let on_json buf = 51 | let@ () = with_lock lock in 52 | if not jsonl then 53 | if !first then ( 54 | if not jsonl then output_char oc '['; 55 | first := false 56 | ) else 57 | output_string oc ",\n"; 58 | Buffer.output_buffer oc buf; 59 | if jsonl then output_char oc '\n' 60 | in 61 | { flush; close; on_json } 62 | 63 | let of_buffer ~jsonl (buf : Buffer.t) : t = 64 | let lock = Mutex.create () in 65 | let first = ref true in 66 | let closed = ref false in 67 | let close () = 68 | let@ () = with_lock lock in 69 | if not !closed then ( 70 | closed := true; 71 | if not jsonl then Buffer.add_char buf ']' 72 | ) 73 | in 74 | let on_json json = 75 | let@ () = with_lock lock in 76 | if not jsonl then 77 | if !first then ( 78 | if not jsonl then Buffer.add_char buf '['; 79 | first := false 80 | ) else 81 | Buffer.add_string buf ",\n"; 82 | Buffer.add_buffer buf json; 83 | if jsonl then Buffer.add_char buf '\n' 84 | in 85 | { flush = ignore; close; on_json } 86 | -------------------------------------------------------------------------------- /src/event/subscriber.ml: -------------------------------------------------------------------------------- 1 | (** Subscriber that emits events *) 2 | 3 | open Trace_core 4 | open Event 5 | 6 | type event_consumer = { on_event: Event.t -> unit } [@@unboxed] 7 | (** Callback for events. *) 8 | 9 | open struct 10 | (* just use the same ones for everyone *) 11 | 12 | let span_gen = Sub.Span_generator.create () 13 | let trace_id_gen = Sub.Trace_id_8B_generator.create () 14 | end 15 | 16 | module Callbacks : Sub.Callbacks.S with type st = event_consumer = struct 17 | type st = event_consumer 18 | 19 | let new_span (_self : st) = Sub.Span_generator.mk_span span_gen 20 | let new_trace_id _self = Sub.Trace_id_8B_generator.mk_trace_id trace_id_gen 21 | let on_init (self : st) ~time_ns = self.on_event (E_init { time_ns }) 22 | let on_shutdown (self : st) ~time_ns = self.on_event (E_shutdown { time_ns }) 23 | 24 | let on_name_process (self : st) ~time_ns:_ ~tid:_ ~name : unit = 25 | self.on_event @@ E_name_process { name } 26 | 27 | let on_name_thread (self : st) ~time_ns:_ ~tid ~name : unit = 28 | self.on_event @@ E_name_thread { tid; name } 29 | 30 | let[@inline] on_enter_span (self : st) ~__FUNCTION__:fun_name ~__FILE__:_ 31 | ~__LINE__:_ ~time_ns ~tid ~data ~name span : unit = 32 | self.on_event 33 | @@ E_define_span { tid; name; time_ns; id = span; fun_name; data } 34 | 35 | let on_exit_span (self : st) ~time_ns ~tid:_ span : unit = 36 | self.on_event @@ E_exit_span { id = span; time_ns } 37 | 38 | let on_add_data (self : st) ~data span = 39 | if data <> [] then self.on_event @@ E_add_data { id = span; data } 40 | 41 | let on_message (self : st) ~time_ns ~tid ~span:_ ~data msg : unit = 42 | self.on_event @@ E_message { tid; time_ns; msg; data } 43 | 44 | let on_counter (self : st) ~time_ns ~tid ~data:_ ~name f : unit = 45 | self.on_event @@ E_counter { name; n = f; time_ns; tid } 46 | 47 | let on_enter_manual_span (self : st) ~__FUNCTION__:fun_name ~__FILE__:_ 48 | ~__LINE__:_ ~time_ns ~tid ~parent:_ ~data ~name ~flavor ~trace_id _span : 49 | unit = 50 | self.on_event 51 | @@ E_enter_manual_span 52 | { id = trace_id; time_ns; tid; data; name; fun_name; flavor } 53 | 54 | let on_exit_manual_span (self : st) ~time_ns ~tid ~name ~data ~flavor 55 | ~trace_id (_ : span) : unit = 56 | self.on_event 57 | @@ E_exit_manual_span { tid; id = trace_id; name; time_ns; data; flavor } 58 | 59 | let on_extension_event (self : st) ~time_ns ~tid ext : unit = 60 | self.on_event @@ E_extension_event { tid; time_ns; ext } 61 | end 62 | 63 | (** A subscriber that turns calls into events that are passed to the 64 | {! event_consumer} *) 65 | let subscriber (consumer : event_consumer) : Sub.t = 66 | Sub.Subscriber.Sub { st = consumer; callbacks = (module Callbacks) } 67 | -------------------------------------------------------------------------------- /test/fuchsia/write/t2.ml: -------------------------------------------------------------------------------- 1 | open Trace_fuchsia 2 | open Trace_fuchsia.Writer 3 | 4 | let pf = Printf.printf 5 | 6 | module Str_ = struct 7 | open String 8 | 9 | let to_hex (s : string) : string = 10 | let i_to_hex (i : int) = 11 | if i < 10 then 12 | Char.chr (i + Char.code '0') 13 | else 14 | Char.chr (i - 10 + Char.code 'a') 15 | in 16 | 17 | let res = Bytes.create (2 * length s) in 18 | for i = 0 to length s - 1 do 19 | let n = Char.code (get s i) in 20 | Bytes.set res (2 * i) (i_to_hex ((n land 0xf0) lsr 4)); 21 | Bytes.set res ((2 * i) + 1) (i_to_hex (n land 0x0f)) 22 | done; 23 | Bytes.unsafe_to_string res 24 | 25 | let of_hex_exn (s : string) : string = 26 | let n_of_c = function 27 | | '0' .. '9' as c -> Char.code c - Char.code '0' 28 | | 'a' .. 'f' as c -> 10 + Char.code c - Char.code 'a' 29 | | 'A' .. 'F' as c -> 10 + Char.code c - Char.code 'A' 30 | | _ -> invalid_arg "string: invalid hex" 31 | in 32 | if String.length s mod 2 <> 0 then 33 | invalid_arg "string: hex sequence must be of even length"; 34 | let res = Bytes.make (String.length s / 2) '\x00' in 35 | for i = 0 to (String.length s / 2) - 1 do 36 | let n1 = n_of_c (String.get s (2 * i)) in 37 | let n2 = n_of_c (String.get s ((2 * i) + 1)) in 38 | let n = (n1 lsl 4) lor n2 in 39 | Bytes.set res i (Char.chr n) 40 | done; 41 | Bytes.unsafe_to_string res 42 | end 43 | 44 | let with_buf_chain (f : Buf_chain.t -> unit) : string = 45 | let buf_pool = Buf_pool.create () in 46 | let buffer = Buffer.create 32 in 47 | let buf_chain = Buf_chain.create ~sharded:true ~buf_pool () in 48 | f buf_chain; 49 | 50 | Buf_chain.ready_all_non_empty buf_chain; 51 | let exp = Exporter.of_buffer buffer in 52 | Buf_chain.pop_ready buf_chain ~f:exp.write_bufs; 53 | Buffer.contents buffer 54 | 55 | let () = pf "first trace\n" 56 | 57 | let () = 58 | let str = 59 | with_buf_chain (fun bufs -> 60 | Metadata.Magic_record.encode bufs; 61 | Thread_record.encode bufs ~as_ref:5 ~pid:1 ~tid:86 (); 62 | Event.Instant.encode bufs ~name:"hello" ~time_ns:1234_5678L 63 | ~t_ref:(Thread_ref.Ref 5) 64 | ~args:[ "x", A_int 42 ] 65 | ()) 66 | in 67 | pf "%s\n" (Str_.to_hex str) 68 | 69 | let () = pf "second trace\n" 70 | 71 | let () = 72 | let str = 73 | with_buf_chain (fun bufs -> 74 | Metadata.Magic_record.encode bufs; 75 | Metadata.Initialization_record.( 76 | encode bufs ~ticks_per_secs:default_ticks_per_sec ()); 77 | Thread_record.encode bufs ~as_ref:5 ~pid:1 ~tid:86 (); 78 | Metadata.Provider_info.encode bufs ~id:1 ~name:"ocaml-trace" (); 79 | Event.Duration_complete.encode bufs ~name:"outer" 80 | ~t_ref:(Thread_ref.Ref 5) ~time_ns:100_000L ~end_time_ns:5_000_000L 81 | ~args:[] (); 82 | Event.Duration_complete.encode bufs ~name:"inner" 83 | ~t_ref:(Thread_ref.Ref 5) ~time_ns:180_000L ~end_time_ns:4_500_000L 84 | ~args:[] (); 85 | Event.Instant.encode bufs ~name:"hello" ~time_ns:1_234_567L 86 | ~t_ref:(Thread_ref.Ref 5) 87 | ~args:[ "x", A_int 42 ] 88 | ()) 89 | in 90 | (let oc = open_out "foo.fxt" in 91 | output_string oc str; 92 | close_out oc); 93 | pf "%s\n" (Str_.to_hex str) 94 | -------------------------------------------------------------------------------- /src/tef/writer.ml: -------------------------------------------------------------------------------- 1 | open Common_ 2 | 3 | let char = Buffer.add_char 4 | let raw_string = Buffer.add_string 5 | 6 | let str_val (buf : Buffer.t) (s : string) = 7 | char buf '"'; 8 | let encode_char c = 9 | match c with 10 | | '"' -> raw_string buf {|\"|} 11 | | '\\' -> raw_string buf {|\\|} 12 | | '\n' -> raw_string buf {|\n|} 13 | | '\b' -> raw_string buf {|\b|} 14 | | '\r' -> raw_string buf {|\r|} 15 | | '\t' -> raw_string buf {|\t|} 16 | | _ when Char.code c <= 0x1f -> 17 | raw_string buf {|\u00|}; 18 | Printf.bprintf buf "%02x" (Char.code c) 19 | | c -> char buf c 20 | in 21 | String.iter encode_char s; 22 | char buf '"' 23 | 24 | let pp_user_data_ (out : Buffer.t) : Trace_core.user_data -> unit = function 25 | | `None -> raw_string out "null" 26 | | `Int i -> Printf.bprintf out "%d" i 27 | | `Bool b -> Printf.bprintf out "%b" b 28 | | `String s -> str_val out s 29 | | `Float f -> Printf.bprintf out "%g" f 30 | 31 | (* emit args, if not empty. [ppv] is used to print values. *) 32 | let emit_args_o_ ppv (out : Buffer.t) args : unit = 33 | if args <> [] then ( 34 | Printf.bprintf out {json|,"args": {|json}; 35 | List.iteri 36 | (fun i (n, value) -> 37 | if i > 0 then raw_string out ","; 38 | Printf.bprintf out {json|"%s":%a|json} n ppv value) 39 | args; 40 | char out '}' 41 | ) 42 | 43 | let emit_duration_event ~pid ~tid ~name ~start ~end_ ~args buf : unit = 44 | let dur = end_ -. start in 45 | let ts = start in 46 | 47 | Printf.bprintf buf 48 | {json|{"pid":%d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json} 49 | pid tid dur ts str_val name 50 | (emit_args_o_ pp_user_data_) 51 | args 52 | 53 | let emit_manual_begin ~pid ~tid ~name ~(id : int64) ~ts ~args 54 | ~(flavor : Trace_core.span_flavor option) buf : unit = 55 | Printf.bprintf buf 56 | {json|{"pid":%d,"cat":"trace","id":%Ld,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json} 57 | pid id tid ts str_val name 58 | (match flavor with 59 | | None | Some `Async -> 'b' 60 | | Some `Sync -> 'B') 61 | (emit_args_o_ pp_user_data_) 62 | args 63 | 64 | let emit_manual_end ~pid ~tid ~name ~(id : int64) ~ts 65 | ~(flavor : Trace_core.span_flavor option) ~args buf : unit = 66 | Printf.bprintf buf 67 | {json|{"pid":%d,"cat":"trace","id":%Ld,"tid": %d,"ts": %.2f,"name":%a,"ph":"%c"%a}|json} 68 | pid id tid ts str_val name 69 | (match flavor with 70 | | None | Some `Async -> 'e' 71 | | Some `Sync -> 'E') 72 | (emit_args_o_ pp_user_data_) 73 | args 74 | 75 | let emit_instant_event ~pid ~tid ~name ~ts ~args buf : unit = 76 | Printf.bprintf buf 77 | {json|{"pid":%d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"I"%a}|json} 78 | pid tid ts str_val name 79 | (emit_args_o_ pp_user_data_) 80 | args 81 | 82 | let emit_name_thread ~pid ~tid ~name buf : unit = 83 | Printf.bprintf buf 84 | {json|{"pid":%d,"tid": %d,"name":"thread_name","ph":"M"%a}|json} pid tid 85 | (emit_args_o_ pp_user_data_) 86 | [ "name", `String name ] 87 | 88 | let emit_name_process ~pid ~name buf : unit = 89 | Printf.bprintf buf {json|{"pid":%d,"name":"process_name","ph":"M"%a}|json} pid 90 | (emit_args_o_ pp_user_data_) 91 | [ "name", `String name ] 92 | 93 | let emit_counter ~pid ~tid ~name ~ts buf f : unit = 94 | Printf.bprintf buf 95 | {json|{"pid":%d,"tid":%d,"ts":%.2f,"name":"c","ph":"C"%a}|json} pid tid ts 96 | (emit_args_o_ pp_user_data_) 97 | [ name, `Float f ] 98 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.10 2 | 3 | - breaking: manual spans now take a `explicit_span_ctx` as parent, that 4 | can potentially be transmitted across processes/machines. It also 5 | is intended to be more compatible with OTEL. 6 | - breaking `trace.subscriber`: timestamps are `int64`ns now, not floats 7 | - breaking `trace`: pass a `string` trace_id in manual spans, which helps 8 | for backends such as opentelemetry. It's also useful for extensions. 9 | 10 | - refactor `trace-fuchsia`: full revamp of the library, modularized, using subscriber API 11 | - refactor `trace-tef`: split into exporter,writer,subscriber, using subscriber API 12 | - feat: add `trace.event`, useful for background threads 13 | - feat `trace.subscriber`: add `Span_tbl`, and a depopt on picos_aux 14 | - feat `trace.subscriber`: tee a whole array at once 15 | - feat tef-tldrs: use EMIT_TEF_AT_EXIT 16 | - feat `trace.subscriber`: depopt on unix for timestamps 17 | - refactor `trace-tef`: depopt on unix for TEF timestamps 18 | 19 | 20 | # 0.9.1 21 | 22 | 23 | - fix: upper bound on ppxlib 24 | - feat trace-tef: print names of non-closed spans upon exit 25 | - fix: block signals in background threads 26 | 27 | # 0.9 28 | 29 | - add an extensible sum type, so users can implement custom events. For example 30 | an OTEL collector can provide custom events to link two spans to one another. 31 | 32 | # 0.8 33 | 34 | - add `trace.subscriber` instead of a separate library 35 | - add `trace-tef.tldrs`, to trace multiple processes easily (with external rust daemon) 36 | 37 | - breaking: `trace-tef`: use `mtime.now`, not a counter, for multiproc 38 | - `trace-fuchsia`: require thread-local-storage 0.2 39 | 40 | # 0.7 41 | 42 | - feat: add levels to `Trace_core`. Levels are similar to `logs` levels, to help control verbosity. 43 | - add hmap as a depopt (#28) 44 | 45 | - fix: truncate large strings in fuchsia 46 | 47 | # 0.6 48 | 49 | - add `ppx_trace` for easier instrumentation. 50 | * `let%trace span = "foo" in …` will enter a scope `span` named "foo" 51 | * `let%trace () = "foo" in …` will enter a scope named "foo" with a hidden name 52 | - add `trace-fuchsia` backend, which produces traces in the binary format 53 | of [fuchsia](https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format). 54 | These traces are reasonably efficient to produce (~60ns per span on my machines) 55 | and reasonably compact on disk, at least compared to the TEF backend. 56 | 57 | # 0.5 58 | 59 | - perf: reduce overhead in trace-tef 60 | - perf: add Mpsc_queue, adapted from picos, to trace-tef 61 | 62 | # 0.4 63 | 64 | - add `?data` to `counter_int` and `counter_float` 65 | - add `float` to user data 66 | - add `add_data_to_current_span` and `add_data_to_manual_span` 67 | - make `explicit_span.meta` mutable 68 | - trace-tef: write to `trace.json` if env variable `TRACE` is either 1 or true 69 | - trace-tef: emit function name, if provided, as a metadata key/value pair 70 | - re-export trace.core in trace 71 | 72 | - perf: in trace-tef, use broadcast instead of signal in the job queue 73 | 74 | # 0.3 75 | 76 | - add explicit spans, for more precise tracing 77 | - rename repo to ocaml-trace 78 | - trace-tef: add a ticker thread to ensure we flush the file regularly 79 | 80 | # 0.2 81 | 82 | - trace-tef: additional argument to `with_setup`; env for "stdout"/"stderr" 83 | - refactor: avoid conflicting with stdlib `Trace` module by adding sublibrary `trace.core`. 84 | Programs that use `compiler-libs.toplevel` should use `trace.core` 85 | directly, because using `trace` will cause linking errors. 86 | - perf(trace-tef): improve behavior of collector under contention by 87 | pulling all events at once in the worker 88 | 89 | # 0.1 90 | 91 | initial release 92 | -------------------------------------------------------------------------------- /src/core/collector.ml: -------------------------------------------------------------------------------- 1 | (** A global collector. 2 | 3 | The collector, if present, is responsible for collecting messages and spans, 4 | and storing them, recording them, forward them, or offering them to other 5 | services and processes. *) 6 | 7 | open Types 8 | 9 | let dummy_span : span = Int64.min_int 10 | let dummy_trace_id : trace_id = "" 11 | 12 | let dummy_explicit_span : explicit_span = 13 | { span = dummy_span; trace_id = dummy_trace_id; meta = Meta_map.empty } 14 | 15 | let dummy_explicit_span_ctx : explicit_span_ctx = 16 | { span = dummy_span; trace_id = dummy_trace_id } 17 | 18 | (** Signature for a collector. 19 | 20 | This is only relevant to implementors of tracing backends; to instrument 21 | your code you only need to look at the {!Trace} module. *) 22 | module type S = sig 23 | val with_span : 24 | __FUNCTION__:string option -> 25 | __FILE__:string -> 26 | __LINE__:int -> 27 | data:(string * user_data) list -> 28 | string -> 29 | (span -> 'a) -> 30 | 'a 31 | (** Run the function in a new span. 32 | @since 0.3 *) 33 | 34 | val enter_span : 35 | __FUNCTION__:string option -> 36 | __FILE__:string -> 37 | __LINE__:int -> 38 | data:(string * user_data) list -> 39 | string -> 40 | span 41 | (** Enter a new implicit span. For many uses cases, {!with_span} will be 42 | easier to use. 43 | @since 0.6 *) 44 | 45 | val exit_span : span -> unit 46 | (** Exit span. This should be called on the same thread as the corresponding 47 | {!enter_span}, and nest properly with other calls to enter/exit_span and 48 | {!with_span}. 49 | @since 0.6 *) 50 | 51 | val enter_manual_span : 52 | parent:explicit_span_ctx option -> 53 | flavor:[ `Sync | `Async ] option -> 54 | __FUNCTION__:string option -> 55 | __FILE__:string -> 56 | __LINE__:int -> 57 | data:(string * user_data) list -> 58 | string -> 59 | explicit_span 60 | (** Enter an explicit span. Surrounding scope, if any, is provided by 61 | [parent], and this function can store as much metadata as it wants in the 62 | hmap in the {!explicit_span}'s [meta] field. 63 | 64 | {b NOTE} the [parent] argument is now an {!explicit_span_ctx} and not an 65 | {!explicit_span} since 0.10. 66 | 67 | This means that the collector doesn't need to implement contextual storage 68 | mapping {!span} to scopes, metadata, etc. on its side; everything can be 69 | transmitted in the {!explicit_span}. 70 | @since 0.3 *) 71 | 72 | val exit_manual_span : explicit_span -> unit 73 | (** Exit an explicit span. 74 | @since 0.3 *) 75 | 76 | val add_data_to_span : span -> (string * user_data) list -> unit 77 | (** @since Adds data to the current span. 78 | 79 | 0.4 *) 80 | 81 | val add_data_to_manual_span : 82 | explicit_span -> (string * user_data) list -> unit 83 | (** Adds data to the given span. 84 | @since 0.4 *) 85 | 86 | val message : ?span:span -> data:(string * user_data) list -> string -> unit 87 | (** Emit a message with associated metadata. *) 88 | 89 | val name_thread : string -> unit 90 | (** Give a name to the current thread. *) 91 | 92 | val name_process : string -> unit 93 | (** Give a name to the current process. *) 94 | 95 | val counter_int : data:(string * user_data) list -> string -> int -> unit 96 | (** Integer counter. *) 97 | 98 | val counter_float : data:(string * user_data) list -> string -> float -> unit 99 | (** Float counter. *) 100 | 101 | val extension_event : extension_event -> unit 102 | (** Handle an extension event. A collector {b MUST} simple ignore events it 103 | doesn't know, and return [()] silently. 104 | @since 0.8 *) 105 | 106 | val shutdown : unit -> unit 107 | (** Shutdown collector, possibly waiting for it to finish sending data. *) 108 | end 109 | -------------------------------------------------------------------------------- /src/ppx/ppx_trace.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let location_errorf ~loc fmt = 4 | Format.kasprintf 5 | (fun err -> 6 | raise (Ocaml_common.Location.Error (Ocaml_common.Location.error ~loc err))) 7 | fmt 8 | 9 | (** {2 let expression} *) 10 | 11 | let expand_let ~ctxt (var : [ `Var of label loc | `Unit ]) (name : string) body 12 | = 13 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 14 | Ast_builder.Default.( 15 | let var_pat = 16 | match var with 17 | | `Var v -> ppat_var ~loc:v.loc v 18 | | `Unit -> ppat_var ~loc { loc; txt = "_trace_span" } 19 | in 20 | let var_exp = 21 | match var with 22 | | `Var v -> pexp_ident ~loc:v.loc { txt = lident v.txt; loc = v.loc } 23 | | `Unit -> [%expr _trace_span] 24 | in 25 | [%expr 26 | let [%p var_pat] = 27 | Trace_core.enter_span ~__FILE__ ~__LINE__ [%e estring ~loc name] 28 | in 29 | try 30 | let res = [%e body] in 31 | Trace_core.exit_span [%e var_exp]; 32 | res 33 | with exn -> 34 | Trace_core.exit_span [%e var_exp]; 35 | raise exn]) 36 | 37 | let extension_let = 38 | Extension.V3.declare "trace" Extension.Context.expression 39 | (let open! Ast_pattern in 40 | single_expr_payload 41 | (pexp_let nonrecursive 42 | (value_binding ~constraint_:none 43 | ~pat: 44 | (let pat_var = ppat_var __' |> map ~f:(fun f v -> f (`Var v)) in 45 | let pat_unit = 46 | as__ @@ ppat_construct (lident (string "()")) none 47 | |> map ~f:(fun f _ -> f `Unit) 48 | in 49 | alt pat_var pat_unit) 50 | ~expr:(estring __) 51 | ^:: nil) 52 | __)) 53 | expand_let 54 | 55 | let rule_let = Ppxlib.Context_free.Rule.extension extension_let 56 | 57 | (** {2 Toplevel binding} *) 58 | 59 | let expand_top_let ~ctxt rec_flag (vbs : _ list) = 60 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 61 | Ast_builder.Default.( 62 | (* go in functions, and add tracing around the body *) 63 | let rec push_into_fun (e : expression) : expression = 64 | match e.pexp_desc with 65 | | Pexp_function (args, ty, Pfunction_body body) -> 66 | pexp_function ~loc args ty @@ Pfunction_body (push_into_fun body) 67 | | Pexp_function (_args, _ty, Pfunction_cases _) -> 68 | (* explicitly fail on [let%trace foo = function …], for now *) 69 | Ast_helper.Exp.extension 70 | ( { txt = "ocaml.error"; loc }, 71 | PStr 72 | [ 73 | pstr_eval ~loc 74 | (pexp_constant ~loc 75 | (Pconst_string 76 | ( "ppxtrace: cannot trace `function`, please unsugar \ 77 | to `fun`+`match`.", 78 | loc, 79 | None ))) 80 | []; 81 | ] ) 82 | | _ -> 83 | [%expr 84 | let _trace_span = 85 | Trace_core.enter_span ~__FILE__ ~__LINE__ __FUNCTION__ 86 | in 87 | match [%e e] with 88 | | res -> 89 | Trace_core.exit_span _trace_span; 90 | res 91 | | exception exn -> 92 | let bt = Printexc.get_raw_backtrace () in 93 | Trace_core.exit_span _trace_span; 94 | Printexc.raise_with_backtrace exn bt] 95 | in 96 | 97 | let tr_vb (vb : value_binding) : value_binding = 98 | let expr = push_into_fun vb.pvb_expr in 99 | { vb with pvb_expr = expr } 100 | in 101 | 102 | let vbs = List.map tr_vb vbs in 103 | pstr_value ~loc rec_flag vbs) 104 | 105 | let extension_top_let = 106 | Extension.V3.declare "trace" Extension.Context.structure_item 107 | (let open! Ast_pattern in 108 | pstr (pstr_value __ __ ^:: nil)) 109 | expand_top_let 110 | 111 | let rule_top_let = Ppxlib.Context_free.Rule.extension extension_top_let 112 | 113 | let () = 114 | Driver.register_transformation ~rules:[ rule_let; rule_top_let ] "ppx_trace" 115 | -------------------------------------------------------------------------------- /src/tef/trace_tef.ml: -------------------------------------------------------------------------------- 1 | open Trace_core 2 | module Subscriber = Subscriber 3 | module Exporter = Exporter 4 | module Writer = Writer 5 | 6 | let block_signals () = 7 | try 8 | ignore 9 | (Unix.sigprocmask SIG_BLOCK 10 | [ 11 | Sys.sigterm; 12 | Sys.sigpipe; 13 | Sys.sigint; 14 | Sys.sigchld; 15 | Sys.sigalrm; 16 | Sys.sigusr1; 17 | Sys.sigusr2; 18 | ] 19 | : _ list) 20 | with _ -> () 21 | 22 | (** Thread that simply regularly "ticks", sending events to the background 23 | thread so it has a chance to write to the file *) 24 | let tick_thread (sub : Subscriber.t) : unit = 25 | block_signals (); 26 | while Subscriber.active sub do 27 | Thread.delay 0.5; 28 | Subscriber.flush sub 29 | done 30 | 31 | type output = 32 | [ `Stdout 33 | | `Stderr 34 | | `File of string 35 | ] 36 | 37 | let subscriber_ ~finally ~out ~(mode : [ `Single | `Jsonl ]) () : 38 | Trace_subscriber.t = 39 | let jsonl = mode = `Jsonl in 40 | let oc, must_close = 41 | match out with 42 | | `Stdout -> stdout, false 43 | | `Stderr -> stderr, false 44 | | `File path -> open_out path, true 45 | | `File_append path -> 46 | open_out_gen [ Open_creat; Open_wronly; Open_append ] 0o644 path, true 47 | | `Output oc -> oc, false 48 | in 49 | let pid = 50 | if !Trace_subscriber.Private_.mock then 51 | 2 52 | else 53 | Unix.getpid () 54 | in 55 | 56 | let exporter = Exporter.of_out_channel oc ~jsonl ~close_channel:must_close in 57 | let exporter = 58 | { 59 | exporter with 60 | close = 61 | (fun () -> 62 | exporter.close (); 63 | finally ()); 64 | } 65 | in 66 | let sub = Subscriber.create ~pid ~exporter () in 67 | let _t_tick : Thread.t = Thread.create tick_thread sub in 68 | Subscriber.subscriber sub 69 | 70 | let collector_ ~(finally : unit -> unit) ~(mode : [ `Single | `Jsonl ]) ~out () 71 | : collector = 72 | let sub = subscriber_ ~finally ~mode ~out () in 73 | Trace_subscriber.collector sub 74 | 75 | let[@inline] subscriber ~out () : Trace_subscriber.t = 76 | subscriber_ ~finally:ignore ~mode:`Single ~out () 77 | 78 | let[@inline] collector ~out () : collector = 79 | collector_ ~finally:ignore ~mode:`Single ~out () 80 | 81 | open struct 82 | let register_atexit = 83 | let has_registered = ref false in 84 | fun () -> 85 | if not !has_registered then ( 86 | has_registered := true; 87 | at_exit Trace_core.shutdown 88 | ) 89 | end 90 | 91 | let setup ?(out = `Env) () = 92 | register_atexit (); 93 | match out with 94 | | `Stderr -> Trace_core.setup_collector @@ collector ~out:`Stderr () 95 | | `Stdout -> Trace_core.setup_collector @@ collector ~out:`Stdout () 96 | | `File path -> Trace_core.setup_collector @@ collector ~out:(`File path) () 97 | | `Env -> 98 | (match Sys.getenv_opt "TRACE" with 99 | | Some ("1" | "true") -> 100 | let path = "trace.json" in 101 | let c = collector ~out:(`File path) () in 102 | Trace_core.setup_collector c 103 | | Some "stdout" -> Trace_core.setup_collector @@ collector ~out:`Stdout () 104 | | Some "stderr" -> Trace_core.setup_collector @@ collector ~out:`Stderr () 105 | | Some path -> 106 | let c = collector ~out:(`File path) () in 107 | Trace_core.setup_collector c 108 | | None -> ()) 109 | 110 | let with_setup ?out () f = 111 | setup ?out (); 112 | Fun.protect ~finally:Trace_core.shutdown f 113 | 114 | module Mock_ = struct 115 | let now = ref 0 116 | 117 | (* used to mock timing *) 118 | let get_now_ns () : int64 = 119 | let x = !now in 120 | incr now; 121 | Int64.(mul (of_int x) 1000L) 122 | 123 | let get_tid_ () : int = 3 124 | end 125 | 126 | module Private_ = struct 127 | let mock_all_ () = 128 | Trace_subscriber.Private_.mock := true; 129 | Trace_subscriber.Private_.get_now_ns_ := Mock_.get_now_ns; 130 | Trace_subscriber.Private_.get_tid_ := Mock_.get_tid_; 131 | () 132 | 133 | let on_tracing_error = Subscriber.on_tracing_error 134 | 135 | let subscriber_jsonl ~finally ~out () = 136 | subscriber_ ~finally ~mode:`Jsonl ~out () 137 | 138 | let collector_jsonl ~finally ~out () : collector = 139 | collector_ ~finally ~mode:`Jsonl ~out () 140 | 141 | module Event = Event 142 | end 143 | -------------------------------------------------------------------------------- /src/fuchsia/buf_chain.ml: -------------------------------------------------------------------------------- 1 | (** A set of buffers in use, and a set of ready buffers *) 2 | 3 | open Common_ 4 | 5 | (** Buffers in use *) 6 | type buffers = 7 | | B_one of { mutable buf: Buf.t } 8 | | B_many of Buf.t Lock.t array 9 | (** mask(thread id) -> buffer. This reduces contention *) 10 | 11 | type t = { 12 | bufs: buffers; 13 | has_ready: bool A.t; 14 | ready: Buf.t Queue.t Lock.t; 15 | (** Buffers that are full (enough) and must be written *) 16 | buf_pool: Buf_pool.t; 17 | } 18 | (** A set of buffers, some of which are ready to be written *) 19 | 20 | open struct 21 | let shard_log = 4 22 | let shard = 1 lsl shard_log 23 | let shard_mask = shard - 1 24 | end 25 | 26 | (** Create a buffer chain. 27 | 28 | @param sharded 29 | if true, multiple buffers are created, to reduce contention on each buffer 30 | in case of concurrent access. This makes the buf chain thread-safe. If 31 | false, there is only one (unprotected) buffer. *) 32 | let create ~(sharded : bool) ~(buf_pool : Buf_pool.t) () : t = 33 | let bufs = 34 | if sharded then ( 35 | let bufs = 36 | Array.init shard (fun _ -> Lock.create @@ Buf_pool.alloc buf_pool) 37 | in 38 | B_many bufs 39 | ) else 40 | B_one { buf = Buf_pool.alloc buf_pool } 41 | in 42 | { 43 | bufs; 44 | buf_pool; 45 | has_ready = A.make false; 46 | ready = Lock.create @@ Queue.create (); 47 | } 48 | 49 | open struct 50 | let put_in_ready (self : t) buf : unit = 51 | if Buf.size buf > 0 then ( 52 | let@ q = Lock.with_ self.ready in 53 | A.set self.has_ready true; 54 | Queue.push buf q 55 | ) 56 | 57 | let assert_available buf ~available = 58 | if Buf.available buf < available then ( 59 | let msg = 60 | Printf.sprintf 61 | "fuchsia: buffer is too small (available: %d bytes, needed: %d bytes)" 62 | (Buf.available buf) available 63 | in 64 | failwith msg 65 | ) 66 | end 67 | 68 | (** Move all non-empty buffers to [ready] *) 69 | let ready_all_non_empty (self : t) : unit = 70 | let@ q = Lock.with_ self.ready in 71 | match self.bufs with 72 | | B_one r -> 73 | if not (Buf.is_empty r.buf) then ( 74 | Queue.push r.buf q; 75 | A.set self.has_ready true; 76 | r.buf <- Buf.empty 77 | ) 78 | | B_many bufs -> 79 | Array.iter 80 | (fun buf -> 81 | Lock.update buf (fun buf -> 82 | if Buf.size buf > 0 then ( 83 | Queue.push buf q; 84 | A.set self.has_ready true; 85 | Buf.empty 86 | ) else 87 | buf)) 88 | bufs 89 | 90 | let[@inline] has_ready self : bool = A.get self.has_ready 91 | 92 | (** Get access to ready buffers, then clean them up automatically *) 93 | let pop_ready (self : t) ~(f : Buf.t Queue.t -> 'a) : 'a = 94 | let@ q = Lock.with_ self.ready in 95 | let res = f q in 96 | 97 | (* clear queue *) 98 | Queue.iter (Buf_pool.recycle self.buf_pool) q; 99 | Queue.clear q; 100 | A.set self.has_ready false; 101 | res 102 | 103 | (** Maximum size available, in words, for a single message *) 104 | let[@inline] max_size_word (_self : t) : int = fuchsia_buf_size lsr 3 105 | 106 | (** Obtain a buffer with at least [available_word] 64-bit words *) 107 | let with_buf (self : t) ~(available_word : int) (f : Buf.t -> 'a) : 'a = 108 | let available = available_word lsl 3 in 109 | match self.bufs with 110 | | B_one r -> 111 | if Buf.available r.buf < available then ( 112 | put_in_ready self r.buf; 113 | r.buf <- Buf_pool.alloc self.buf_pool 114 | ); 115 | assert_available r.buf ~available; 116 | f r.buf 117 | | B_many bufs -> 118 | let tid = Thread.(id (self ())) in 119 | let masked_tid = tid land shard_mask in 120 | let buf_lock = bufs.(masked_tid) in 121 | let@ buf = Lock.with_ buf_lock in 122 | let buf = 123 | if Buf.available buf < available then ( 124 | put_in_ready self buf; 125 | let new_buf = Buf_pool.alloc self.buf_pool in 126 | assert_available new_buf ~available; 127 | Lock.set_while_locked buf_lock new_buf; 128 | new_buf 129 | ) else 130 | buf 131 | in 132 | f buf 133 | 134 | (** Dispose of resources (here, recycle buffers) *) 135 | let dispose (self : t) : unit = 136 | match self.bufs with 137 | | B_one r -> 138 | Buf_pool.recycle self.buf_pool r.buf; 139 | r.buf <- Buf.empty 140 | | B_many bufs -> 141 | Array.iter 142 | (fun buf_lock -> 143 | let@ buf = Lock.with_ buf_lock in 144 | Buf_pool.recycle self.buf_pool buf; 145 | Lock.set_while_locked buf_lock Buf.empty) 146 | bufs 147 | -------------------------------------------------------------------------------- /src/subscriber/subscriber.ml: -------------------------------------------------------------------------------- 1 | (** Trace subscribers *) 2 | 3 | (** A trace subscriber. It pairs a set of callbacks with the state they need 4 | (which can contain a file handle, a socket to write events to, config, 5 | etc.). 6 | 7 | The design goal for this is that it should be possible to avoid allocations 8 | whenever the trace collector invokes the callbacks. *) 9 | type t = 10 | | Sub : { 11 | st: 'st; 12 | callbacks: 'st Callbacks.t; 13 | } 14 | -> t 15 | 16 | (** Dummy subscriber that ignores every call. *) 17 | let dummy : t = Sub { st = (); callbacks = Callbacks.dummy () } 18 | 19 | open struct 20 | module Tee_cb : Callbacks.S with type st = t array = struct 21 | type nonrec st = t array 22 | 23 | let new_span st = 24 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st 0 in 25 | CB.new_span s 26 | 27 | let new_trace_id st = 28 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st 0 in 29 | CB.new_trace_id s 30 | 31 | let on_init st ~time_ns = 32 | for i = 0 to Array.length st - 1 do 33 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 34 | CB.on_init s ~time_ns 35 | done 36 | 37 | let on_shutdown st ~time_ns = 38 | for i = 0 to Array.length st - 1 do 39 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 40 | CB.on_shutdown s ~time_ns 41 | done 42 | 43 | let on_name_thread st ~time_ns ~tid ~name = 44 | for i = 0 to Array.length st - 1 do 45 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 46 | CB.on_name_thread s ~time_ns ~tid ~name 47 | done 48 | 49 | let on_name_process st ~time_ns ~tid ~name = 50 | for i = 0 to Array.length st - 1 do 51 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 52 | CB.on_name_process s ~time_ns ~tid ~name 53 | done 54 | 55 | let on_enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns ~tid ~data 56 | ~name span = 57 | for i = 0 to Array.length st - 1 do 58 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 59 | CB.on_enter_span s ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns ~tid ~data 60 | ~name span 61 | done 62 | 63 | let on_exit_span st ~time_ns ~tid span = 64 | for i = 0 to Array.length st - 1 do 65 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 66 | CB.on_exit_span s ~time_ns ~tid span 67 | done 68 | 69 | let on_add_data st ~data span = 70 | for i = 0 to Array.length st - 1 do 71 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 72 | CB.on_add_data s ~data span 73 | done 74 | 75 | let on_message st ~time_ns ~tid ~span ~data msg = 76 | for i = 0 to Array.length st - 1 do 77 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 78 | CB.on_message s ~time_ns ~tid ~span ~data msg 79 | done 80 | 81 | let on_counter st ~time_ns ~tid ~data ~name n = 82 | for i = 0 to Array.length st - 1 do 83 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 84 | CB.on_counter s ~time_ns ~tid ~data ~name n 85 | done 86 | 87 | let on_enter_manual_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns ~tid 88 | ~parent ~data ~name ~flavor ~trace_id span = 89 | for i = 0 to Array.length st - 1 do 90 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 91 | CB.on_enter_manual_span s ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns 92 | ~tid ~parent ~data ~name ~flavor ~trace_id span 93 | done 94 | 95 | let on_exit_manual_span st ~time_ns ~tid ~name ~data ~flavor ~trace_id span 96 | = 97 | for i = 0 to Array.length st - 1 do 98 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 99 | CB.on_exit_manual_span s ~time_ns ~tid ~name ~data ~flavor ~trace_id 100 | span 101 | done 102 | 103 | let on_extension_event st ~time_ns ~tid ev : unit = 104 | for i = 0 to Array.length st - 1 do 105 | let (Sub { st = s; callbacks = (module CB) }) = Array.get st i in 106 | CB.on_extension_event s ~time_ns ~tid ev 107 | done 108 | end 109 | end 110 | 111 | (** Tee multiple subscribers, ie return a subscriber that forwards to every 112 | subscriber in [subs]. 113 | 114 | To generate a new span or trace ID, the first subscriber of the list is 115 | used. *) 116 | let tee_l (subs : t list) : t = 117 | match subs with 118 | | [] -> dummy 119 | | [ s ] -> s 120 | | l -> Sub { st = Array.of_list l; callbacks = (module Tee_cb) } 121 | 122 | (** [tee s1 s2] is a subscriber that forwards every call to [s1] and [s2] both. 123 | *) 124 | let tee (s1 : t) (s2 : t) : t = tee_l [ s1; s2 ] 125 | -------------------------------------------------------------------------------- /src/tef-tldrs/trace_tef_tldrs.ml: -------------------------------------------------------------------------------- 1 | open Trace_core 2 | 3 | let spf = Printf.sprintf 4 | let fpf = Printf.fprintf 5 | 6 | type output = [ `File of string ] 7 | 8 | (** Env variable used to communicate to subprocesses, which trace ID to use *) 9 | let env_var_trace_id = "TRACE_TEF_TLDR_TRACE_ID" 10 | 11 | (** Env variable used to communicate to subprocesses, which trace ID to use *) 12 | let env_var_unix_socket = "TRACE_TEF_TLDR_SOCKET" 13 | 14 | let get_unix_socket () = 15 | match Sys.getenv_opt env_var_unix_socket with 16 | | Some s -> s 17 | | None -> 18 | let s = "/tmp/tldrs.socket" in 19 | (* children must agree on the socket file *) 20 | Unix.putenv env_var_unix_socket s; 21 | s 22 | 23 | type as_client = { 24 | trace_id: string; 25 | socket: string; (** Unix socket address *) 26 | emit_tef_at_exit: string option; 27 | (** For parent, ask daemon to emit traces here *) 28 | } 29 | 30 | type role = as_client option 31 | 32 | let to_hex (s : string) : string = 33 | let open String in 34 | let i_to_hex (i : int) = 35 | if i < 10 then 36 | Char.chr (i + Char.code '0') 37 | else 38 | Char.chr (i - 10 + Char.code 'a') 39 | in 40 | 41 | let res = Bytes.create (2 * length s) in 42 | for i = 0 to length s - 1 do 43 | let n = Char.code (get s i) in 44 | Bytes.set res (2 * i) (i_to_hex ((n land 0xf0) lsr 4)); 45 | Bytes.set res ((2 * i) + 1) (i_to_hex (n land 0x0f)) 46 | done; 47 | Bytes.unsafe_to_string res 48 | 49 | let create_trace_id () : string = 50 | let now = Unix.gettimeofday () in 51 | let rand = Random.State.make_self_init () in 52 | 53 | let rand_bytes = Bytes.create 16 in 54 | for i = 0 to Bytes.length rand_bytes - 1 do 55 | Bytes.set rand_bytes i (Random.State.int rand 256 |> Char.chr) 56 | done; 57 | (* convert to hex *) 58 | spf "tr-%d-%s" (int_of_float now) (to_hex @@ Bytes.unsafe_to_string rand_bytes) 59 | 60 | (** Find what this particular process has to do wrt tracing *) 61 | let find_role ~out () : role = 62 | match Sys.getenv_opt env_var_trace_id with 63 | | Some trace_id -> 64 | Some { trace_id; emit_tef_at_exit = None; socket = get_unix_socket () } 65 | | None -> 66 | let write_to_file path = 67 | (* normalize path so the daemon knows what we're talking about *) 68 | let path = 69 | if Filename.is_relative path then 70 | Filename.concat (Unix.getcwd ()) path 71 | else 72 | path 73 | in 74 | let trace_id = create_trace_id () in 75 | Unix.putenv env_var_trace_id trace_id; 76 | { trace_id; emit_tef_at_exit = Some path; socket = get_unix_socket () } 77 | in 78 | 79 | (match out with 80 | | `File path -> Some (write_to_file path) 81 | | `Env -> 82 | (match Sys.getenv_opt "TRACE" with 83 | | Some ("1" | "true") -> Some (write_to_file "trace.json") 84 | | Some path -> Some (write_to_file path) 85 | | None -> None)) 86 | 87 | let subscriber_ (client : as_client) : Trace_subscriber.t = 88 | (* connect to unix socket *) 89 | let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 90 | (try Unix.connect sock (Unix.ADDR_UNIX client.socket) 91 | with exn -> 92 | failwith 93 | @@ spf "Could not open socket to `tldrs` demon at %S: %s" client.socket 94 | (Printexc.to_string exn)); 95 | let out = Unix.out_channel_of_descr sock in 96 | 97 | (* what to do when the collector shuts down *) 98 | let finally () = 99 | (try flush out with _ -> ()); 100 | try Unix.close sock with _ -> () 101 | in 102 | 103 | fpf out "OPEN %s\n%!" client.trace_id; 104 | (* ask the collector to emit the trace in a user-chosen file, perhaps *) 105 | Option.iter 106 | (fun file -> fpf out "EMIT_TEF_AT_EXIT %s\n" file) 107 | client.emit_tef_at_exit; 108 | 109 | Trace_tef.Private_.subscriber_jsonl ~finally ~out:(`Output out) () 110 | 111 | let subscriber ~out () = 112 | let role = find_role ~out () in 113 | match role with 114 | | None -> assert false 115 | | Some c -> subscriber_ c 116 | 117 | let collector ~out () : collector = 118 | let role = find_role ~out () in 119 | match role with 120 | | None -> assert false 121 | | Some c -> subscriber_ c |> Trace_subscriber.collector 122 | 123 | open struct 124 | let register_atexit = 125 | let has_registered = ref false in 126 | fun () -> 127 | if not !has_registered then ( 128 | has_registered := true; 129 | at_exit Trace_core.shutdown 130 | ) 131 | end 132 | 133 | let setup ?(out = `Env) () = 134 | let role = find_role ~out () in 135 | match role with 136 | | None -> () 137 | | Some c -> 138 | register_atexit (); 139 | Trace_core.setup_collector @@ Trace_subscriber.collector @@ subscriber_ c 140 | 141 | let with_setup ?out () f = 142 | setup ?out (); 143 | Fun.protect ~finally:Trace_core.shutdown f 144 | 145 | module Private_ = struct 146 | include Trace_tef.Private_ 147 | end 148 | -------------------------------------------------------------------------------- /src/subscriber/trace_subscriber.ml: -------------------------------------------------------------------------------- 1 | open Trace_core 2 | module Callbacks = Callbacks 3 | module Subscriber = Subscriber 4 | module Span_tbl = Span_tbl 5 | 6 | type t = Subscriber.t 7 | 8 | module Private_ = struct 9 | let mock = ref false 10 | let get_now_ns_ = ref Time_.get_time_ns 11 | let get_tid_ = ref Thread_.get_tid 12 | 13 | (** Now, in nanoseconds *) 14 | let[@inline] now_ns () : int64 = 15 | if !mock then 16 | !get_now_ns_ () 17 | else 18 | Time_.get_time_ns () 19 | 20 | let[@inline] tid_ () : int = 21 | if !mock then 22 | !get_tid_ () 23 | else 24 | Thread_.get_tid () 25 | end 26 | 27 | open struct 28 | module A = Trace_core.Internal_.Atomic_ 29 | 30 | type manual_span_info = { 31 | name: string; 32 | flavor: Trace_core.span_flavor option; 33 | mutable data: (string * Trace_core.user_data) list; 34 | } 35 | 36 | (** Key used to carry some information between begin and end of manual spans, 37 | by way of the meta map *) 38 | let key_manual_info : manual_span_info Meta_map.key = Meta_map.Key.create () 39 | end 40 | 41 | (** A collector that calls the callbacks of subscriber *) 42 | let collector (Sub { st; callbacks = (module CB) } : Subscriber.t) : collector = 43 | let open Private_ in 44 | let module M = struct 45 | let enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : span = 46 | let span = CB.new_span st in 47 | let tid = tid_ () in 48 | let time_ns = now_ns () in 49 | CB.on_enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns ~tid ~data 50 | ~name span; 51 | span 52 | 53 | let exit_span span : unit = 54 | let time_ns = now_ns () in 55 | let tid = tid_ () in 56 | CB.on_exit_span st ~time_ns ~tid span 57 | 58 | let with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f = 59 | let span = enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name in 60 | try 61 | let x = f span in 62 | exit_span span; 63 | x 64 | with exn -> 65 | let bt = Printexc.get_raw_backtrace () in 66 | exit_span span; 67 | Printexc.raise_with_backtrace exn bt 68 | 69 | let add_data_to_span span data = 70 | if data <> [] then CB.on_add_data st ~data span 71 | 72 | let enter_manual_span ~(parent : explicit_span_ctx option) ~flavor 73 | ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : explicit_span = 74 | let span = CB.new_span st in 75 | let tid = tid_ () in 76 | let time_ns = now_ns () in 77 | 78 | (* get the common trace id, or make a new one *) 79 | let trace_id, parent = 80 | match parent with 81 | | Some m -> m.trace_id, Some m.span 82 | | None -> CB.new_trace_id st, None 83 | in 84 | 85 | CB.on_enter_manual_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~parent ~data 86 | ~time_ns ~tid ~name ~flavor ~trace_id span; 87 | let meta = 88 | Meta_map.empty 89 | |> Meta_map.add key_manual_info { name; flavor; data = [] } 90 | in 91 | { span; trace_id; meta } 92 | 93 | let exit_manual_span (es : explicit_span) : unit = 94 | let time_ns = now_ns () in 95 | let tid = tid_ () in 96 | let trace_id = es.trace_id in 97 | let minfo = 98 | match Meta_map.find key_manual_info es.meta with 99 | | None -> assert false 100 | | Some m -> m 101 | in 102 | CB.on_exit_manual_span st ~tid ~time_ns ~data:minfo.data ~name:minfo.name 103 | ~flavor:minfo.flavor ~trace_id es.span 104 | 105 | let add_data_to_manual_span (es : explicit_span) data = 106 | if data <> [] then ( 107 | match Meta_map.find key_manual_info es.meta with 108 | | None -> assert false 109 | | Some m -> m.data <- List.rev_append data m.data 110 | ) 111 | 112 | let message ?span ~data msg : unit = 113 | let time_ns = now_ns () in 114 | let tid = tid_ () in 115 | CB.on_message st ~time_ns ~tid ~span ~data msg 116 | 117 | let counter_float ~data name f : unit = 118 | let time_ns = now_ns () in 119 | let tid = tid_ () in 120 | CB.on_counter st ~tid ~time_ns ~data ~name f 121 | 122 | let[@inline] counter_int ~data name i = 123 | counter_float ~data name (float_of_int i) 124 | 125 | let name_process name : unit = 126 | let tid = tid_ () in 127 | let time_ns = now_ns () in 128 | CB.on_name_process st ~time_ns ~tid ~name 129 | 130 | let name_thread name : unit = 131 | let tid = tid_ () in 132 | let time_ns = now_ns () in 133 | CB.on_name_thread st ~time_ns ~tid ~name 134 | 135 | let shutdown () = 136 | let time_ns = now_ns () in 137 | CB.on_shutdown st ~time_ns 138 | 139 | let extension_event ev = 140 | let tid = tid_ () in 141 | let time_ns = now_ns () in 142 | CB.on_extension_event st ~time_ns ~tid ev 143 | 144 | let () = 145 | (* init code *) 146 | let time_ns = now_ns () in 147 | CB.on_init st ~time_ns 148 | end in 149 | (module M) 150 | 151 | module Span_generator = struct 152 | type t = int A.t 153 | 154 | let create () = A.make 0 155 | let[@inline] mk_span self = A.fetch_and_add self 1 |> Int64.of_int 156 | end 157 | 158 | module Trace_id_8B_generator = struct 159 | type t = int A.t 160 | 161 | let create () = A.make 0 162 | 163 | let[@inline] mk_trace_id (self : t) : trace_id = 164 | let n = A.fetch_and_add self 1 in 165 | let b = Bytes.create 8 in 166 | Bytes.set_int64_le b 0 (Int64.of_int n); 167 | Bytes.unsafe_to_string b 168 | end 169 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Trace 3 | 4 | [![Build and Test](https://github.com/c-cube/ocaml-trace/actions/workflows/main.yml/badge.svg)](https://github.com/c-cube/ocaml-trace/actions/workflows/main.yml) 5 | 6 | This small library provides basic types that can be used to instrument 7 | a library or application, either by hand or via a ppx. 8 | 9 | ## Features 10 | 11 | - [x] spans 12 | - [x] messages 13 | - [x] counters 14 | - [ ] other metrics? 15 | - [x] ppx to help instrumentation 16 | 17 | ## Usage 18 | 19 | To instrument your code, you can simply add `trace` to your dune/opam files, and then 20 | write code like such: 21 | 22 | ```ocaml 23 | let f x = 24 | Trace.with_span ~__FILE__ ~__LINE__ "inside-f" @@ fun _sp -> 25 | (* … code for f *) 26 | 27 | let g x = 28 | Trace.with_span ~__FILE__ ~__LINE__ "inside-g" @@ fun _sp -> 29 | let y = f x in 30 | (* … code for f *) 31 | 32 | let () = 33 | Some_trace_backend.setup () @@ fun () -> 34 | let result = g 42 in 35 | print_result result 36 | ``` 37 | 38 | The file `test/t1.ml` follows this pattern, using `trace-tef` as a simple backend 39 | that emits one JSON object per span/message: 40 | 41 | ```ocaml 42 | let run () = 43 | Trace.set_process_name "main"; 44 | Trace.set_thread_name "t1"; 45 | 46 | let n = ref 0 in 47 | 48 | for _i = 1 to 50 do 49 | Trace.with_span ~__FILE__ ~__LINE__ "outer.loop" @@ fun _sp -> 50 | for _j = 2 to 5 do 51 | incr n; 52 | Trace.with_span ~__FILE__ ~__LINE__ "inner.loop" @@ fun _sp -> 53 | Trace.messagef (fun k -> k "hello %d %d" _i _j); 54 | Trace.message "world"; 55 | Trace.counter_int "n" !n 56 | done 57 | done 58 | 59 | let () = 60 | Trace_tef.with_setup ~out:(`File "trace.json") () @@ fun () -> 61 | run () 62 | ``` 63 | 64 | After running this, the file "trace.json" will contain something like: 65 | ```json 66 | [{"pid":2,"name":"process_name","ph":"M","args": {"name":"main"}}, 67 | {"pid":2,"tid": 3,"name":"thread_name","ph":"M","args": {"name":"t1"}}, 68 | {"pid":2,"cat":"","tid": 3,"ts": 2.00,"name":"hello 1 2","ph":"I"}, 69 | {"pid":2,"cat":"","tid": 3,"ts": 3.00,"name":"world","ph":"I"}, 70 | {"pid":2,"tid":3,"ts":4.00,"name":"c","ph":"C","args": {"n":1}}, 71 | … 72 | ``` 73 | 74 | Opening it in https://ui.perfetto.dev we get something like this: 75 | 76 | ![screenshot of perfetto UI](media/ui.png) 77 | 78 | ## ppx_trace 79 | 80 | On OCaml >= 4.12, and with `ppxlib` installed, you can install `ppx_trace`. 81 | This is a preprocessor that will rewrite like so: 82 | 83 | ```ocaml 84 | let%trace f x y z = 85 | do_sth x; 86 | do_sth y; 87 | begin 88 | let%trace () = "sub-span" in 89 | do_sth z 90 | end 91 | ``` 92 | 93 | This more or less corresponds to: 94 | 95 | ```ocaml 96 | let f x y z = 97 | let _trace_span = Trace_core.enter_span ~__FILE__ ~__LINE__ "Foo.f" in 98 | match 99 | do_sth x; 100 | do_sth y; 101 | begin 102 | let _trace_span = Trace_core.enter_span ~__FILE__ ~__LINE__ "sub-span" in 103 | match do_sth z with 104 | | res -> 105 | Trace_core.exit_span _trace_span; 106 | res 107 | | exception e -> 108 | Trace_core.exit_span _trace_span 109 | raise e 110 | end; 111 | with 112 | | res -> 113 | Trace_core.exit_span _trace_span 114 | res 115 | | exception e -> 116 | Trace_core.exit_span _trace_span 117 | raise e 118 | ``` 119 | 120 | Alternatively, a name can be provided for the span, which is useful if you want 121 | to access it and use functions like `Trace.add_data_to_span`: 122 | 123 | 124 | ```ocaml 125 | let%trace f x y z = 126 | do_sth x; 127 | do_sth y; 128 | begin 129 | let%trace _sp = "sub-span" in 130 | do_sth z; 131 | Trace.add_data_to_span _sp ["x", `Int 42] 132 | end 133 | ``` 134 | 135 | ### Dune configuration 136 | 137 | In your `library` or `executable` stanza, add: `(preprocess (pps ppx_trace))`. 138 | The dependency on `trace.core` is automatically added. You still need to 139 | configure a backend to actually do collection. 140 | 141 | ## Backends 142 | 143 | Concrete tracing or observability formats such as: 144 | 145 | - [x] Fuchsia (see [the spec](https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format) and [tracing](https://github.com/janestreet/tracing). 146 | Can be opened in https://ui.perfetto.dev) 147 | - Catapult 148 | * [x] light bindings here with `trace-tef`. 149 | (Can be opened in https://ui.perfetto.dev) 150 | * [x] backend for [tldrs](https://github.com/imandra-ai/tldrs), a 151 | small rust daemon that aggregates TEF traces from multiple processes/clients 152 | into a single `.jsonl` file 153 | * [x] [tldrs](https://github.com/imandra-ai/tldrs), to collect TEF traces from multiple processes in a clean way. 154 | This requires the rust `tldrs` program to be in path. 155 | * ~~[ ] richer bindings with [ocaml-catapult](https://github.com/imandra-ai/catapult), 156 | with multi-process backends, etc.~~ (subsumed by tldrs) 157 | - [x] Tracy (see [ocaml-tracy](https://github.com/imandra-ai/ocaml-tracy), more specifically `tracy-client.trace`) 158 | - [x] Opentelemetry (see [ocaml-opentelemetry](https://github.com/imandra-ai/ocaml-opentelemetry/), in `opentelemetry.trace`) 159 | - [ ] landmarks? 160 | - [ ] Logs (only for messages, obviously) 161 | 162 | ## Subscribers 163 | 164 | The library `trace.subscriber` defines composable _subscribers_, which are sets of callbacks 165 | that consume tracing events. 166 | Multiple subscribers can be aggregated together (with events being dispatched to all of them) 167 | and be installed as a normal _collector_. 168 | -------------------------------------------------------------------------------- /src/subscriber/callbacks.ml: -------------------------------------------------------------------------------- 1 | (** Callbacks used for subscribers. 2 | 3 | Each subscriber defines a set of callbacks, for each possible tracing event. 4 | These callbacks take a custom state that is paired with the callbacks in 5 | {!Subscriber.t}. 6 | 7 | To use a default implementation for some callbacks, use: 8 | 9 | {[ 10 | module My_callbacks = struct 11 | type st = … 12 | 13 | include Trace_subscriber.Callbacks.Dummy 14 | 15 | let on_init (state:st) ~time_ns : unit = … 16 | 17 | (* … other custom callbacks … *) 18 | end 19 | ]} 20 | 21 | {b NOTE}: the [trace_id] passed alongside manual spans is guaranteed to be 22 | at least 64 bits. *) 23 | 24 | open Trace_core 25 | 26 | (** First class module signature for callbacks *) 27 | module type S = sig 28 | type st 29 | (** Type of the state passed to every callback. *) 30 | 31 | val on_init : st -> time_ns:int64 -> unit 32 | (** Called when the subscriber is initialized in a collector *) 33 | 34 | val new_span : st -> span 35 | (** How to generate a new span? 36 | @since NEXT_RELEASE *) 37 | 38 | val new_trace_id : st -> trace_id 39 | (** How to generate a new trace ID? 40 | @since NEXT_RELEASE *) 41 | 42 | val on_shutdown : st -> time_ns:int64 -> unit 43 | (** Called when the collector is shutdown *) 44 | 45 | val on_name_thread : st -> time_ns:int64 -> tid:int -> name:string -> unit 46 | (** Current thread is being named *) 47 | 48 | val on_name_process : st -> time_ns:int64 -> tid:int -> name:string -> unit 49 | (** Current process is being named *) 50 | 51 | val on_enter_span : 52 | st -> 53 | __FUNCTION__:string option -> 54 | __FILE__:string -> 55 | __LINE__:int -> 56 | time_ns:int64 -> 57 | tid:int -> 58 | data:(string * Trace_core.user_data) list -> 59 | name:string -> 60 | span -> 61 | unit 62 | (** Enter a regular (sync) span *) 63 | 64 | val on_exit_span : st -> time_ns:int64 -> tid:int -> span -> unit 65 | (** Exit a span. This and [on_enter_span] must follow strict stack discipline 66 | *) 67 | 68 | val on_add_data : 69 | st -> data:(string * Trace_core.user_data) list -> span -> unit 70 | (** Add data to a regular span (which must be active) *) 71 | 72 | val on_message : 73 | st -> 74 | time_ns:int64 -> 75 | tid:int -> 76 | span:span option -> 77 | data:(string * Trace_core.user_data) list -> 78 | string -> 79 | unit 80 | (** Emit a log message *) 81 | 82 | val on_counter : 83 | st -> 84 | time_ns:int64 -> 85 | tid:int -> 86 | data:(string * Trace_core.user_data) list -> 87 | name:string -> 88 | float -> 89 | unit 90 | (** Emit the current value of a counter *) 91 | 92 | val on_enter_manual_span : 93 | st -> 94 | __FUNCTION__:string option -> 95 | __FILE__:string -> 96 | __LINE__:int -> 97 | time_ns:int64 -> 98 | tid:int -> 99 | parent:span option -> 100 | data:(string * Trace_core.user_data) list -> 101 | name:string -> 102 | flavor:Trace_core.span_flavor option -> 103 | trace_id:trace_id -> 104 | span -> 105 | unit 106 | (** Enter a manual (possibly async) span *) 107 | 108 | val on_exit_manual_span : 109 | st -> 110 | time_ns:int64 -> 111 | tid:int -> 112 | name:string -> 113 | data:(string * Trace_core.user_data) list -> 114 | flavor:Trace_core.span_flavor option -> 115 | trace_id:trace_id -> 116 | span -> 117 | unit 118 | (** Exit a manual span *) 119 | 120 | val on_extension_event : 121 | st -> time_ns:int64 -> tid:int -> extension_event -> unit 122 | (** Extension event 123 | @since 0.8 *) 124 | end 125 | 126 | type 'st t = (module S with type st = 'st) 127 | (** Callbacks for a subscriber. There is one callback per event in {!Trace}. The 128 | type ['st] is the state that is passed to every single callback. *) 129 | 130 | (** Dummy callbacks. It can be useful to reuse some of these functions in a real 131 | subscriber that doesn't want to handle {b all} events, but only some of 132 | them. 133 | 134 | To write a subscriber that only supports some callbacks, this can be handy: 135 | {[ 136 | module My_callbacks = struct 137 | type st = my_own_state 138 | include Callbacks.Dummy 139 | let on_counter (st:st) ~time_ns ~tid ~data ~name v : unit = ... 140 | end 141 | ]} *) 142 | module Dummy = struct 143 | let on_init _ ~time_ns:_ = () 144 | let new_span _ = Collector.dummy_span 145 | let new_trace_id _ = Collector.dummy_trace_id 146 | let on_shutdown _ ~time_ns:_ = () 147 | let on_name_thread _ ~time_ns:_ ~tid:_ ~name:_ = () 148 | let on_name_process _ ~time_ns:_ ~tid:_ ~name:_ = () 149 | let on_message _ ~time_ns:_ ~tid:_ ~span:_ ~data:_ _msg = () 150 | let on_counter _ ~time_ns:_ ~tid:_ ~data:_ ~name:_ _v = () 151 | 152 | let on_enter_span _ ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~time_ns:_ ~tid:_ 153 | ~data:_ ~name:_ _sp = 154 | () 155 | 156 | let on_exit_span _ ~time_ns:_ ~tid:_ _ = () 157 | let on_add_data _ ~data:_ _sp = () 158 | 159 | let on_enter_manual_span _ ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~time_ns:_ 160 | ~tid:_ ~parent:_ ~data:_ ~name:_ ~flavor:_ ~trace_id:_ _sp = 161 | () 162 | 163 | let on_exit_manual_span _ ~time_ns:_ ~tid:_ ~name:_ ~data:_ ~flavor:_ 164 | ~trace_id:_ _ = 165 | () 166 | 167 | let on_extension_event _ ~time_ns:_ ~tid:_ _ = () 168 | end 169 | 170 | (** Dummy callbacks, ignores all events. *) 171 | let dummy (type st) () : st t = 172 | let module M = struct 173 | type nonrec st = st 174 | 175 | include Dummy 176 | end in 177 | (module M) 178 | -------------------------------------------------------------------------------- /src/core/trace_core.ml: -------------------------------------------------------------------------------- 1 | include Types 2 | module A = Atomic_ 3 | module Collector = Collector 4 | module Meta_map = Meta_map 5 | module Level = Level 6 | 7 | type collector = (module Collector.S) 8 | 9 | (* ## globals ## *) 10 | 11 | (** Global collector. *) 12 | let collector : collector option A.t = A.make None 13 | 14 | (* default level for spans without a level *) 15 | let default_level_ = A.make Level.Trace 16 | let current_level_ = A.make Level.Trace 17 | 18 | (* ## implementation ## *) 19 | 20 | let[@inline] ctx_of_span (sp : explicit_span) : explicit_span_ctx = 21 | { span = sp.span; trace_id = sp.trace_id } 22 | 23 | let data_empty_build_ () = [] 24 | 25 | let[@inline] enabled () = 26 | match A.get collector with 27 | | None -> false 28 | | Some _ -> true 29 | 30 | let[@inline] get_default_level () = A.get default_level_ 31 | let[@inline] set_default_level l = A.set default_level_ l 32 | let[@inline] set_current_level l = A.set current_level_ l 33 | let[@inline] get_current_level () = A.get current_level_ 34 | 35 | let[@inline] check_level ?(level = A.get default_level_) () : bool = 36 | Level.leq level (A.get current_level_) 37 | 38 | let with_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__ 39 | ~__LINE__ ?(data = data_empty_build_) name f = 40 | let data = data () in 41 | C.with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f 42 | 43 | let[@inline] with_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f = 44 | match A.get collector with 45 | | Some collector when check_level ?level () -> 46 | with_span_collector_ collector ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name 47 | f 48 | | _ -> 49 | (* fast path: no collector, no span *) 50 | f Collector.dummy_span 51 | 52 | let[@inline] enter_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ 53 | ?(data = data_empty_build_) name : span = 54 | match A.get collector with 55 | | Some (module C) when check_level ?level () -> 56 | let data = data () in 57 | C.enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name 58 | | _ -> Collector.dummy_span 59 | 60 | let[@inline] exit_span sp : unit = 61 | match A.get collector with 62 | | None -> () 63 | | Some (module C) -> C.exit_span sp 64 | 65 | let enter_manual_span_collector_ (module C : Collector.S) ~parent ~flavor 66 | ?__FUNCTION__ ~__FILE__ ~__LINE__ ?(data = data_empty_build_) name : 67 | explicit_span = 68 | let data = data () in 69 | C.enter_manual_span ~parent ~flavor ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data 70 | name 71 | 72 | let[@inline] enter_manual_span ~parent ?flavor ?level ?__FUNCTION__ ~__FILE__ 73 | ~__LINE__ ?data name : explicit_span = 74 | match A.get collector with 75 | | Some coll when check_level ?level () -> 76 | enter_manual_span_collector_ coll ~parent ~flavor ?__FUNCTION__ ~__FILE__ 77 | ~__LINE__ ?data name 78 | | _ -> Collector.dummy_explicit_span 79 | 80 | let[@inline] enter_manual_toplevel_span ?flavor ?level ?__FUNCTION__ ~__FILE__ 81 | ~__LINE__ ?data name : explicit_span = 82 | enter_manual_span ~parent:None ?flavor ?level ?__FUNCTION__ ~__FILE__ 83 | ~__LINE__ ?data name 84 | 85 | let[@inline] enter_manual_sub_span ~parent ?flavor ?level ?__FUNCTION__ 86 | ~__FILE__ ~__LINE__ ?data name : explicit_span = 87 | enter_manual_span 88 | ~parent:(Some (ctx_of_span parent)) 89 | ?flavor ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name 90 | 91 | let[@inline] exit_manual_span espan : unit = 92 | if espan != Collector.dummy_explicit_span then ( 93 | match A.get collector with 94 | | None -> () 95 | | Some (module C) -> C.exit_manual_span espan 96 | ) 97 | 98 | let[@inline] add_data_to_span sp data : unit = 99 | if sp != Collector.dummy_span && data <> [] then ( 100 | match A.get collector with 101 | | None -> () 102 | | Some (module C) -> C.add_data_to_span sp data 103 | ) 104 | 105 | let[@inline] add_data_to_manual_span esp data : unit = 106 | if esp != Collector.dummy_explicit_span && data <> [] then ( 107 | match A.get collector with 108 | | None -> () 109 | | Some (module C) -> C.add_data_to_manual_span esp data 110 | ) 111 | 112 | let message_collector_ (module C : Collector.S) ?span 113 | ?(data = data_empty_build_) msg : unit = 114 | let data = data () in 115 | C.message ?span ~data msg 116 | 117 | let[@inline] message ?level ?span ?data msg : unit = 118 | match A.get collector with 119 | | Some coll when check_level ?level () -> 120 | message_collector_ coll ?span ?data msg 121 | | _ -> () 122 | 123 | let messagef ?level ?span ?data k = 124 | match A.get collector with 125 | | Some (module C) when check_level ?level () -> 126 | k (fun fmt -> 127 | Format.kasprintf 128 | (fun str -> 129 | let data = 130 | match data with 131 | | None -> [] 132 | | Some f -> f () 133 | in 134 | C.message ?span ~data str) 135 | fmt) 136 | | _ -> () 137 | 138 | let counter_int ?level ?(data = data_empty_build_) name n : unit = 139 | match A.get collector with 140 | | Some (module C) when check_level ?level () -> 141 | let data = data () in 142 | C.counter_int ~data name n 143 | | _ -> () 144 | 145 | let counter_float ?level ?(data = data_empty_build_) name f : unit = 146 | match A.get collector with 147 | | Some (module C) when check_level ?level () -> 148 | let data = data () in 149 | C.counter_float ~data name f 150 | | _ -> () 151 | 152 | let set_thread_name name : unit = 153 | match A.get collector with 154 | | None -> () 155 | | Some (module C) -> C.name_thread name 156 | 157 | let set_process_name name : unit = 158 | match A.get collector with 159 | | None -> () 160 | | Some (module C) -> C.name_process name 161 | 162 | let setup_collector c : unit = 163 | while 164 | let cur = A.get collector in 165 | match cur with 166 | | Some _ -> invalid_arg "trace: collector already present" 167 | | None -> not (A.compare_and_set collector cur (Some c)) 168 | do 169 | () 170 | done 171 | 172 | let shutdown () = 173 | match A.exchange collector None with 174 | | None -> () 175 | | Some (module C) -> C.shutdown () 176 | 177 | type extension_event = Types.extension_event = .. 178 | 179 | let[@inline] extension_event ev = 180 | match A.get collector with 181 | | None -> () 182 | | Some (module C) -> C.extension_event ev 183 | 184 | module Internal_ = struct 185 | module Atomic_ = Atomic_ 186 | end 187 | -------------------------------------------------------------------------------- /src/tef/subscriber.ml: -------------------------------------------------------------------------------- 1 | open Common_ 2 | open Trace_core 3 | open Trace_private_util 4 | module Span_tbl = Sub.Span_tbl 5 | 6 | module Buf_pool = struct 7 | type t = Buffer.t Rpool.t 8 | 9 | let create ?(max_size = 32) ?(buf_size = 256) () : t = 10 | Rpool.create ~max_size ~clear:Buffer.reset 11 | ~create:(fun () -> Buffer.create buf_size) 12 | () 13 | end 14 | 15 | open struct 16 | let[@inline] time_us_of_time_ns (t : int64) : float = 17 | Int64.div t 1_000L |> Int64.to_float 18 | 19 | let[@inline] int64_of_trace_id_ (id : Trace_core.trace_id) : int64 = 20 | if id == Trace_core.Collector.dummy_trace_id then 21 | 0L 22 | else 23 | Bytes.get_int64_le (Bytes.unsafe_of_string id) 0 24 | end 25 | 26 | let on_tracing_error = ref (fun s -> Printf.eprintf "%s\n%!" s) 27 | 28 | type span_info = { 29 | tid: int; 30 | name: string; 31 | start_us: float; 32 | mutable data: (string * user_data) list; 33 | (* NOTE: thread safety: this is supposed to only be modified by the thread 34 | that's running this (synchronous, stack-abiding) span. *) 35 | } 36 | (** Information we store about a span begin event, to emit a complete event when 37 | we meet the corresponding span end event *) 38 | 39 | type t = { 40 | active: bool A.t; 41 | pid: int; 42 | spans: span_info Span_tbl.t; 43 | buf_pool: Buf_pool.t; 44 | exporter: Exporter.t; 45 | span_gen: Sub.Span_generator.t; 46 | trace_id_gen: Sub.Trace_id_8B_generator.t; 47 | } 48 | (** Subscriber state *) 49 | 50 | open struct 51 | let print_non_closed_spans_warning spans = 52 | let module Str_set = Set.Make (String) in 53 | let spans = Span_tbl.to_list spans in 54 | if spans <> [] then ( 55 | !on_tracing_error 56 | @@ Printf.sprintf "trace-tef: warning: %d spans were not closed" 57 | (List.length spans); 58 | let names = 59 | List.fold_left 60 | (fun set (_, span) -> Str_set.add span.name set) 61 | Str_set.empty spans 62 | in 63 | Str_set.iter 64 | (fun name -> 65 | !on_tracing_error @@ Printf.sprintf " span %S was not closed" name) 66 | names; 67 | flush stderr 68 | ) 69 | end 70 | 71 | let close (self : t) : unit = 72 | if A.exchange self.active false then ( 73 | print_non_closed_spans_warning self.spans; 74 | self.exporter.close () 75 | ) 76 | 77 | let[@inline] active self = A.get self.active 78 | let[@inline] flush (self : t) : unit = self.exporter.flush () 79 | 80 | let create ?(buf_pool = Buf_pool.create ()) ~pid ~exporter () : t = 81 | { 82 | active = A.make true; 83 | exporter; 84 | buf_pool; 85 | pid; 86 | spans = Span_tbl.create (); 87 | span_gen = Sub.Span_generator.create (); 88 | trace_id_gen = Sub.Trace_id_8B_generator.create (); 89 | } 90 | 91 | module Callbacks = struct 92 | type st = t 93 | 94 | let new_span (self : st) = Sub.Span_generator.mk_span self.span_gen 95 | 96 | let new_trace_id self = 97 | Sub.Trace_id_8B_generator.mk_trace_id self.trace_id_gen 98 | 99 | let on_init _ ~time_ns:_ = () 100 | let on_shutdown (self : st) ~time_ns:_ = close self 101 | 102 | let on_name_process (self : st) ~time_ns:_ ~tid:_ ~name : unit = 103 | let@ buf = Rpool.with_ self.buf_pool in 104 | Writer.emit_name_process ~pid:self.pid ~name buf; 105 | self.exporter.on_json buf 106 | 107 | let on_name_thread (self : st) ~time_ns:_ ~tid ~name : unit = 108 | let@ buf = Rpool.with_ self.buf_pool in 109 | Writer.emit_name_thread buf ~pid:self.pid ~tid ~name; 110 | self.exporter.on_json buf 111 | 112 | (* add function name, if provided, to the metadata *) 113 | let add_fun_name_ fun_name data : _ list = 114 | match fun_name with 115 | | None -> data 116 | | Some f -> ("function", `String f) :: data 117 | 118 | let[@inline] on_enter_span (self : st) ~__FUNCTION__:fun_name ~__FILE__:_ 119 | ~__LINE__:_ ~time_ns ~tid ~data ~name span : unit = 120 | let time_us = time_us_of_time_ns @@ time_ns in 121 | let data = add_fun_name_ fun_name data in 122 | let info = { tid; name; start_us = time_us; data } in 123 | (* save the span so we find it at exit *) 124 | Span_tbl.add self.spans span info 125 | 126 | let on_exit_span (self : st) ~time_ns ~tid:_ span : unit = 127 | let time_us = time_us_of_time_ns @@ time_ns in 128 | 129 | match Span_tbl.find_exn self.spans span with 130 | | exception Not_found -> 131 | !on_tracing_error 132 | (Printf.sprintf "trace-tef: error: cannot find span %Ld" span) 133 | | { tid; name; start_us; data } -> 134 | Span_tbl.remove self.spans span; 135 | let@ buf = Rpool.with_ self.buf_pool in 136 | Writer.emit_duration_event buf ~pid:self.pid ~tid ~name ~start:start_us 137 | ~end_:time_us ~args:data; 138 | 139 | self.exporter.on_json buf 140 | 141 | let on_add_data (self : st) ~data span = 142 | if data <> [] then ( 143 | try 144 | let info = Span_tbl.find_exn self.spans span in 145 | info.data <- List.rev_append data info.data 146 | with Not_found -> 147 | !on_tracing_error 148 | (Printf.sprintf "trace-tef: error: cannot find span %Ld" span) 149 | ) 150 | 151 | let on_message (self : st) ~time_ns ~tid ~span:_ ~data msg : unit = 152 | let time_us = time_us_of_time_ns @@ time_ns in 153 | let@ buf = Rpool.with_ self.buf_pool in 154 | Writer.emit_instant_event buf ~pid:self.pid ~tid ~name:msg ~ts:time_us 155 | ~args:data; 156 | self.exporter.on_json buf 157 | 158 | let on_counter (self : st) ~time_ns ~tid ~data:_ ~name n : unit = 159 | let time_us = time_us_of_time_ns @@ time_ns in 160 | let@ buf = Rpool.with_ self.buf_pool in 161 | Writer.emit_counter buf ~pid:self.pid ~name ~tid ~ts:time_us n; 162 | self.exporter.on_json buf 163 | 164 | let on_enter_manual_span (self : st) ~__FUNCTION__:fun_name ~__FILE__:_ 165 | ~__LINE__:_ ~time_ns ~tid ~parent:_ ~data ~name ~flavor ~trace_id _span : 166 | unit = 167 | let time_us = time_us_of_time_ns @@ time_ns in 168 | 169 | let data = add_fun_name_ fun_name data in 170 | let@ buf = Rpool.with_ self.buf_pool in 171 | Writer.emit_manual_begin buf ~pid:self.pid ~tid ~name 172 | ~id:(int64_of_trace_id_ trace_id) 173 | ~ts:time_us ~args:data ~flavor; 174 | self.exporter.on_json buf 175 | 176 | let on_exit_manual_span (self : st) ~time_ns ~tid ~name ~data ~flavor 177 | ~trace_id (_ : span) : unit = 178 | let time_us = time_us_of_time_ns @@ time_ns in 179 | 180 | let@ buf = Rpool.with_ self.buf_pool in 181 | Writer.emit_manual_end buf ~pid:self.pid ~tid ~name 182 | ~id:(int64_of_trace_id_ trace_id) 183 | ~ts:time_us ~flavor ~args:data; 184 | self.exporter.on_json buf 185 | 186 | let on_extension_event _ ~time_ns:_ ~tid:_ _ev = () 187 | end 188 | 189 | let subscriber (self : t) : Sub.t = 190 | Sub.Subscriber.Sub { st = self; callbacks = (module Callbacks) } 191 | -------------------------------------------------------------------------------- /src/fuchsia/subscriber.ml: -------------------------------------------------------------------------------- 1 | open Common_ 2 | open Trace_core 3 | module Span_tbl = Trace_subscriber.Span_tbl 4 | 5 | let on_tracing_error = on_tracing_error 6 | 7 | type span_info = { 8 | tid: int; 9 | name: string; 10 | start_ns: int64; 11 | mutable data: (string * user_data) list; 12 | (* NOTE: thread safety: this is supposed to only be modified by the thread 13 | that's running this (synchronous, stack-abiding) span. *) 14 | } 15 | (** Information we store about a span begin event, to emit a complete event when 16 | we meet the corresponding span end event *) 17 | 18 | type t = { 19 | active: bool A.t; 20 | pid: int; 21 | spans: span_info Span_tbl.t; 22 | buf_chain: Buf_chain.t; 23 | exporter: Exporter.t; 24 | span_gen: Sub.Span_generator.t; 25 | trace_id_gen: Sub.Trace_id_8B_generator.t; 26 | } 27 | (** Subscriber state *) 28 | 29 | open struct 30 | (** Write the buffers that are ready *) 31 | let[@inline] write_ready_ (self : t) = 32 | if Buf_chain.has_ready self.buf_chain then 33 | Buf_chain.pop_ready self.buf_chain ~f:self.exporter.write_bufs 34 | 35 | let print_non_closed_spans_warning spans = 36 | let module Str_set = Set.Make (String) in 37 | let spans = Span_tbl.to_list spans in 38 | if spans <> [] then ( 39 | !on_tracing_error 40 | @@ Printf.sprintf "warning: %d spans were not closed" (List.length spans); 41 | let names = 42 | List.fold_left 43 | (fun set (_, span) -> Str_set.add span.name set) 44 | Str_set.empty spans 45 | in 46 | Str_set.iter 47 | (fun name -> 48 | !on_tracing_error @@ Printf.sprintf " span %S was not closed" name) 49 | names; 50 | flush stderr 51 | ) 52 | end 53 | 54 | let close (self : t) : unit = 55 | if A.exchange self.active false then ( 56 | Buf_chain.ready_all_non_empty self.buf_chain; 57 | write_ready_ self; 58 | self.exporter.close (); 59 | 60 | print_non_closed_spans_warning self.spans 61 | ) 62 | 63 | let[@inline] active self = A.get self.active 64 | 65 | let flush (self : t) : unit = 66 | Buf_chain.ready_all_non_empty self.buf_chain; 67 | write_ready_ self; 68 | self.exporter.flush () 69 | 70 | let create ?(buf_pool = Buf_pool.create ()) ~pid ~exporter () : t = 71 | let buf_chain = Buf_chain.create ~sharded:true ~buf_pool () in 72 | { 73 | active = A.make true; 74 | buf_chain; 75 | exporter; 76 | pid; 77 | spans = Span_tbl.create (); 78 | span_gen = Sub.Span_generator.create (); 79 | trace_id_gen = Sub.Trace_id_8B_generator.create (); 80 | } 81 | 82 | module Callbacks = struct 83 | type st = t 84 | 85 | let new_span (self : st) = Sub.Span_generator.mk_span self.span_gen 86 | 87 | let new_trace_id self = 88 | Sub.Trace_id_8B_generator.mk_trace_id self.trace_id_gen 89 | 90 | let on_init (self : st) ~time_ns:_ = 91 | Writer.Metadata.Magic_record.encode self.buf_chain; 92 | Writer.Metadata.Initialization_record.( 93 | encode self.buf_chain ~ticks_per_secs:default_ticks_per_sec ()); 94 | Writer.Metadata.Provider_info.encode self.buf_chain ~id:0 95 | ~name:"ocaml-trace" (); 96 | (* make sure we write these immediately so they're not out of order *) 97 | Buf_chain.ready_all_non_empty self.buf_chain; 98 | 99 | write_ready_ self 100 | 101 | let on_shutdown (self : st) ~time_ns:_ = close self 102 | 103 | let on_name_process (self : st) ~time_ns:_ ~tid:_ ~name : unit = 104 | Writer.Kernel_object.( 105 | encode self.buf_chain ~name ~ty:ty_process ~kid:self.pid ~args:[] ()); 106 | write_ready_ self 107 | 108 | let on_name_thread (self : st) ~time_ns:_ ~tid ~name : unit = 109 | Writer.Kernel_object.( 110 | encode self.buf_chain ~name ~ty:ty_thread ~kid:tid 111 | ~args:[ "process", A_kid (Int64.of_int self.pid) ] 112 | ()); 113 | write_ready_ self 114 | 115 | (* add function name, if provided, to the metadata *) 116 | let add_fun_name_ fun_name data : _ list = 117 | match fun_name with 118 | | None -> data 119 | | Some f -> ("function", `String f) :: data 120 | 121 | let[@inline] on_enter_span (self : st) ~__FUNCTION__:fun_name ~__FILE__:_ 122 | ~__LINE__:_ ~time_ns ~tid ~data ~name span : unit = 123 | let data = add_fun_name_ fun_name data in 124 | let info = { tid; name; start_ns = time_ns; data } in 125 | (* save the span so we find it at exit *) 126 | Span_tbl.add self.spans span info 127 | 128 | let on_exit_span (self : st) ~time_ns ~tid:_ span : unit = 129 | match Span_tbl.find_exn self.spans span with 130 | | exception Not_found -> 131 | !on_tracing_error (Printf.sprintf "cannot find span %Ld" span) 132 | | { tid; name; start_ns; data } -> 133 | Span_tbl.remove self.spans span; 134 | Writer.( 135 | Event.Duration_complete.encode self.buf_chain ~name 136 | ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid) 137 | ~time_ns:start_ns ~end_time_ns:time_ns ~args:(args_of_user_data data) 138 | ()); 139 | write_ready_ self 140 | 141 | let on_add_data (self : st) ~data span = 142 | if data <> [] then ( 143 | try 144 | let info = Span_tbl.find_exn self.spans span in 145 | info.data <- List.rev_append data info.data 146 | with Not_found -> 147 | !on_tracing_error (Printf.sprintf "cannot find span %Ld" span) 148 | ) 149 | 150 | let on_message (self : st) ~time_ns ~tid ~span:_ ~data msg : unit = 151 | Writer.( 152 | Event.Instant.encode self.buf_chain 153 | ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid) 154 | ~name:msg ~time_ns ~args:(args_of_user_data data) ()); 155 | write_ready_ self 156 | 157 | let on_counter (self : st) ~time_ns ~tid ~data ~name n : unit = 158 | Writer.( 159 | Event.Counter.encode self.buf_chain 160 | ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid) 161 | ~name ~time_ns 162 | ~args:((name, A_float n) :: args_of_user_data data) 163 | ()); 164 | write_ready_ self 165 | 166 | let on_enter_manual_span (self : st) ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ 167 | ~time_ns ~tid ~parent:_ ~data ~name ~flavor:_ ~trace_id _span : unit = 168 | Writer.( 169 | Event.Async_begin.encode self.buf_chain ~name 170 | ~args:(args_of_user_data data) 171 | ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid) 172 | ~time_ns ~async_id:trace_id ()); 173 | write_ready_ self 174 | 175 | let on_exit_manual_span (self : st) ~time_ns ~tid ~name ~data ~flavor:_ 176 | ~trace_id (_ : span) : unit = 177 | Writer.( 178 | Event.Async_end.encode self.buf_chain ~name ~args:(args_of_user_data data) 179 | ~t_ref:(Thread_ref.inline ~pid:self.pid ~tid) 180 | ~time_ns ~async_id:trace_id ()); 181 | write_ready_ self 182 | 183 | let on_extension_event _ ~time_ns:_ ~tid:_ _ev = () 184 | end 185 | 186 | let subscriber (self : t) : Sub.t = 187 | Sub.Subscriber.Sub { st = self; callbacks = (module Callbacks) } 188 | -------------------------------------------------------------------------------- /src/core/trace_core.mli: -------------------------------------------------------------------------------- 1 | (** Trace. *) 2 | 3 | include module type of Types 4 | module Collector = Collector 5 | module Meta_map = Meta_map 6 | module Level = Level 7 | 8 | (**/**) 9 | 10 | (* no guarantee of stability *) 11 | module Internal_ : sig 12 | module Atomic_ = Atomic_ 13 | end 14 | 15 | (**/**) 16 | 17 | (** {2 Tracing} *) 18 | 19 | val enabled : unit -> bool 20 | (** Is there a collector? 21 | 22 | This is fast, so that the traced program can check it before creating any 23 | span or message. *) 24 | 25 | val get_default_level : unit -> Level.t 26 | (** Current default level for spans. 27 | @since 0.7 *) 28 | 29 | val set_default_level : Level.t -> unit 30 | (** Set level used for spans that do not specify it. The default default value 31 | is [Level.Trace]. 32 | @since 0.7 *) 33 | 34 | val ctx_of_span : explicit_span -> explicit_span_ctx 35 | (** Turn a span into a span context. 36 | @since 0.10 *) 37 | 38 | val with_span : 39 | ?level:Level.t -> 40 | ?__FUNCTION__:string -> 41 | __FILE__:string -> 42 | __LINE__:int -> 43 | ?data:(unit -> (string * user_data) list) -> 44 | string -> 45 | (span -> 'a) -> 46 | 'a 47 | (** [with_span ~__FILE__ ~__LINE__ name f] enters a new span [sp], and calls 48 | [f sp]. [sp] might be a dummy span if no collector is installed. When [f sp] 49 | returns or raises, the span [sp] is exited. 50 | 51 | This is the recommended way to instrument most code. 52 | 53 | @param level 54 | optional level for this span. since 0.7. Default is set via 55 | {!set_default_level}. 56 | 57 | {b NOTE} an important restriction is that this is only supposed to work for 58 | synchronous, direct style code. Monadic concurrency, Effect-based fibers, 59 | etc. might not play well with this style of spans on some or all backends. 60 | If you use cooperative concurrency, see {!enter_manual_span}. *) 61 | 62 | val enter_span : 63 | ?level:Level.t -> 64 | ?__FUNCTION__:string -> 65 | __FILE__:string -> 66 | __LINE__:int -> 67 | ?data:(unit -> (string * user_data) list) -> 68 | string -> 69 | span 70 | (** Enter a span manually. 71 | 72 | @param level 73 | optional level for this span. since 0.7. Default is set via 74 | {!set_default_level}. *) 75 | 76 | val exit_span : span -> unit 77 | (** Exit a span manually. This must run on the same thread as the corresponding 78 | {!enter_span}, and spans must nest correctly. *) 79 | 80 | val add_data_to_span : span -> (string * user_data) list -> unit 81 | (** Add structured data to the given active span (see {!with_span}). Behavior is 82 | not specified if the span has been exited. 83 | @since 0.4 *) 84 | 85 | val enter_manual_span : 86 | parent:explicit_span_ctx option -> 87 | ?flavor:span_flavor -> 88 | ?level:Level.t -> 89 | ?__FUNCTION__:string -> 90 | __FILE__:string -> 91 | __LINE__:int -> 92 | ?data:(unit -> (string * user_data) list) -> 93 | string -> 94 | explicit_span 95 | (** Like {!with_span} but the caller is responsible for obtaining the [parent] 96 | span from their {e own} caller, and carry the resulting {!explicit_span} to 97 | the matching {!exit_manual_span}. 98 | 99 | {b NOTE} this replaces [enter_manual_sub_span] and 100 | [enter_manual_toplevel_span] by just making [parent] an explicit option. It 101 | is breaking anyway because we now pass an {!explicit_span_ctx} instead of a 102 | full {!explicit_span} (the reason being that we might receive this 103 | explicit_span_ctx from another process or machine). 104 | 105 | @param flavor 106 | a description of the span that can be used by the {!Collector.S} to decide 107 | how to represent the span. Typically, [`Sync] spans start and stop on one 108 | thread, and are nested purely by their timestamp; and [`Async] spans can 109 | overlap, migrate between threads, etc. (as happens in Lwt, Eio, Async, 110 | etc.) which impacts how the collector might represent them. 111 | @param level 112 | optional level for this span. since 0.7. Default is set via 113 | {!set_default_level}. 114 | @since 0.10 *) 115 | 116 | val enter_manual_sub_span : 117 | parent:explicit_span -> 118 | ?flavor:[ `Sync | `Async ] -> 119 | ?level:Level.t -> 120 | ?__FUNCTION__:string -> 121 | __FILE__:string -> 122 | __LINE__:int -> 123 | ?data:(unit -> (string * user_data) list) -> 124 | string -> 125 | explicit_span 126 | [@@deprecated "use enter_manual_span"] 127 | (** @deprecated since 0.10, use {!enter_manual_span} *) 128 | 129 | val enter_manual_toplevel_span : 130 | ?flavor:[ `Sync | `Async ] -> 131 | ?level:Level.t -> 132 | ?__FUNCTION__:string -> 133 | __FILE__:string -> 134 | __LINE__:int -> 135 | ?data:(unit -> (string * user_data) list) -> 136 | string -> 137 | explicit_span 138 | [@@deprecated "use enter_manual_span"] 139 | (** @deprecated since 0.10, use {!enter_manual_span} *) 140 | 141 | val exit_manual_span : explicit_span -> unit 142 | (** Exit an explicit span. This can be on another thread, in a fiber or 143 | lightweight thread, etc. and will be supported by backends nonetheless. The 144 | span can be obtained via {!enter_manual_sub_span} or 145 | {!enter_manual_toplevel_span}. 146 | @since 0.3 *) 147 | 148 | val add_data_to_manual_span : explicit_span -> (string * user_data) list -> unit 149 | (** [add_data_explicit esp data] adds [data] to the span [esp]. The behavior is 150 | not specified is the span has been exited already. 151 | @since 0.4 *) 152 | 153 | val message : 154 | ?level:Level.t -> 155 | ?span:span -> 156 | ?data:(unit -> (string * user_data) list) -> 157 | string -> 158 | unit 159 | (** [message msg] logs a message [msg] (if a collector is installed). Additional 160 | metadata can be provided. 161 | @param level 162 | optional level for this span. since 0.7. Default is set via 163 | {!set_default_level}. 164 | @param span 165 | the surrounding span, if any. This might be ignored by the collector. *) 166 | 167 | val messagef : 168 | ?level:Level.t -> 169 | ?span:span -> 170 | ?data:(unit -> (string * user_data) list) -> 171 | ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> 172 | unit 173 | (** [messagef (fun k->k"hello %s %d!" "world" 42)] is like 174 | [message "hello world 42!"] but only computes the string formatting if a 175 | collector is installed. 176 | @param level 177 | optional level for this span. since 0.7. Default is set via 178 | {!set_default_level}. *) 179 | 180 | val set_thread_name : string -> unit 181 | (** Give a name to the current thread. This might be used by the collector to 182 | display traces in a more informative way. *) 183 | 184 | val set_process_name : string -> unit 185 | (** Give a name to the current process. This might be used by the collector to 186 | display traces in a more informative way. *) 187 | 188 | val counter_int : 189 | ?level:Level.t -> 190 | ?data:(unit -> (string * user_data) list) -> 191 | string -> 192 | int -> 193 | unit 194 | (** Emit a counter of type [int]. Counters represent the evolution of some 195 | quantity over time. 196 | @param level 197 | optional level for this span. since 0.7. Default is set via 198 | {!set_default_level}. 199 | @param data metadata for this metric (since 0.4) *) 200 | 201 | val counter_float : 202 | ?level:Level.t -> 203 | ?data:(unit -> (string * user_data) list) -> 204 | string -> 205 | float -> 206 | unit 207 | (** Emit a counter of type [float]. See {!counter_int} for more details. 208 | @param level 209 | optional level for this span. since 0.7. Default is set via 210 | {!set_default_level}. 211 | @param data metadata for this metric (since 0.4) *) 212 | 213 | (** {2 Collector} *) 214 | 215 | type collector = (module Collector.S) 216 | (** An event collector. 217 | 218 | See {!Collector} for more details. *) 219 | 220 | val setup_collector : collector -> unit 221 | (** [setup_collector c] installs [c] as the current collector. 222 | @raise Invalid_argument if there already is an established collector. *) 223 | 224 | val get_current_level : unit -> Level.t 225 | (** Get current level. This is only meaningful if a collector was set up with 226 | {!setup_collector}. 227 | @since 0.7 *) 228 | 229 | val set_current_level : Level.t -> unit 230 | (** Set the current level of tracing. This only has a visible effect if a 231 | collector was installed with {!setup_collector}. 232 | @since 0.7 *) 233 | 234 | val shutdown : unit -> unit 235 | (** [shutdown ()] shutdowns the current collector, if one was installed, and 236 | waits for it to terminate before returning. *) 237 | 238 | (** {2 Extensions} *) 239 | 240 | type extension_event = Types.extension_event = .. 241 | (** Extension event 242 | @since 0.8 *) 243 | 244 | val extension_event : extension_event -> unit 245 | (** Trigger an extension event, whose meaning depends on the library that 246 | defines it. Some collectors will simply ignore it. This does nothing if no 247 | collector is setup. 248 | @since 0.8 *) 249 | -------------------------------------------------------------------------------- /src/fuchsia/writer.ml: -------------------------------------------------------------------------------- 1 | (** Write fuchsia events into buffers. 2 | 3 | Reference: https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format *) 4 | 5 | open Common_ 6 | module Util = Util 7 | 8 | open struct 9 | let[@inline] int64_of_trace_id_ (id : Trace_core.trace_id) : int64 = 10 | if id == Trace_core.Collector.dummy_trace_id then 11 | 0L 12 | else 13 | Bytes.get_int64_le (Bytes.unsafe_of_string id) 0 14 | end 15 | 16 | open Util 17 | 18 | type user_data = Trace_core.user_data 19 | 20 | type arg = 21 | | A_bool of bool 22 | | A_float of float 23 | | A_int of int 24 | | A_none 25 | | A_string of string 26 | | A_kid of int64 27 | 28 | let arg_of_user_data : user_data -> arg = function 29 | | `Bool b -> A_bool b 30 | | `Float f -> A_float f 31 | | `Int i -> A_int i 32 | | `String s -> A_string s 33 | | `None -> A_none 34 | 35 | let[@inline] args_of_user_data : 36 | (string * user_data) list -> (string * arg) list = 37 | fun l -> List.rev_map (fun (k, v) -> k, arg_of_user_data v) l 38 | 39 | module I64 = struct 40 | include Int64 41 | 42 | let ( + ) = add 43 | let ( - ) = sub 44 | let ( = ) = equal 45 | let ( land ) = logand 46 | let ( lor ) = logor 47 | let lnot = lognot 48 | let ( lsl ) = shift_left 49 | let ( lsr ) = shift_right_logical 50 | let ( asr ) = shift_right 51 | end 52 | 53 | open struct 54 | (** maximum length as specified in the 55 | {{:https://fuchsia.dev/fuchsia-src/reference/tracing/trace-format} spec} 56 | *) 57 | let max_str_len = 32000 58 | 59 | (** Length of string, in words *) 60 | let[@inline] str_len_word (s : string) = 61 | let len = String.length s in 62 | assert (len <= max_str_len); 63 | round_to_word len lsr 3 64 | 65 | let str_len_word_maybe_too_big s = 66 | let len = min max_str_len (String.length s) in 67 | round_to_word len lsr 3 68 | end 69 | 70 | module Str_ref = struct 71 | type t = int 72 | (** 16 bits *) 73 | 74 | let[@inline never] inline_fail_ () = 75 | invalid_arg 76 | (Printf.sprintf "fuchsia: max length of strings is %d" max_str_len) 77 | 78 | let inline (size : int) : t = 79 | if size > max_str_len then 80 | inline_fail_ () 81 | else if size = 0 then 82 | 0 83 | else 84 | (1 lsl 15) lor size 85 | end 86 | 87 | (** [truncate_string s] truncates [s] to the maximum length allowed for strings. 88 | If [s] is already short enough, no allocation is done. *) 89 | let[@inline] truncate_string s : string = 90 | if String.length s <= max_str_len then 91 | s 92 | else 93 | String.sub s 0 max_str_len 94 | 95 | module Thread_ref = struct 96 | type t = 97 | | Ref of int 98 | | Inline of { 99 | pid: int; 100 | tid: int; 101 | } 102 | 103 | let inline ~pid ~tid : t = Inline { pid; tid } 104 | 105 | let ref x : t = 106 | if x = 0 || x > 255 then 107 | invalid_arg "fuchsia: thread inline ref must be >0 < 256"; 108 | Ref x 109 | 110 | let size_word (self : t) : int = 111 | match self with 112 | | Ref _ -> 0 113 | | Inline _ -> 2 114 | 115 | (** 8-bit int for the reference *) 116 | let as_i8 (self : t) : int = 117 | match self with 118 | | Ref i -> i 119 | | Inline _ -> 0 120 | end 121 | 122 | (** record type = 0 *) 123 | module Metadata = struct 124 | (** First record in the trace *) 125 | module Magic_record = struct 126 | let value = 0x0016547846040010L 127 | let size_word = 1 128 | 129 | let encode (bufs : Buf_chain.t) = 130 | let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in 131 | Buf.add_i64 buf value 132 | end 133 | 134 | module Initialization_record = struct 135 | let size_word = 2 136 | 137 | (** Default: 1 tick = 1 ns *) 138 | let default_ticks_per_sec = 1_000_000_000L 139 | 140 | let encode (bufs : Buf_chain.t) ~ticks_per_secs () : unit = 141 | let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in 142 | let hd = I64.(1L lor (of_int size_word lsl 4)) in 143 | Buf.add_i64 buf hd; 144 | Buf.add_i64 buf ticks_per_secs 145 | end 146 | 147 | module Provider_info = struct 148 | let size_word ~name () = 1 + str_len_word name 149 | 150 | let encode (bufs : Buf_chain.t) ~(id : int) ~name () : unit = 151 | let name = truncate_string name in 152 | let size = size_word ~name () in 153 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 154 | let hd = 155 | I64.( 156 | (of_int size lsl 4) 157 | lor (1L lsl 16) 158 | lor (of_int id lsl 20) 159 | lor (of_int (Str_ref.inline (str_len_word name)) lsl 52)) 160 | in 161 | Buf.add_i64 buf hd; 162 | Buf.add_string buf name 163 | end 164 | 165 | module Provider_section = struct end 166 | module Trace_info = struct end 167 | end 168 | 169 | module Argument = struct 170 | type t = string * arg 171 | 172 | let check_valid_ : t -> unit = function 173 | | _, A_string s -> assert (String.length s < max_str_len) 174 | | _ -> () 175 | 176 | let[@inline] is_i32_ (i : int) : bool = Int32.(to_int (of_int i) = i) 177 | 178 | let size_word (self : t) = 179 | let name, data = self in 180 | match data with 181 | | A_none | A_bool _ -> 1 + str_len_word name 182 | | A_int i when is_i32_ i -> 1 + str_len_word name 183 | | A_int _ -> (* int64 *) 2 + str_len_word name 184 | | A_float _ -> 2 + str_len_word name 185 | | A_string s -> 1 + str_len_word_maybe_too_big s + str_len_word name 186 | | A_kid _ -> 2 + str_len_word name 187 | 188 | open struct 189 | external int_of_bool : bool -> int = "%identity" 190 | end 191 | 192 | let encode (buf : Buf.t) (self : t) : unit = 193 | let name, data = self in 194 | let name = truncate_string name in 195 | let size = size_word self in 196 | 197 | (* part of header with argument name + size *) 198 | let hd_arg_size = 199 | I64.( 200 | (of_int size lsl 4) 201 | lor (of_int (Str_ref.inline (String.length name)) lsl 16)) 202 | in 203 | 204 | match data with 205 | | A_none -> 206 | let hd = hd_arg_size in 207 | Buf.add_i64 buf hd; 208 | Buf.add_string buf name 209 | | A_int i when is_i32_ i -> 210 | let hd = I64.(1L lor hd_arg_size lor (of_int i lsl 32)) in 211 | Buf.add_i64 buf hd; 212 | Buf.add_string buf name 213 | | A_int i -> 214 | (* int64 *) 215 | let hd = I64.(3L lor hd_arg_size) in 216 | Buf.add_i64 buf hd; 217 | Buf.add_string buf name; 218 | Buf.add_i64 buf (I64.of_int i) 219 | | A_float f -> 220 | let hd = I64.(5L lor hd_arg_size) in 221 | Buf.add_i64 buf hd; 222 | Buf.add_string buf name; 223 | Buf.add_i64 buf (I64.bits_of_float f) 224 | | A_string s -> 225 | let s = truncate_string s in 226 | let hd = 227 | I64.( 228 | 6L lor hd_arg_size 229 | lor (of_int (Str_ref.inline (String.length s)) lsl 32)) 230 | in 231 | Buf.add_i64 buf hd; 232 | Buf.add_string buf name; 233 | Buf.add_string buf s 234 | | A_bool b -> 235 | let hd = I64.(9L lor hd_arg_size lor (of_int (int_of_bool b) lsl 16)) in 236 | Buf.add_i64 buf hd; 237 | Buf.add_string buf name 238 | | A_kid kid -> 239 | (* int64 *) 240 | let hd = I64.(8L lor hd_arg_size) in 241 | Buf.add_i64 buf hd; 242 | Buf.add_string buf name; 243 | Buf.add_i64 buf kid 244 | end 245 | 246 | module Arguments = struct 247 | type t = Argument.t list 248 | 249 | let[@inline] len (self : t) : int = 250 | match self with 251 | | [] -> 0 252 | | [ _ ] -> 1 253 | | _ :: _ :: tl -> 2 + List.length tl 254 | 255 | let check_valid (self : t) = 256 | let len = len self in 257 | if len > 15 then 258 | invalid_arg (spf "fuchsia: can have at most 15 args, got %d" len); 259 | List.iter Argument.check_valid_ self; 260 | () 261 | 262 | let[@inline] size_word (self : t) = 263 | match self with 264 | | [] -> 0 265 | | [ a ] -> Argument.size_word a 266 | | a :: b :: tl -> 267 | List.fold_left 268 | (fun n arg -> n + Argument.size_word arg) 269 | (Argument.size_word a + Argument.size_word b) 270 | tl 271 | 272 | let[@inline] encode (buf : Buf.t) (self : t) = 273 | let rec aux buf l = 274 | match l with 275 | | [] -> () 276 | | x :: tl -> 277 | Argument.encode buf x; 278 | aux buf tl 279 | in 280 | 281 | match self with 282 | | [] -> () 283 | | [ x ] -> Argument.encode buf x 284 | | x :: tl -> 285 | Argument.encode buf x; 286 | aux buf tl 287 | end 288 | 289 | (** record type = 3 *) 290 | module Thread_record = struct 291 | let size_word : int = 3 292 | 293 | (** Record that [Thread_ref.ref as_ref] represents the pair [pid, tid] *) 294 | let encode (bufs : Buf_chain.t) ~as_ref ~pid ~tid () : unit = 295 | if as_ref <= 0 || as_ref > 255 then 296 | invalid_arg "fuchsia: thread_record: invalid ref"; 297 | 298 | let@ buf = Buf_chain.with_buf bufs ~available_word:size_word in 299 | 300 | let hd = I64.(3L lor (of_int size_word lsl 4) lor (of_int as_ref lsl 16)) in 301 | Buf.add_i64 buf hd; 302 | Buf.add_i64 buf (I64.of_int pid); 303 | Buf.add_i64 buf (I64.of_int tid) 304 | end 305 | 306 | (** record type = 4 *) 307 | module Event = struct 308 | (** type=0 *) 309 | module Instant = struct 310 | let size_word ~name ~t_ref ~args () : int = 311 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 312 | + Arguments.size_word args 313 | 314 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args 315 | () : unit = 316 | let name = truncate_string name in 317 | let size = size_word ~name ~t_ref ~args () in 318 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 319 | 320 | (* set category = 0 *) 321 | let hd = 322 | I64.( 323 | 4L 324 | lor (of_int size lsl 4) 325 | lor (of_int (Arguments.len args) lsl 20) 326 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 327 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 328 | in 329 | Buf.add_i64 buf hd; 330 | Buf.add_i64 buf time_ns; 331 | 332 | (match t_ref with 333 | | Thread_ref.Inline { pid; tid } -> 334 | Buf.add_i64 buf (I64.of_int pid); 335 | Buf.add_i64 buf (I64.of_int tid) 336 | | Thread_ref.Ref _ -> ()); 337 | 338 | Buf.add_string buf name; 339 | Arguments.encode buf args; 340 | () 341 | end 342 | 343 | (** type=1 *) 344 | module Counter = struct 345 | let size_word ~name ~t_ref ~args () : int = 346 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 347 | + Arguments.size_word args + 1 (* counter id *) 348 | 349 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args 350 | () : unit = 351 | let name = truncate_string name in 352 | let size = size_word ~name ~t_ref ~args () in 353 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 354 | 355 | let hd = 356 | I64.( 357 | 4L 358 | lor (of_int size lsl 4) 359 | lor (1L lsl 16) 360 | lor (of_int (Arguments.len args) lsl 20) 361 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 362 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 363 | in 364 | Buf.add_i64 buf hd; 365 | Buf.add_i64 buf time_ns; 366 | 367 | (match t_ref with 368 | | Thread_ref.Inline { pid; tid } -> 369 | Buf.add_i64 buf (I64.of_int pid); 370 | Buf.add_i64 buf (I64.of_int tid) 371 | | Thread_ref.Ref _ -> ()); 372 | 373 | Buf.add_string buf name; 374 | Arguments.encode buf args; 375 | (* just use 0 as counter id *) 376 | Buf.add_i64 buf 0L; 377 | () 378 | end 379 | 380 | (** type=2 *) 381 | module Duration_begin = struct 382 | let size_word ~name ~t_ref ~args () : int = 383 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 384 | + Arguments.size_word args 385 | 386 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args 387 | () : unit = 388 | let name = truncate_string name in 389 | let size = size_word ~name ~t_ref ~args () in 390 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 391 | 392 | let hd = 393 | I64.( 394 | 4L 395 | lor (of_int size lsl 4) 396 | lor (2L lsl 16) 397 | lor (of_int (Arguments.len args) lsl 20) 398 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 399 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 400 | in 401 | Buf.add_i64 buf hd; 402 | Buf.add_i64 buf time_ns; 403 | 404 | (match t_ref with 405 | | Thread_ref.Inline { pid; tid } -> 406 | Buf.add_i64 buf (I64.of_int pid); 407 | Buf.add_i64 buf (I64.of_int tid) 408 | | Thread_ref.Ref _ -> ()); 409 | 410 | Buf.add_string buf name; 411 | Arguments.encode buf args; 412 | () 413 | end 414 | 415 | (** type=3 *) 416 | module Duration_end = struct 417 | let size_word ~name ~t_ref ~args () : int = 418 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 419 | + Arguments.size_word args 420 | 421 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns ~args 422 | () : unit = 423 | let name = truncate_string name in 424 | let size = size_word ~name ~t_ref ~args () in 425 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 426 | 427 | let hd = 428 | I64.( 429 | 4L 430 | lor (of_int size lsl 4) 431 | lor (3L lsl 16) 432 | lor (of_int (Arguments.len args) lsl 20) 433 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 434 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 435 | in 436 | Buf.add_i64 buf hd; 437 | Buf.add_i64 buf time_ns; 438 | 439 | (match t_ref with 440 | | Thread_ref.Inline { pid; tid } -> 441 | Buf.add_i64 buf (I64.of_int pid); 442 | Buf.add_i64 buf (I64.of_int tid) 443 | | Thread_ref.Ref _ -> ()); 444 | 445 | Buf.add_string buf name; 446 | Arguments.encode buf args; 447 | () 448 | end 449 | 450 | (** type=4 *) 451 | module Duration_complete = struct 452 | let size_word ~name ~t_ref ~args () : int = 453 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 454 | + Arguments.size_word args + 1 (* end timestamp *) 455 | 456 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns 457 | ~end_time_ns ~args () : unit = 458 | let name = truncate_string name in 459 | let size = size_word ~name ~t_ref ~args () in 460 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 461 | 462 | (* set category = 0 *) 463 | let hd = 464 | I64.( 465 | 4L 466 | lor (of_int size lsl 4) 467 | lor (4L lsl 16) 468 | lor (of_int (Arguments.len args) lsl 20) 469 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 470 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 471 | in 472 | Buf.add_i64 buf hd; 473 | Buf.add_i64 buf time_ns; 474 | 475 | (match t_ref with 476 | | Thread_ref.Inline { pid; tid } -> 477 | Buf.add_i64 buf (I64.of_int pid); 478 | Buf.add_i64 buf (I64.of_int tid) 479 | | Thread_ref.Ref _ -> ()); 480 | 481 | Buf.add_string buf name; 482 | Arguments.encode buf args; 483 | Buf.add_i64 buf end_time_ns; 484 | () 485 | end 486 | 487 | (** type=5 *) 488 | module Async_begin = struct 489 | let size_word ~name ~t_ref ~args () : int = 490 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 491 | + Arguments.size_word args + 1 (* async id *) 492 | 493 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns 494 | ~(async_id : Trace_core.trace_id) ~args () : unit = 495 | let name = truncate_string name in 496 | let size = size_word ~name ~t_ref ~args () in 497 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 498 | 499 | let hd = 500 | I64.( 501 | 4L 502 | lor (of_int size lsl 4) 503 | lor (5L lsl 16) 504 | lor (of_int (Arguments.len args) lsl 20) 505 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 506 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 507 | in 508 | Buf.add_i64 buf hd; 509 | Buf.add_i64 buf time_ns; 510 | 511 | (match t_ref with 512 | | Thread_ref.Inline { pid; tid } -> 513 | Buf.add_i64 buf (I64.of_int pid); 514 | Buf.add_i64 buf (I64.of_int tid) 515 | | Thread_ref.Ref _ -> ()); 516 | 517 | Buf.add_string buf name; 518 | Arguments.encode buf args; 519 | Buf.add_i64 buf (int64_of_trace_id_ async_id); 520 | () 521 | end 522 | 523 | (** type=7 *) 524 | module Async_end = struct 525 | let size_word ~name ~t_ref ~args () : int = 526 | 1 + Thread_ref.size_word t_ref + 1 (* timestamp *) + str_len_word name 527 | + Arguments.size_word args + 1 (* async id *) 528 | 529 | let encode (bufs : Buf_chain.t) ~name ~(t_ref : Thread_ref.t) ~time_ns 530 | ~(async_id : Trace_core.trace_id) ~args () : unit = 531 | let name = truncate_string name in 532 | let size = size_word ~name ~t_ref ~args () in 533 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 534 | 535 | let hd = 536 | I64.( 537 | 4L 538 | lor (of_int size lsl 4) 539 | lor (7L lsl 16) 540 | lor (of_int (Arguments.len args) lsl 20) 541 | lor (of_int (Thread_ref.as_i8 t_ref) lsl 24) 542 | lor (of_int (Str_ref.inline (String.length name)) lsl 48)) 543 | in 544 | Buf.add_i64 buf hd; 545 | Buf.add_i64 buf time_ns; 546 | 547 | (match t_ref with 548 | | Thread_ref.Inline { pid; tid } -> 549 | Buf.add_i64 buf (I64.of_int pid); 550 | Buf.add_i64 buf (I64.of_int tid) 551 | | Thread_ref.Ref _ -> ()); 552 | 553 | Buf.add_string buf name; 554 | Arguments.encode buf args; 555 | Buf.add_i64 buf (int64_of_trace_id_ async_id); 556 | () 557 | end 558 | end 559 | 560 | (** record type = 7 *) 561 | module Kernel_object = struct 562 | let size_word ~name ~args () : int = 563 | 1 + 1 + str_len_word name + Arguments.size_word args 564 | 565 | (* see: 566 | https://cs.opensource.google/fuchsia/fuchsia/+/main:zircon/system/public/zircon/types.h;l=441?q=ZX_OBJ_TYPE&ss=fuchsia%2Ffuchsia 567 | *) 568 | 569 | type ty = int 570 | 571 | let ty_process : ty = 1 572 | let ty_thread : ty = 2 573 | 574 | let encode (bufs : Buf_chain.t) ~name ~(ty : ty) ~(kid : int) ~args () : unit 575 | = 576 | let name = truncate_string name in 577 | let size = size_word ~name ~args () in 578 | let@ buf = Buf_chain.with_buf bufs ~available_word:size in 579 | 580 | let hd = 581 | I64.( 582 | 7L 583 | lor (of_int size lsl 4) 584 | lor (of_int ty lsl 16) 585 | lor (of_int (Arguments.len args) lsl 40) 586 | lor (of_int (Str_ref.inline (String.length name)) lsl 24)) 587 | in 588 | Buf.add_i64 buf hd; 589 | Buf.add_i64 buf (I64.of_int kid); 590 | Buf.add_string buf name; 591 | Arguments.encode buf args; 592 | () 593 | end 594 | --------------------------------------------------------------------------------