mirror of
https://github.com/ocaml-tracing/ocaml-trace.git
synced 2026-03-08 03:47:57 -04:00
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
parent
c7a25a1618
commit
ee2e5dd651
9 changed files with 130 additions and 122 deletions
12
src/core/dune
Normal file
12
src/core/dune
Normal 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
115
src/core/trace_core.ml
Normal 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
|
||||
9
src/dune
9
src/dune
|
|
@ -1,11 +1,6 @@
|
|||
(library
|
||||
(name trace)
|
||||
(public_name trace)
|
||||
(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))))
|
||||
|
|
|
|||
116
src/trace.ml
116
src/trace.ml
|
|
@ -1,115 +1 @@
|
|||
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
|
||||
include Trace_core
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue