diff --git a/src/collector.ml b/src/core/collector.ml similarity index 100% rename from src/collector.ml rename to src/core/collector.ml diff --git a/src/core/dune b/src/core/dune new file mode 100644 index 0000000..2240246 --- /dev/null +++ b/src/core/dune @@ -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)))) diff --git a/src/gen/dune b/src/core/gen/dune similarity index 100% rename from src/gen/dune rename to src/core/gen/dune diff --git a/src/gen/gen.ml b/src/core/gen/gen.ml similarity index 100% rename from src/gen/gen.ml rename to src/core/gen/gen.ml diff --git a/src/core/trace_core.ml b/src/core/trace_core.ml new file mode 100644 index 0000000..c8b5209 --- /dev/null +++ b/src/core/trace_core.ml @@ -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 diff --git a/src/trace.mli b/src/core/trace_core.mli similarity index 100% rename from src/trace.mli rename to src/core/trace_core.mli diff --git a/src/types.ml b/src/core/types.ml similarity index 100% rename from src/types.ml rename to src/core/types.ml diff --git a/src/dune b/src/dune index f26ef78..82c7d7f 100644 --- a/src/dune +++ b/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)))) diff --git a/src/trace.ml b/src/trace.ml index c8b5209..5684517 100644 --- a/src/trace.ml +++ b/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