Compare commits

..

17 commits
v0.11 ... main

Author SHA1 Message Date
Simon Cruanes
41b152c789
doc 2026-03-03 09:23:34 -05:00
Simon Cruanes
dd30ae0858
prepare for 0.12 2026-02-27 21:53:15 -05:00
Simon Cruanes
fd6eac6ea8 format 2026-02-26 12:33:53 -05:00
Simon Cruanes
a36f91b350 fix tests 2026-02-26 12:33:53 -05:00
Simon Cruanes
3752d70403 testing with domains 2026-02-26 12:33:53 -05:00
Simon Cruanes
72d64be0c3 additional unit tests 2026-02-26 12:33:53 -05:00
Simon Cruanes
0a95e5ff37 test for TLS as ambient-span-provider 2026-02-26 12:33:53 -05:00
Simon Cruanes
fe50b4d325 CI 2026-02-26 12:33:53 -05:00
Simon Cruanes
e0a705e391
add trace.thread-local-storage optional library
a basic ambient span provider.
2026-02-26 09:36:06 -05:00
Simon Cruanes
aaba8d4db3
use current_span when entering spans or sending messages
use the current span if no parent/context span is specified.
2026-02-25 14:16:47 -05:00
Simon Cruanes
4e6c69de8c
Merge pull request #44 from ocaml-tracing/simon/proper-scope-in-collector
add ambient_span_provider to get cur_span/with_cur_span
2026-02-25 14:10:02 -05:00
Simon Cruanes
85b501ce14
fix test dune stanza 2026-02-15 21:34:00 -05:00
Simon Cruanes
44bafeca1a
test for runtime events is optional 2026-02-15 16:33:50 -05:00
Simon Cruanes
a20233a455
add CI for formatting 2026-02-15 16:30:57 -05:00
Simon Cruanes
d8cdb2bcc2
runtime events collector, + test 2026-02-11 20:39:25 -05:00
Simon Cruanes
e4d4e23530
add {thread,process}_sort_index extension + TEF support
https://github.com/google/perfetto/pull/3273/changes#diff-ecec88c33adb7591ee6aa88e29b62ad52ef443611cba5e0f0ecac9b5725afdba

allows user to sort threads/processes.
2026-02-11 20:16:07 -05:00
Simon Cruanes
627164afd0
update next tag 2026-02-10 20:43:09 -05:00
45 changed files with 1068 additions and 42 deletions

28
.github/workflows/format.yml vendored Normal file
View file

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

View file

@ -24,7 +24,7 @@ jobs:
- run: opam pin odoc 3.1.0 -y -n
# crash with 2.4, see https://github.com/ocaml/odoc/issues/1066
- name: Deps
run: opam install odig trace trace-tef trace-fuchsia ppx_trace
run: opam install odig thread-local-storage trace trace-tef trace-fuchsia ppx_trace
- name: Build
run: opam exec -- odig odoc --cache-dir=_doc/ trace trace-tef trace-fuchsia ppx_trace

View file

@ -47,7 +47,7 @@ jobs:
- run: opam exec -- dune runtest -p trace-tef,trace-fuchsia
# with depopts
- run: opam install hmap
- run: opam install hmap thread-local-storage
- run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
- run: opam install picos_aux

View file

@ -1,3 +1,12 @@
# 0.12
- use `current_span` when entering spans or sending messages
- add `Trace.Ambient_span_provider.t` concept, to track the current span.
It is not part of the collector and is optional.
- add `trace.thread-local-storage` optional library that implements the `Ambient_span_provider.t`
- add a runtime events collector, + test, in `trace-runtime-events`
- add `{thread,process}_sort_index` extension + TEF support
# 0.11
- entire rework of the collector, now lighter, and using an open sum type

View file

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

View file

@ -4,7 +4,7 @@
(generate_opam_files true)
(version 0.11)
(version 0.12)
(source
(github ocaml-tracing/ocaml-trace))
@ -29,6 +29,7 @@
dune)
(depopts
unix
(thread-local-storage (>= 0.2))
(mtime
(>= 2.0)))
(tags
@ -91,4 +92,20 @@
(tags
(trace tracing fuchsia)))
(package
(name trace-runtime-events)
(synopsis
"A simple collector relying on runtime-events for OCaml 5. Some assembly required.")
(depends
(ocaml
(>= 5.1))
(trace
(= :version))
(ppx_trace (and (= :version) :with-test))
base-bigarray
base-unix
dune)
(tags
(trace tracing trace runtime-events)))
; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project

View file

