refactor: avoid the cursed stdlib Trace module by adding trace.core

this way, we can actually use only `trace.core` when we also expect to
use compiler-libs.toplevel (which contains a naked `Trace` module, which
would cause .cmi collisions). The library `trace` still exists, and just
forwards to `trace.core`.
This commit is contained in:
Simon Cruanes 2023-06-12 13:12:41 -04:00
parent c7a25a1618
commit ee2e5dd651
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
9 changed files with 130 additions and 122 deletions

12
src/core/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(name trace_core)
(public_name trace.core)
(synopsis "Lightweight stub for tracing")
)
(rule
(targets atomic_.ml)
(action
(with-stdout-to %{targets}
(run ./gen/gen.exe --ocaml %{ocaml_version} --atomic))))

115
src/core/trace_core.ml Normal file
View file

@ -0,0 +1,115 @@
include Types
module A = Atomic_
module Collector = Collector
type collector = (module Collector.S)
(** Global collector. *)
let collector : collector option A.t = A.make None
let[@inline] enabled () =
match A.get collector with
| None -> false
| Some _ -> true
let enter_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
~__LINE__ ?(data = fun () -> []) name : span =
let data = data () in
C.enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
let[@inline] enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name : span =
match A.get collector with
| None -> Collector.dummy_span
| Some coll ->
enter_span_collector_ coll ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
let[@inline] exit_span span : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.exit_span span
let with_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
~__LINE__ ?(data = fun () -> []) name f =
let data = data () in
let sp = C.enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ~data name in
match f sp with
| x ->
C.exit_span sp;
x
| exception exn ->
let bt = Printexc.get_raw_backtrace () in
C.exit_span sp;
Printexc.raise_with_backtrace exn bt
let[@inline] with_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f =
match A.get collector with
| None ->
(* fast path: no collector, no span *)
f Collector.dummy_span
| Some collector ->
with_span_collector_ collector ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
f
let message_collector_ (module C : Collector.S) ?span ?(data = fun () -> []) msg
: unit =
let data = data () in
C.message ?span ~data msg
let[@inline] message ?span ?data msg : unit =
match A.get collector with
| None -> ()
| Some coll -> message_collector_ coll ?span ?data msg
let messagef ?span ?data k =
match A.get collector with
| None -> ()
| Some (module C) ->
k (fun fmt ->
Format.kasprintf
(fun str ->
let data =
match data with
| None -> []
| Some f -> f ()
in
C.message ?span ~data str)
fmt)
let counter_int name n : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.counter_int name n
let counter_float name f : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.counter_float name f
let set_thread_name name : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.name_thread name
let set_process_name name : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.name_process name
let setup_collector c : unit =
while
let cur = A.get collector in
match cur with
| Some _ -> invalid_arg "trace: collector already present"
| None -> not (A.compare_and_set collector cur (Some c))
do
()
done
let shutdown () =
match A.exchange collector None with
| None -> ()
| Some (module C) -> C.shutdown ()
module Internal_ = struct
module Atomic_ = Atomic_
end

View file

@ -1,11 +1,6 @@
(library (library
(name trace)
(public_name trace) (public_name trace)
(synopsis "Lightweight stub for tracing") (synopsis "Lightweight stub for tracing")
(name trace) (libraries trace.core)
) )
(rule
(targets atomic_.ml)
(action
(with-stdout-to %{targets}
(run ./gen/gen.exe --ocaml %{ocaml_version} --atomic))))

View file

@ -1,115 +1 @@
include Types include Trace_core
module A = Atomic_
module Collector = Collector
type collector = (module Collector.S)
(** Global collector. *)
let collector : collector option A.t = A.make None
let[@inline] enabled () =
match A.get collector with
| None -> false
| Some _ -> true
let enter_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
~__LINE__ ?(data = fun () -> []) name : span =
let data = data () in
C.enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
let[@inline] enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name : span =
match A.get collector with
| None -> Collector.dummy_span
| Some coll ->
enter_span_collector_ coll ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
let[@inline] exit_span span : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.exit_span span
let with_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
~__LINE__ ?(data = fun () -> []) name f =
let data = data () in
let sp = C.enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ~data name in
match f sp with
| x ->
C.exit_span sp;
x
| exception exn ->
let bt = Printexc.get_raw_backtrace () in
C.exit_span sp;
Printexc.raise_with_backtrace exn bt
let[@inline] with_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f =
match A.get collector with
| None ->
(* fast path: no collector, no span *)
f Collector.dummy_span
| Some collector ->
with_span_collector_ collector ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
f
let message_collector_ (module C : Collector.S) ?span ?(data = fun () -> []) msg
: unit =
let data = data () in
C.message ?span ~data msg
let[@inline] message ?span ?data msg : unit =
match A.get collector with
| None -> ()
| Some coll -> message_collector_ coll ?span ?data msg
let messagef ?span ?data k =
match A.get collector with
| None -> ()
| Some (module C) ->
k (fun fmt ->
Format.kasprintf
(fun str ->
let data =
match data with
| None -> []
| Some f -> f ()
in
C.message ?span ~data str)
fmt)
let counter_int name n : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.counter_int name n
let counter_float name f : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.counter_float name f
let set_thread_name name : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.name_thread name
let set_process_name name : unit =
match A.get collector with
| None -> ()
| Some (module C) -> C.name_process name
let setup_collector c : unit =
while
let cur = A.get collector in
match cur with
| Some _ -> invalid_arg "trace: collector already present"
| None -> not (A.compare_and_set collector cur (Some c))
do
()
done
let shutdown () =
match A.exchange collector None with
| None -> ()
| Some (module C) -> C.shutdown ()
module Internal_ = struct
module Atomic_ = Atomic_
end