@ -1,6 +1,6 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.11"
version: "0.12"
synopsis: "A ppx-based preprocessor for trace"
maintainer: ["Simon Cruanes"]
authors: ["Simon Cruanes"]

View file

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

View file

@ -82,8 +82,7 @@ end
This is only relevant to implementors of tracing backends; to instrument
your code you only need to look at the {!Trace} module.
The definition changed since NEXT_RELEASE to a record of callbacks + a state
*)
The definition changed since 0.11 to a record of callbacks + a state *)
type t =
| C_none (** No collector. *)
| C_some : 'st * 'st Callbacks.t -> t

View file

@ -1,6 +1,6 @@
(** A few core extensions.
@since NEXT_RELEASE *)
@since 0.11 *)
open Types
@ -8,6 +8,10 @@ open Types
type extension_event +=
| Extension_set_thread_name of string
| Extension_set_process_name of string
| Extension_set_thread_sort_index of int
(** https://github.com/google/perfetto/pull/3273/changes#diff-ecec88c33adb7591ee6aa88e29b62ad52ef443611cba5e0f0ecac9b5725afdba
*)
| Extension_set_process_sort_index of int
(** Specialized parameters *)
type extension_parameter +=

View file

@ -3,6 +3,7 @@ module A = Atomic_
module Collector = Collector
module Level = Level
module Core_ext = Core_ext
module Ambient_span_provider = Ambient_span_provider
type collector = Collector.t
@ -15,8 +16,17 @@ let collector : collector A.t = A.make Collector.C_none
let default_level_ = A.make Level.Trace
let current_level_ = A.make Level.Trace
(** Global provider of span context *)
let ambient_span_provider : Ambient_span_provider.t A.t =
A.make Ambient_span_provider.ASP_none
(* ## implementation ## *)
let[@inline] option_or_ a f =
match a with
| Some _ -> a
| None -> f ()
let data_empty_build_ () = []
let[@inline] enabled () = Collector.is_some (A.get collector)
let[@inline] get_default_level () = A.get default_level_
@ -27,8 +37,21 @@ let[@inline] get_current_level () = A.get current_level_
let[@inline] check_level_ ~level st (cbs : _ Collector.Callbacks.t) : bool =
Level.leq level (A.get current_level_) && cbs.enabled st level
let[@inline] current_span () =
match A.get ambient_span_provider with
| ASP_none -> None
| ASP_some (st, cbs) -> cbs.get_current_span st
let[@inline] with_current_span_set_to sp f =
match A.get ambient_span_provider with
| ASP_none -> f sp
| ASP_some (st, cbs) -> cbs.with_current_span_set_to st sp f
let parent_of_span_opt_opt = function
| None -> P_unknown
| None ->
(match current_span () with
| None -> P_unknown
| Some p -> P_some p)
| Some None -> P_none
| Some (Some p) -> P_some p
@ -46,7 +69,10 @@ let with_span_collector_ st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__
enter_span_st st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ~level ?parent
?params ?data name
in
match f sp with
match
(* set [sp] as current span before calling [f sp] *)
with_current_span_set_to sp f
with
| res ->
cbs.exit_span st sp;
res
@ -93,6 +119,7 @@ let[@inline] add_data_to_span sp data : unit =
let message_collector_ st (cbs : _ Collector.Callbacks.t) ~level ?span
?(params = []) ?(data = data_empty_build_) msg : unit =
let data = data () in
let span = option_or_ span current_span in
cbs.message st ~level ~span ~params ~data msg
let[@inline] message ?(level = A.get default_level_) ?span ?params ?data msg :
@ -149,6 +176,8 @@ let with_setup_collector c f =
setup_collector c;
Fun.protect ~finally:shutdown f
let set_ambient_context_provider p = A.set ambient_span_provider p
type extension_event = Types.extension_event = ..
let[@inline] extension_event ?(level = A.get default_level_) ev : unit =

View file

@ -7,6 +7,7 @@
include module type of Types
module Collector = Collector
module Level = Level
module Ambient_span_provider = Ambient_span_provider
(**/**)
@ -54,10 +55,10 @@ val with_span :
@param level
optional level for this span. since 0.7. Default is set via
{!set_default_level}.
@param parent the span's parent, if any. since NEXT_RELEASE.
@param parent the span's parent, if any. since 0.11.
@param params
extension parameters, used to communicate additional information to the
collector. It might be collector-specific. since NEXT_RELEASE.
collector. It might be collector-specific. since 0.11.
Depending on the collector, this might clash with some forms of cooperative
concurrency in which [with_span (fun span -> )] might contain a yield
@ -83,7 +84,7 @@ val enter_span :
@param level
optional level for this span. since 0.7. Default is set via
{!set_default_level}.
@param parent the span's parent, if any. since NEXT_RELEASE.
@param parent the span's parent, if any. since 0.11.
@param params see {!with_span}. *)
val exit_span : span -> unit
@ -114,7 +115,7 @@ val message :
the surrounding span, if any. This might be ignored by the collector.
@param params
extension parameters, used to communicate additional information to the
collector. It might be collector-specific. since NEXT_RELEASE. *)
collector. It might be collector-specific. since 0.11. *)
val messagef :
?level:Level.t ->
@ -133,13 +134,13 @@ val set_thread_name : string -> unit
(** Give a name to the current thread. This might be used by the collector to
display traces in a more informative way.
Uses {!Core_ext.Extension_set_thread_name} since NEXT_RELEASE *)
Uses {!Core_ext.Extension_set_thread_name} since 0.11 *)
val set_process_name : string -> unit
(** Give a name to the current process. This might be used by the collector to
display traces in a more informative way.
Uses {!Core_ext.Extension_set_process_name} since NEXT_RELEASE *)
Uses {!Core_ext.Extension_set_process_name} since 0.11 *)
val metric :
?level:Level.t ->
@ -150,7 +151,7 @@ val metric :
unit
(** Emit a metric. Metrics are an extensible type, each collector might support
a different subset.
@since NEXT_RELEASE *)
@since 0.11 *)
val counter_int :
?level:Level.t ->
@ -180,6 +181,22 @@ val counter_float :
{!set_default_level}.
@param data metadata for this metric (since 0.4) *)
val current_span : unit -> span option
(** Access the current span from some ambient scope, {b if supported}. This is
only supported if a {!Ambient_span_provider} has been set up.
@since 0.12 *)
val with_current_span_set_to : span -> (span -> 'a) -> 'a
(** [with_current_span_set_to span f] sets the span as current span, enters
[f span], and restores the previous current span (if any).
This is only supported if a {!Ambient_span_provider} has been set up,
otherwise it is a no-op.
Automatically called by {!with_span}.
@since 0.12 *)
(** {2 Collector} *)
type collector = Collector.t
@ -206,7 +223,14 @@ val shutdown : unit -> unit
val with_setup_collector : Collector.t -> (unit -> 'a) -> 'a
(** [with_setup_collector c f] installs [c], calls [f()], and shutdowns [c] once
[f()] is done.
@since NEXT_RELEASE *)
@since 0.11 *)
(** {2 ambient span provider} *)
val set_ambient_context_provider : Ambient_span_provider.t -> unit
(** Install a provider for {!current_span} and {!with_current_span_set_to}. The
default provider does nothing (ie [current_span ()] is always [None]).
@since 0.12 *)
(** {2 Extensions} *)
@ -218,7 +242,7 @@ val extension_event : ?level:Level.t -> extension_event -> unit
(** Trigger an extension event, whose meaning depends on the library that
defines it. Some collectors will simply ignore it. This does nothing if no
collector is setup.
@param level filtering level, since NEXT_RELEASE
@param level filtering level, since 0.11
@since 0.8 *)
(** {2 Core extensions} *)

View file

@ -1,10 +1,12 @@
(** Main type definitions *)
type span = ..
(** A span. Its representation is defined by the current collector. *)
(** A span. Its representation is defined by the current collector.
This representation changed in 0.11 (from [int64] to an open sum type) *)
(** Information about a span's parent span, if any.
@since NEXT_RELEASE *)
@since 0.11 *)
type parent =
| P_unknown (** Parent is not specified at this point *)
| P_none (** We know the current span has no parent *)
@ -32,8 +34,8 @@ type extension_event = ..
type extension_parameter = ..
(** An extension parameter, used to carry information for spans/messages/metrics
that can be backend-specific or just not envisioned by [trace].
@since NEXT_RELEASE *)
@since 0.11 *)
type metric = ..
(** A metric, can be of many types. See {!Core_ext} for some builtin metrics.
@since NEXT_RELEASE *)
@since 0.11 *)

8
src/runtime-events/dune Normal file
View file

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

View file

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

View file

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

View file

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

View file

@ -2,7 +2,7 @@
This is a concrete representation of spans that is convenient to manipulate.
@since NEXT_RELEASE *)
@since 0.11 *)
open Trace_core

View file

@ -142,12 +142,27 @@ open struct
Writer.emit_name_process ~pid:self.pid ~name buf;
self.exporter.on_json buf
let on_thread_sort_index_ (self : st) ~tid i : unit =
let@ buf = Trace_util.Rpool.with_ self.buf_pool in
Writer.emit_thread_sort_index ~pid:self.pid ~tid i buf;
self.exporter.on_json buf
let on_process_sort_index_ (self : st) i : unit =
let@ buf = Trace_util.Rpool.with_ self.buf_pool in
Writer.emit_process_sort_index ~pid:self.pid i buf;
self.exporter.on_json buf
let extension (self : st) ~level:_ ev =
match ev with
| Core_ext.Extension_set_thread_name name ->
let tid = Trace_util.Mock_.get_tid () in
on_name_thread_ self ~tid name
| Core_ext.Extension_set_process_name name -> on_name_process_ self name
| Core_ext.Extension_set_process_sort_index idx ->
on_process_sort_index_ self idx
| Core_ext.Extension_set_thread_sort_index idx ->
let tid = Trace_util.Mock_.get_tid () in
on_thread_sort_index_ self ~tid idx
| _ -> ()
end

View file

@ -75,6 +75,19 @@ let emit_name_thread ~pid ~tid ~name buf : unit =
(emit_args_o_ pp_user_data_)
[ "name", `String name ]
let emit_process_sort_index ~pid i buf : unit =
Printf.bprintf buf
{json|{"pid":%d,"name":"process_sort_index","ph":"M"%a}|json} pid
(emit_args_o_ pp_user_data_)
[ "sort_index", `Int i ]
let emit_thread_sort_index ~pid ~tid i buf : unit =
Printf.bprintf buf
{json|{"pid":%d,"tid": %d,"name":"thread_sort_index","ph":"M"%a}|json} pid
tid
(emit_args_o_ pp_user_data_)
[ "sort_index", `Int i ]
let emit_name_process ~pid ~name buf : unit =
Printf.bprintf buf {json|{"pid":%d,"name":"process_name","ph":"M"%a}|json} pid
(emit_args_o_ pp_user_data_)

View file

@ -46,6 +46,8 @@ val emit_instant_event :
val emit_name_thread : pid:int -> tid:int -> name:string -> Buffer.t -> unit
val emit_name_process : pid:int -> name:string -> Buffer.t -> unit
val emit_process_sort_index : pid:int -> int -> Buffer.t -> unit
val emit_thread_sort_index : pid:int -> tid:int -> int -> Buffer.t -> unit
val emit_counter :
pid:int -> tid:int -> name:string -> ts:float -> Buffer.t -> float -> unit

6
src/tls/dune Normal file
View file

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

View file

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

View file

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

View file

@ -17,10 +17,10 @@
(unix -> time_util.unix.ml)
(-> time_util.dummy.ml))
(select
unix_util.ml
from
(unix -> unix_util.real.ml)
(-> unix_util.dummy.ml))
unix_util.ml
from
(unix -> unix_util.real.ml)
(-> unix_util.dummy.ml))
(select
domain_util.ml
from

29
test/domains/dune Normal file
View file

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

1
test/domains/ocaml5.ml Normal file
View file

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

View file

@ -0,0 +1,5 @@
=== domain concurrency ===
domain-0: enter=10000 exit=10000 msg=10000
domain-1: enter=10000 exit=10000 msg=10000
domain-2: enter=10000 exit=10000 msg=10000
domain-3: enter=10000 exit=10000 msg=10000

View file

@ -0,0 +1,10 @@
(* When Domain is unavailable (OCaml < 5), echo the expected file
so the diff always passes. The file is passed as argv[1] by the dune rule. *)
let () =
let ic = open_in Sys.argv.(1) in
(try
while true do
print_char (input_char ic)
done
with End_of_file -> ());
close_in ic

View file

@ -0,0 +1,89 @@
(* Test concurrent span recording across multiple domains (OCaml 5+).
Each domain runs [iters] spans. We embed the recording thread's id into
the span value so that exit events can be attributed to the right domain,
then verify that every domain has exactly [iters] enters and exits. *)
let ( let@ ) = ( @@ )
let iters = 10_000
(* Custom span type that carries the thread id of the recording domain. *)
type Trace_core.span += Thread_span of int
let make_recorder () =
let log = Queue.create () in
let mu = Mutex.create () in
let add x =
Mutex.lock mu;
Queue.add x log;
Mutex.unlock mu
in
let enter_span () ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~level:_ ~params:_
~data:_ ~parent:_ _name =
let tid = Thread.id (Thread.self ()) in
add (`Enter tid);
Thread_span tid
in
let exit_span () sp =
match sp with
| Thread_span tid -> add (`Exit tid)
| _ -> ()
in
let message () ~level:_ ~params:_ ~data:_ ~span:_ _msg =
add (`Msg (Thread.id (Thread.self ())))
in
let metric () ~level:_ ~params:_ ~data:_ _name _m = () in
let add_data_to_span () _sp _data = () in
let coll =
Trace_core.Collector.(
C_some
( (),
Callbacks.make ~enter_span ~exit_span ~add_data_to_span ~message
~metric () ))
in
coll, fun () -> Queue.fold (fun acc x -> x :: acc) [] log |> List.rev
let () =
print_endline "=== domain concurrency ===";
let coll, get = make_recorder () in
let@ () = Trace_core.with_setup_collector coll in
let n = 4 in
(* Each domain returns its own thread id so we can check per-domain counts. *)
let domains =
Array.init n (fun _i ->
Domain.spawn (fun () ->
let tid = Thread.id (Thread.self ()) in
for j = 1 to iters do
Trace_core.with_span ~__FILE__ ~__LINE__ "" @@ fun _ ->
Trace_core.message "";
if j mod 1000 = 0 then Thread.yield ()
done;
tid))
in
let tids = Array.map Domain.join domains in
let events = get () in
let count pred = List.length (List.filter pred events) in
(* For each domain, verify exactly [iters] enters and [iters] exits. *)
Array.iteri
(fun i tid ->
let n_enter =
count (function
| `Enter t -> t = tid
| _ -> false)
in
let n_exit =
count (function
| `Exit t -> t = tid
| _ -> false)
in
let n_msg =
count (function
| `Msg t -> t = tid
| _ -> false)
in
Printf.printf "domain-%d: enter=%d exit=%d msg=%d%s\n" i n_enter n_exit
n_msg
(if n_enter = iters && n_exit = iters && n_msg = iters then
""
else
" FAIL"))
tids

View file

@ -1,7 +1,7 @@
(test
(name t1)
(tests
(names t1 t_core t_debug)
(modules t1 t_core t_debug)
(package trace-tef)
(modules t1)
(libraries trace trace-tef))
(test
@ -13,7 +13,9 @@
(libraries trace-tef))
(test
(name t_debug)
(modules t_debug)
(package trace-tef)
(libraries trace trace.debug trace-tef))
(name t_runtime_events)
(package trace-runtime-events)
(modules t_runtime_events)
(preprocess
(pps ppx_trace))
(libraries trace trace-runtime-events runtime_events))

View file

@ -1,3 +1,5 @@
module Trace = Trace_core
let run () =
Trace.set_process_name "main";
Trace.set_thread_name "t1";

View file

@ -1,3 +1,5 @@
module Trace = Trace_core
let ( let@ ) = ( @@ )
let rec fib x =

19
test/t_core.expected Normal file
View file

@ -0,0 +1,19 @@
=== level filtering ===
enter(error-span)
enter(info-span)
msg(warn-msg)
=== manual enter/exit ===
enter(manual)
exit
=== exception safety ===
enter(risky)
exit
=== no collector ===
ok
=== double setup ===
caught: trace: collector already present
=== metrics ===
metric(my_int,42)
metric(my_float,3.14)
=== with_setup_collector exception safety ===
shutdown called: true

138
test/t_core.ml Normal file
View file

@ -0,0 +1,138 @@
module Trace = Trace_core
let ( let@ ) = ( @@ )
(** mini recording collector *)
let make_recorder ?(on_shutdown = fun () -> ()) () :
Trace.Collector.t * (unit -> _ list) =
let log = Queue.create () in
let enter_span () ~__FUNCTION__:_ ~__FILE__:_ ~__LINE__:_ ~level:_ ~params:_
~data:_ ~parent:_ name =
Queue.add (`Enter name) log;
Trace.Collector.dummy_span
in
let exit_span () _sp = Queue.add `Exit log in
let message () ~level:_ ~params:_ ~data:_ ~span:_ msg =
Queue.add (`Msg msg) log
in
let metric () ~level:_ ~params:_ ~data:_ name m =
let v =
match m with
| Trace.Core_ext.Metric_int n -> string_of_int n
| Trace.Core_ext.Metric_float f -> Printf.sprintf "%.2f" f
| _ -> "?"
in
Queue.add (`Metric (name, v)) log
in
let add_data_to_span () _sp _data = () in
let coll =
Trace.Collector.(
C_some
( (),
Callbacks.make ~enter_span ~exit_span ~add_data_to_span ~message
~metric
~shutdown:(fun () -> on_shutdown ())
() ))
in
coll, fun () -> Queue.fold (fun acc x -> x :: acc) [] log |> List.rev
let dump events =
List.iter
(function
| `Enter s -> Printf.printf "enter(%s)\n" s
| `Exit -> print_endline "exit"
| `Msg s -> Printf.printf "msg(%s)\n" s
| `Metric (n, v) -> Printf.printf "metric(%s,%s)\n" n v)
events
(* current_level acts as a ceiling: events with level <= current_level pass.
Level order: Error < Warning < Info < Debug1 < Debug2 < Debug3 < Trace
With current_level=Info: Error, Warning, Info pass; Debug1..Trace are filtered. *)
let () =
print_endline "=== level filtering ===";
let coll, get = make_recorder () in
Trace.set_current_level Trace.Level.Info;
let@ () = Trace.with_setup_collector coll in
let@ _ =
Trace.with_span ~level:Trace.Level.Error ~__FILE__ ~__LINE__ "error-span"
in
let@ _ =
Trace.with_span ~level:Trace.Level.Info ~__FILE__ ~__LINE__ "info-span"
in
let@ _ =
Trace.with_span ~level:Trace.Level.Debug1 ~__FILE__ ~__LINE__ "debug-span"
in
Trace.message ~level:Trace.Level.Warning "warn-msg";
Trace.message ~level:Trace.Level.Trace "trace-msg";
dump (get ());
Trace.set_current_level Trace.Level.Trace
(* manual enter/exit round-trip
Verify exit_span is called when using enter_span/exit_span directly. *)
let () =
print_endline "=== manual enter/exit ===";
let coll, get = make_recorder () in
let@ () = Trace.with_setup_collector coll in
let sp = Trace.enter_span ~__FILE__ ~__LINE__ "manual" in
Trace.exit_span sp;
dump (get ())
(* exception safety in with_span
The span must be exited even when the body raises. *)
let () =
print_endline "=== exception safety ===";
let coll, get = make_recorder () in
let@ () = Trace.with_setup_collector coll in
(try Trace.with_span ~__FILE__ ~__LINE__ "risky" @@ fun _ -> raise Exit
with Exit -> ());
dump (get ())
(* no-collector behavior
All operations are no-ops; messagef's thunk must not be called. *)
let () =
print_endline "=== no collector ===";
assert (not (Trace.enabled ()));
let sp = Trace.enter_span ~__FILE__ ~__LINE__ "noop" in
assert (sp == Trace.Collector.dummy_span);
Trace.exit_span sp;
let@ sp = Trace.with_span ~__FILE__ ~__LINE__ "noop2" in
assert (sp == Trace.Collector.dummy_span);
Trace.message "ignored";
Trace.counter_int "ignored" 42;
let called = ref false in
Trace.messagef (fun k ->
called := true;
k "ignored");
assert (not !called);
print_endline "ok"
(* double setup_collector
Installing a second collector while one is active raises Invalid_argument. *)
let () =
print_endline "=== double setup ===";
let coll, _ = make_recorder () in
let coll2, _ = make_recorder () in
let@ () = Trace.with_setup_collector coll in
match Trace.setup_collector coll2 with
| exception Invalid_argument msg -> Printf.printf "caught: %s\n" msg
| () -> assert false
(* counter_float and metric *)
let () =
print_endline "=== metrics ===";
let coll, get = make_recorder () in
let@ () = Trace.with_setup_collector coll in
Trace.counter_int "my_int" 42;
Trace.counter_float "my_float" 3.14;
dump (get ())
(* with_setup_collector exception safety
shutdown must be called even when the body raises. *)
let () =
print_endline "=== with_setup_collector exception safety ===";
let shutdown_called = ref false in
let coll, _ =
make_recorder ~on_shutdown:(fun () -> shutdown_called := true) ()
in
(try Trace.with_setup_collector coll @@ fun () -> raise Exit with Exit -> ());
Printf.printf "shutdown called: %b\n" !shutdown_called

View file

@ -1,3 +1,5 @@
module Trace = Trace_core
let ( let@ ) = ( @@ )
let main () =

164
test/t_runtime_events.ml Normal file
View file

@ -0,0 +1,164 @@
(** Test program for the Runtime_events backend.
This demonstrates and tests the Runtime_events backend by: 1. Emitting trace
events 2. Subscribing to the ringbuffer 3. Collecting all events 4.
Verifying expected events were emitted *)
let ( let@ ) = ( @@ )
(* Event types we'll collect *)
type collected_event =
| Span_enter of string
| Span_exit of string
| Message of string
| Metric_int of string * int
| Metric_float of string * float
(* Simple recursive function to generate some trace activity *)
let rec fib x =
let%trace () = "fib" in
if x <= 2 then
1
else
fib (x - 1) + fib (x - 2)
(* Function with explicit span *)
let do_work () =
Trace_core.with_span ~__FILE__ ~__LINE__ "do_work" @@ fun _sp ->
Trace_core.message "Starting work";
Trace_core.counter_int "work_units" 100;
let result = fib 10 in
Trace_core.messagef (fun k -> k "Computed fib(10) = %d" result);
Trace_core.counter_int "work_units" 200;
result
(* Subscribe to runtime events and collect them *)
let collect_events () =
let events = ref [] in
(* Create a cursor to read from our own process *)
let cursor = Runtime_events.create_cursor None in
(* Set up callbacks *)
let callbacks =
Runtime_events.Callbacks.create ()
(* Register callbacks for our custom events using type values *)
|> Runtime_events.Callbacks.add_user_event
Trace_runtime_events.String_type.ty (fun _domain_id _ts tag name ->
match Runtime_events.User.tag tag with
| Trace_runtime_events.Events.Tag_span_enter ->
events := Span_enter name :: !events
| Trace_runtime_events.Events.Tag_span_exit ->
events := Span_exit name :: !events
| Trace_runtime_events.Events.Tag_message ->
events := Message name :: !events
| _ -> ())
|> Runtime_events.Callbacks.add_user_event
Trace_runtime_events.String_int.ty
(fun _domain_id _ts tag (name, value) ->
match Runtime_events.User.tag tag with
| Trace_runtime_events.Events.Tag_metric_int ->
events := Metric_int (name, value) :: !events
| _ -> ())
|> Runtime_events.Callbacks.add_user_event
Trace_runtime_events.String_float.ty
(fun _domain_id _ts tag (name, value) ->
match Runtime_events.User.tag tag with
| Trace_runtime_events.Events.Tag_metric_float ->
events := Metric_float (name, value) :: !events
| _ -> ())
in
(* Read all events from the ringbuffer *)
let _lost_events = Runtime_events.read_poll cursor callbacks None in
List.rev !events
let () =
(* Initialize the Runtime_events backend with start_events=false
so we can manually control when to start *)
Trace_runtime_events.setup ~start_events:false ();
(* Start runtime events *)
Runtime_events.start ();
(* Set process and thread names *)
Trace_core.set_process_name "test";
Trace_core.set_thread_name "main";
(* Do some traced work *)
let result = do_work () in
Printf.eprintf "result: %d\n" result;
(* Collect events from the ringbuffer *)
let events = collect_events () in
Printf.eprintf "\ncollected %d events:\n" (List.length events);
List.iter
(fun ev ->
match ev with
| Span_enter name -> Printf.eprintf " - span enter: %s\n" name
| Span_exit name -> Printf.eprintf " - span exit: %s\n" name
| Message msg -> Printf.eprintf " - message: %s\n" msg
| Metric_int (name, value) ->
Printf.eprintf " - metric int: %s = %d\n" name value
| Metric_float (name, value) ->
Printf.eprintf " - metric float: %s = %f\n" name value)
events;
(* Verify expected events *)
let has_do_work_enter =
List.exists
(function
| Span_enter "do_work" -> true
| _ -> false)
events
in
let has_do_work_exit =
List.exists
(function
| Span_exit "do_work" -> true
| _ -> false)
events
in
let has_fib_spans =
List.filter
(function
| Span_enter "fib" | Span_exit "fib" -> true
| _ -> false)
events
in
let has_starting_work =
List.exists
(function
| Message "Starting work" -> true
| _ -> false)
events
in
let has_metrics =
List.filter
(function
| Metric_int ("work_units", _) -> true
| _ -> false)
events
in
Printf.eprintf "\nVerification:\n";
Printf.eprintf " - do_work span enter: %b\n" has_do_work_enter;
Printf.eprintf " - do_work span exit: %b\n" has_do_work_exit;
Printf.eprintf " - fib spans (enter+exit): %d\n" (List.length has_fib_spans);
Printf.eprintf " - 'Starting work' message: %b\n" has_starting_work;
Printf.eprintf " - work_units metrics: %d\n" (List.length has_metrics);
(* Check assertions *)
assert has_do_work_enter;
assert has_do_work_exit;
assert (List.length has_fib_spans = 218);
assert has_starting_work;
assert (List.length has_metrics = 2);
Printf.eprintf "\nall good :-)\n";
Trace_core.shutdown ()

21
test/tls/dune Normal file
View file

@ -0,0 +1,21 @@
(executable
(name t_tls)
(modules t_tls)
(libraries
trace
; avoid using a recent dune with `enabled-if`, by just using `select` instead.
; the dummy case just echoes back the expected file.
(select
t_tls.ml
from
(trace.thread-local-storage -> t_tls.real.ml)
(-> t_tls.quine.ml))))
(rule
(alias runtest)
(action
(progn
(with-stdout-to
t_tls.output
(run %{exe:t_tls.exe} %{dep:t_tls.expected}))
(diff t_tls.expected t_tls.output))))

5
test/tls/t_tls.expected Normal file
View file

@ -0,0 +1,5 @@
=== ambient span (TLS) ===
before any span: none
in outer: outer
in inner: inner
after inner exits: outer

10
test/tls/t_tls.quine.ml Normal file
View file

@ -0,0 +1,10 @@
(* When trace.thread-local-storage is unavailable, echo the expected file
so the diff always passes. The file is passed as argv[1] by the dune rule. *)
let () =
let ic = open_in Sys.argv.(1) in
(try
while true do
print_char (input_char ic)
done
with End_of_file -> ());
close_in ic

54
test/tls/t_tls.real.ml Normal file
View file

@ -0,0 +1,54 @@
(* Test ambient span tracking via thread-local-storage provider *)
let ( let@ ) = ( @@ )
(* Unique span type so we can identify spans by name *)
type Trace_core.span += Named of string
let make_recorder () =
let open Trace_core.Collector in
let cbs =
Callbacks.make
~enter_span:(fun
()
~__FUNCTION__:_
~__FILE__:_
~__LINE__:_
~level:_
~params:_
~data:_
~parent:_
name
-> Named name)
~exit_span:(fun () _sp -> ())
~add_data_to_span:(fun () _sp _data -> ())
~message:(fun () ~level:_ ~params:_ ~data:_ ~span:_ _msg -> ())
~metric:(fun () ~level:_ ~params:_ ~data:_ _name _m -> ())
()
in
C_some ((), cbs)
let current_name () =
match Trace_core.current_span () with
| None -> "none"
| Some (Named s) -> s
| Some _ -> "<other>"
let () =
print_endline "=== ambient span (TLS) ===";
Trace_thread_local_storage.setup ();
let coll = make_recorder () in
let@ () = Trace_core.with_setup_collector coll in
Printf.printf "before any span: %s\n" (current_name ());
let@ _outer = Trace_core.with_span ~__FILE__ ~__LINE__ "outer" in
Printf.printf "in outer: %s\n" (current_name ());
(* inner span is scoped to just the one printf *)
(let@ _inner = Trace_core.with_span ~__FILE__ ~__LINE__ "inner" in
ignore _inner;
Printf.printf "in inner: %s\n" (current_name ()));
(* inner has exited, outer span is restored *)
Printf.printf "after inner exits: %s\n" (current_name ())

View file

@ -1,6 +1,6 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.11"
version: "0.12"
synopsis:
"A high-performance backend for trace, emitting a Fuchsia trace into a file"
maintainer: ["Simon Cruanes"]

37
trace-runtime-events.opam Normal file
View file

@ -0,0 +1,37 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.12"
synopsis:
"A simple collector relying on runtime-events for OCaml 5. Some assembly required."
maintainer: ["Simon Cruanes"]
authors: ["Simon Cruanes"]
license: "MIT"
tags: ["trace" "tracing" "trace" "runtime-events"]
homepage: "https://github.com/ocaml-tracing/ocaml-trace"
bug-reports: "https://github.com/ocaml-tracing/ocaml-trace/issues"
depends: [
"ocaml" {>= "5.1"}
"trace" {= version}
"ppx_trace" {= version & with-test}
"base-bigarray"
"base-unix"
"dune" {>= "2.9"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"--promote-install-files=false"
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
["dune" "install" "-p" name "--create-install-files" name]
]
dev-repo: "git+https://github.com/ocaml-tracing/ocaml-trace.git"

View file

@ -1,6 +1,6 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.11"
version: "0.12"
synopsis:
"A simple backend for trace, emitting Catapult/TEF JSON into a file"
maintainer: ["Simon Cruanes"]

View file

@ -1,6 +1,6 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "0.11"
version: "0.12"
synopsis:
"A lightweight stub for tracing/observability, agnostic in how data is collected"
description: """
@ -21,6 +21,7 @@ depends: [
]
depopts: [
"unix"
"thread-local-storage" {>= "0.2"}
"mtime" {>= "2.0"}
]
build: [