diff --git a/README.md b/README.md index 954ffdc..10d1df2 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ # Catapult [![build](https://github.com/imandra-ai/catapult/actions/workflows/main.yml/badge.svg)](https://github.com/imandra-ai/catapult/actions/workflows/main.yml) -This is a tracing library for OCaml, based on the +This is a collection of tracing _backends_ for +[ocaml-trace](https://github.com/c-cube/ocaml-trace/), ultimately producing [Catapult/TEF](https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/) trace format. @@ -12,12 +13,46 @@ The traces are `.json` files (or compressed `.json.gz`). They can be viewed in: ## Usage -The core library is `catapult`. It's a small set of probes that can be -inserted in your code, by hand (with meaningful messages if needed). +Instrument your code using [ocaml-trace](https://github.com/c-cube/ocaml-trace/). +In the program's entry point, use one of the Catapult libraries +backend to forward events from [Trace] into the place of your choice. + +An example can be found in 'examples/heavy/heavy.ml' + +## sqlite + +To collect data directly into a local Sqlite database, use something like: + +```ocaml +let main () =̵ + … + let@ writer = Catapult_sqlite.Writer.with_ ~file:!db ~sync:!sync () in + Trace.setup_collector (Catapult_sqlite.trace_collector_of_writer writer); + + … + (* do the actual work here *) +``` + +(assuming this is in scope: +```ocaml +let (let@) = (@@) +``` +) + + +## network client + +The library `catapult-client` provides a tracing backend that forwards all events +(messages, traces, metrics) to a network daemon. The daemon is in the +`catapult-daemon` package. + +The traces can be listed and retrieved using the `catapult-conv` program that +comes with `catapult-sqlite`. ## Systemd -An example systemd service file can be found in `src/data/catapult-daemon.service`. +An example systemd service file for this daemon can +be found in `src/data/catapult-daemon.service`. ```systemd [Unit] @@ -36,29 +71,30 @@ RestartSec=10 WantedBy=default.target ``` -### Example: "basic" +## Example: "basic" A very stupid example (in `examples/basic/basic.ml`), is: ```ocaml -module Tr = Catapult.Tracing +let (let@) = (@@) let spf = Printf.sprintf let rec fake_trace depth = if depth>=3 then () else ( (* the probe is here *) - Tr.with_ "step" @@ fun () -> + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "step" in Thread.delay 0.1; Printf.printf "fake (depth=%d)\n%!" depth; fake_trace (depth+1); Thread.delay 0.2; - Tr.instant "iteration.done" ~args:["depth", `Int depth]; + Trace.message "iteration.done" ~data:(fun () -> ["depth", `Int depth]); ) let () = - (* this just logs into a file. It's not thread safe nor multiprocess-safe. *) - Catapult_file.with_setup @@ fun () -> + (* address of daemon *) + let addr = Catapult_client.addr_of_string_exn "tcp://localhost:1234" in + let@() = Catapult_client.with_ ~addr () in let n = try int_of_string (Sys.getenv "N") with _ -> 10 in Printf.printf "run %d iterations\n%!" n; @@ -67,14 +103,10 @@ let () = done ``` -If run with the `TRACE=1` environment variable set, this will just produce a -basic trace in the file "trace.json" (otherwise probes will do nothing and keep -a minimal overhead). - Once opened in chrome://tracing, the trace looks like this: ![viewer screenshot](media/viewer1.png) -### Example: "heavy" +## Example: "heavy" A more heavy example (used to benchmark a bit the tracing), is in `examples/heavy`. @@ -87,7 +119,7 @@ $ ./daemon.sh Then in another terminal: ``` -$ ./heavy.sh -n=1 --mode=net -j 2 +$ ./heavy.sh -n=1 --mode=net -j 2 --trace-id=mytrace use net client tcp://127.0.0.1:6981 run 1 iterations iteration 1 @@ -96,12 +128,12 @@ run 1 iterations iteration 1 # list traces -$ catapult-conv -… -catapult-2022-2-16-16-36-18-pid-3229175.dbo +$ catapult-conv -l +[…] +mytrace.db -# convert last trace into a json.gz file -$ catapult-conv catapult-2022-2-16-16-36-18-pid-3229175.db +# convert last trace into a file (trace.json.gz) +$ catapult-conv mytrace.db $ ls -lh trace.json.gz -rw-r--r-- 1 simon simon 374K Feb 16 11:38 trace.json.gz diff --git a/catapult.opam b/catapult.opam index 6774728..54d045f 100644 --- a/catapult.opam +++ b/catapult.opam @@ -10,7 +10,7 @@ bug-reports: "https://github.com/imandra-ai/catapult/issues" depends: [ "dune" {>= "2.7"} "base-threads" - "base-unix" + "trace" {>= "0.3"} "odoc" {with-doc} "ocaml" {>= "4.08"} ] diff --git a/dune-project b/dune-project index 2dd9f0e..454c056 100644 --- a/dune-project +++ b/dune-project @@ -15,7 +15,7 @@ mtime) (depends base-threads - base-unix + (trace (>= 0.3)) (odoc :with-doc) (ocaml (>= "4.08")))) diff --git a/examples/file/basic.ml b/examples/file/basic.ml deleted file mode 100644 index 6556dce..0000000 --- a/examples/file/basic.ml +++ /dev/null @@ -1,25 +0,0 @@ -module Tr = Catapult.Tracing - -let spf = Printf.sprintf - -let rec fake_trace depth = - if depth >= 3 then - () - else - Tr.with_ "step" @@ fun () -> - Thread.delay 0.1; - Printf.printf "fake (depth=%d)\n%!" depth; - fake_trace (depth + 1); - Thread.delay 0.2; - Tr.instant "iteration.done" ~args:[ "depth", `Int depth ] - -let () = - Catapult_file.with_setup @@ fun () -> - let n = try int_of_string (Sys.getenv "N") with _ -> 10 in - Printf.printf "run %d iterations\n%!" n; - - for _i = 1 to n do - fake_trace 0; - - if _i mod 3 = 0 then Gc.major () - done diff --git a/examples/file/dune b/examples/file/dune deleted file mode 100644 index 4c96800..0000000 --- a/examples/file/dune +++ /dev/null @@ -1,4 +0,0 @@ -(executable - (name basic) - (optional) - (libraries threads.posix catapult catapult-file)) diff --git a/examples/heavy/dune b/examples/heavy/dune index a920e1e..ee849fa 100644 --- a/examples/heavy/dune +++ b/examples/heavy/dune @@ -1,5 +1,5 @@ (executable (name heavy) (optional) - (libraries threads.posix unix catapult catapult-file catapult-sqlite + (libraries threads.posix trace unix catapult catapult-sqlite catapult-client)) diff --git a/examples/heavy/heavy.ml b/examples/heavy/heavy.ml index b01d1c6..b8cbe4d 100644 --- a/examples/heavy/heavy.ml +++ b/examples/heavy/heavy.ml @@ -1,6 +1,6 @@ -module Tr = Catapult.Tracing -open Tr.Syntax +module Tr = Trace +let ( let@ ) = ( @@ ) let spf = Printf.sprintf let rec fib n = @@ -10,10 +10,14 @@ let rec fib n = fib (n - 1) + fib (n - 2) let do_work () = - let@ () = Tr.with_ "dowork" in + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "dowork" in for j = 0 to 5_000 do let n = 15 + (j mod 5) in - let@ () = Tr.with_ ~args:[ "j", `Int j; "fib n", `Int n ] "step" in + let@ _sp = + Trace.with_span ~__FILE__ ~__LINE__ + ~data:(fun () -> [ "j", `Int j; "fib n", `Int n ]) + "step" + in ignore (Sys.opaque_identity (fib n) : int) done @@ -21,7 +25,7 @@ let run n = Printf.printf "run %d iterations\n%!" n; for i = 1 to n do - let@ () = Tr.with_ "main iter" in + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "main iter" in Printf.printf "iteration %d\n%!" i; for j = 1 to 4 do do_work () @@ -29,11 +33,10 @@ let run n = if i mod 3 = 0 then Gc.major () done -type mode = Net | File | Db +type mode = Net | Db let mode_of_str = function | "net" -> Net - | "file" -> File | "db" -> Db | s -> failwith ("unknown mode: " ^ s) @@ -45,7 +48,7 @@ let sync_of_str = function let () = let n = ref 10 in - let mode = ref File in + let mode = ref Db in let file = ref "trace.json" in let addr = ref Catapult_client.default_endpoint in let j = ref 1 in @@ -59,7 +62,7 @@ let () = "-n", Arg.Set_int n, " number of iterations"; "-o", Arg.Set_string file, " output file"; ( "--mode", - Arg.Symbol ([ "net"; "file"; "db" ], fun s -> mode := mode_of_str s), + Arg.Symbol ([ "net"; "db" ], fun s -> mode := mode_of_str s), " serialization mode" ); "--worker", Arg.Set worker, " act as a worker"; ( "--db", @@ -83,19 +86,10 @@ let () = in Arg.parse opts (fun _ -> ()) "heavy"; - if !worker then - Catapult_sqlite.set_multiproc true - else if (not !worker) && !j > 1 then ( - Catapult_sqlite.set_multiproc true; - + if (not !worker) && !j > 1 then ( (match !mode with - | Net -> - if !trace_id <> "" then Catapult_client.set_trace_id !trace_id; - trace_id := Catapult_client.get_trace_id () - | Db -> - if !trace_id <> "" then Catapult_sqlite.set_trace_id !trace_id; - trace_id := Catapult_sqlite.get_trace_id () - | File -> ()); + | Net -> () + | Db -> failwith "cannot use -j with a sqlite backend"); let bin_name = Sys.executable_name in for _k = 2 to !j do @@ -115,16 +109,17 @@ let () = | Net -> Printf.printf "use net client %s\n%!" (Catapult_client.Endpoint_address.to_string !addr); - if !trace_id <> "" then Catapult_client.set_trace_id !trace_id; - Catapult_client.set_endpoint !addr; - Catapult_client.with_setup run + let trace_id = + if !trace_id <> "" then + Some !trace_id + else + None + in + let@ conn = Catapult_client.with_conn ?trace_id ~addr:!addr () in + Trace_core.setup_collector (Catapult_client.trace_collector_of_conn conn); + run () | Db -> Printf.printf "use sqlite backend %s\n%!" !db; - if !trace_id <> "" then Catapult_sqlite.set_trace_id !trace_id; - Catapult_sqlite.set_file !db; - Catapult_sqlite.set_sqlite_sync !sync; - Catapult_sqlite.with_setup run - | File -> - Printf.printf "write to file %S\n%!" !file; - Catapult_file.set_file !file; - Catapult_file.with_setup run + let@ writer = Catapult_sqlite.Writer.with_ ~file:!db ~sync:!sync () in + Trace.setup_collector (Catapult_sqlite.trace_collector_of_writer writer); + run () diff --git a/src/client/backend.ml b/src/client/backend.ml index 2b995b9..cb819a9 100644 --- a/src/client/backend.ml +++ b/src/client/backend.ml @@ -1,22 +1,21 @@ open Catapult_utils module P = Catapult -module Tracing = P.Tracing type event = Ser.Event.t module type ARG = sig - val conn : Connections.t + val conn : Connection.t end module Make (A : ARG) : P.BACKEND = struct let conn = A.conn - let teardown () = Connections.close conn + let teardown () = Connection.close conn let[@inline] opt_map_ f = function | None -> None | Some x -> Some (f x) - let conv_arg (key, a) = + let conv_arg (key, (a : [< `Float of float | Trace.user_data ])) = let open Ser in let value = match a with @@ -24,7 +23,7 @@ module Make (A : ARG) : P.BACKEND = struct | `String s -> Arg_value.String s | `Float f -> Arg_value.Float64 f | `Bool b -> Arg_value.Bool b - | `Null -> Arg_value.Void + | `None -> Arg_value.Void in { Arg.key; value } @@ -50,10 +49,16 @@ module Make (A : ARG) : P.BACKEND = struct in { Event.id; name; ph; tid; pid; cat; ts_us; args; stack; dur; extra } in - Connections.send_msg conn ~pid ~now:ts_us ev + Connection.send_msg conn ~pid ~now:ts_us ev let tick () = let now = P.Clock.now_us () in let pid = Unix.getpid () in Gc_stats.maybe_emit ~now ~pid () end + +let make (c : Connection.t) : P.backend = + let module M = Make (struct + let conn = c + end) in + (module M) diff --git a/src/client/backend.mli b/src/client/backend.mli index a481520..e5741a8 100644 --- a/src/client/backend.mli +++ b/src/client/backend.mli @@ -1,5 +1 @@ -module type ARG = sig - val conn : Connections.t -end - -module Make (_ : ARG) : Catapult.BACKEND +val make : Connection.t -> Catapult.backend diff --git a/src/client/catapult_client.ml b/src/client/catapult_client.ml index 3c77c48..14acdd4 100644 --- a/src/client/catapult_client.ml +++ b/src/client/catapult_client.ml @@ -1,68 +1,26 @@ -module P = Catapult -module Tracing = P.Tracing -module Endpoint_address = Catapult_utils.Endpoint_address - -let trace_id = ref (try Sys.getenv "TRACE_ID" with _ -> "") -let set_trace_id s = trace_id := s - -(* try to make a non-stupid default id, based on PID + date. - This is not perfect, use a UUID4 if possible. *) -let[@inline never] invent_trace_id_ () : string = - let pid = Unix.getpid () in - let now = Unix.gettimeofday () in - let tm = Unix.gmtime now in - Printf.sprintf "catapult-%d-%02d-%02d-%02d-%02d-%02d-pid-%d" - (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min - tm.tm_sec pid +(** Backend for Catapult, using a connection to the daemon. +*) -let[@inline] get_trace_id () = - if !trace_id = "" then trace_id := invent_trace_id_ (); - !trace_id +module Endpoint_address = Catapult_utils.Endpoint_address +module Backend = Backend +module Connection = Connection let default_endpoint = Endpoint_address.default - -let endpoint = - ref - (try Endpoint_address.of_string_exn (Sys.getenv "TRACE_ENDPOINT") - with _ -> default_endpoint) - -let set_endpoint e = endpoint := e -let get_endpoint () = !endpoint -let set_tcp_endpoint h p = set_endpoint (Endpoint_address.Tcp (h, p)) -let set_ipc_endpoint file = set_endpoint (Endpoint_address.Unix file) -let tef_in_env () = List.mem (Sys.getenv_opt "TRACE") [ Some "1"; Some "true" ] - -let mk_lazy_enable getenv = - let r = ref false in - let enabled_thunk = lazy (!r || getenv ()) in - let[@inline] enabled () = Lazy.force enabled_thunk in - let enable () = if not !r then r := true in - enable, enabled - -let enable, enabled = mk_lazy_enable tef_in_env - -let setup_ = - lazy - (if enabled () then ( - at_exit P.Control.teardown; - let trace_id = get_trace_id () in - let conn = Connections.create ~addr:!endpoint ~trace_id () in - let module B = Backend.Make (struct - let conn = conn - end) in - let backend = (module B : P.BACKEND) in - P.Control.setup (Some backend) - )) - -let setup () = Lazy.force setup_ -let teardown = P.Tracing.Control.teardown - -let with_setup f = - setup (); - try - let x = f () in - teardown (); - x - with e -> - teardown (); - raise e +let with_conn = Connection.with_ +let backend_of_conn : Connection.t -> Catapult.backend = Backend.make + +(** Parse a remote address. *) +let addr_of_string_exn : string -> Endpoint_address.t = + Endpoint_address.of_string_exn + +(** Obtain a trace collector from a network connection *) +let trace_collector_of_conn : Connection.t -> Trace_core.collector = + fun conn -> backend_of_conn conn |> Catapult.trace_collector_of_backend + +(** [with_ ~addr () f] runs [f()] in an environment where a connection + to [addr] has been established and is used to forward + tracing events to the remote daemon. *) +let with_ ~addr ?trace_id () (f : unit -> 'a) : 'a = + Connection.with_ ~addr ?trace_id () @@ fun conn -> + Trace_core.setup_collector (trace_collector_of_conn conn); + f () diff --git a/src/client/catapult_client.mli b/src/client/catapult_client.mli deleted file mode 100644 index 9323ab6..0000000 --- a/src/client/catapult_client.mli +++ /dev/null @@ -1,28 +0,0 @@ -(** Backend for Catapult, using a connection to the daemon. - - - - The tracing is enabled/disabled via "TRACE=1". - - The trace identifier is specified in "TRACE_ID" (as a unique string ID). - - The daemon's address is either "TRACE_ENDPOINT=ipc://" - or "TRACE_ENDPOINT=tcp://host:port". - -*) - -include Catapult.IMPL -module Endpoint_address = Catapult_utils.Endpoint_address - -val enable : unit -> unit -val enabled : unit -> bool - -val set_trace_id : string -> unit -(** Must be called before the setup. *) - -val get_trace_id : unit -> string -val default_endpoint : Endpoint_address.t -val get_endpoint : unit -> Endpoint_address.t - -val set_endpoint : Endpoint_address.t -> unit -(** Must be called before the setup. *) - -val set_tcp_endpoint : string -> int -> unit -val set_ipc_endpoint : string -> unit diff --git a/src/client/connections.ml b/src/client/connection.ml similarity index 91% rename from src/client/connections.ml rename to src/client/connection.ml index 807b190..887db39 100644 --- a/src/client/connections.ml +++ b/src/client/connection.ml @@ -1,8 +1,10 @@ open Catapult_utils module P = Catapult -module Tracing = P.Tracing module Atomic = P.Atomic_shim_ +let ( let@ ) = ( @@ ) +let default_addr = Endpoint_address.default + let connect_endpoint ctx (addr : Endpoint_address.t) : [ `Dealer ] Zmq.Socket.t = let module E = Endpoint_address in @@ -83,7 +85,7 @@ let close (self : t) = (Printexc.to_string e) ) -let create ~(addr : Endpoint_address.t) ~trace_id () : t = +let create ~(addr : Endpoint_address.t) ?(trace_id = "trace") () : t = let ctx = Zmq.Context.create () in Zmq.Context.set_io_threads ctx 6; let per_t = @@ -95,7 +97,6 @@ let create ~(addr : Endpoint_address.t) ~trace_id () : t = Gc.finalise close self; self -(* send a message. *) let send_msg (self : t) ~pid ~now (ev : Ser.Event.t) : unit = if not self.closed then ( let logger = Thread_local.get_or_create self.per_t in @@ -108,3 +109,8 @@ let send_msg (self : t) ~pid ~now (ev : Ser.Event.t) : unit = (* maybe emit GC stats as well *) Gc_stats.maybe_emit ~now:ev.ts_us ~pid:(Int64.to_int ev.pid) () ) + +let with_ ~addr ?trace_id () f = + let conn = create ~addr ?trace_id () in + let@ () = Fun.protect ~finally:(fun () -> close conn) in + f conn diff --git a/src/client/connection.mli b/src/client/connection.mli new file mode 100644 index 0000000..dee41cb --- /dev/null +++ b/src/client/connection.mli @@ -0,0 +1,11 @@ +open Catapult_utils + +type t + +val default_addr : Endpoint_address.t +val create : addr:Endpoint_address.t -> ?trace_id:string -> unit -> t +val send_msg : t -> pid:int -> now:float -> Ser.Event.t -> unit +val close : t -> unit + +val with_ : + addr:Endpoint_address.t -> ?trace_id:string -> unit -> (t -> 'a) -> 'a diff --git a/src/client/connections.mli b/src/client/connections.mli deleted file mode 100644 index 355f73e..0000000 --- a/src/client/connections.mli +++ /dev/null @@ -1,7 +0,0 @@ -open Catapult_utils - -type t - -val create : addr:Endpoint_address.t -> trace_id:string -> unit -> t -val send_msg : t -> pid:int -> now:float -> Ser.Event.t -> unit -val close : t -> unit diff --git a/src/client/dune b/src/client/dune index 16e2cc3..522ee92 100644 --- a/src/client/dune +++ b/src/client/dune @@ -2,4 +2,4 @@ (name catapult_client) (public_name catapult-client) (synopsis "Client library for the catapult daemon") - (libraries catapult catapult.utils zmq unix)) + (libraries trace.core catapult catapult.utils zmq unix trace)) diff --git a/src/core/adapt_backend.ml b/src/core/adapt_backend.ml new file mode 100644 index 0000000..5f2436d --- /dev/null +++ b/src/core/adapt_backend.ml @@ -0,0 +1,91 @@ +module Trace = Trace_core + +module type BACKEND = Backend.S +module type COLLECTOR = Trace.Collector.S + +type backend = (module BACKEND) + +open Event_type + +let pid = Unix.getpid () +let now_ = Clock.now_us + +type full_arg = [ `Float of float | Trace.user_data ] + +let span_gen_ = Atomic_shim_.make 0 + +let k_span_info : (string * [ `Sync | `Async ]) Trace.Meta_map.Key.t = + Trace.Meta_map.Key.create () + +module Mk_collector (B : BACKEND) : COLLECTOR = struct + (** actually emit an event via the backend *) + let[@inline never] emit_real_ ?ts_us ?cat ?(pid = pid) + ?(tid = Thread.self () |> Thread.id) ?stack ?args ?id ?extra ?dur name + (ev : Event_type.t) : unit = + let ts_us = + match ts_us with + | Some x -> x + | None -> now_ () + in + B.emit ~id ~pid ~cat ~tid ~ts_us ~stack ~args ~name ~ph:ev ~dur ?extra (); + () + + let with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f = + let start = now_ () in + let sp = Trace.Collector.dummy_span in + + let finally () : unit = + let now = now_ () in + let dur = now -. start in + let args = + (data + : (string * Trace_core.user_data) list + :> (string * full_arg) list) + in + emit_real_ ~args name ~ts_us:start ~dur X + in + Fun.protect ~finally (fun () -> f sp) + + let enter_manual_span ~parent ~flavor ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data + name : Trace_core.explicit_span = + let span = Int64.of_int (Atomic_shim_.fetch_and_add span_gen_ 1) in + let flavor = Option.value ~default:`Sync flavor in + let args = + (data : (string * Trace_core.user_data) list :> (string * full_arg) list) + in + (match flavor with + | `Sync -> + emit_real_ ~cat:[ "async" ] ~args name ~id:(Int64.to_string span) B + | `Async -> + emit_real_ ~cat:[ "async" ] ~args name ~id:(Int64.to_string span) A_b); + let meta = Trace_core.Meta_map.(empty |> add k_span_info (name, flavor)) in + { Trace_core.span; meta } + + let exit_manual_span (es : Trace_core.explicit_span) : unit = + let name, flavor = Trace_core.Meta_map.find_exn k_span_info es.meta in + match flavor with + | `Sync -> emit_real_ name E + | `Async -> + emit_real_ ~cat:[ "async" ] name ~id:(es.span |> Int64.to_string) A_e + + let counter_int name n : unit = emit_real_ "counter" C ~args:[ name, `Int n ] + + let counter_float name n : unit = + emit_real_ "counter" C ~args:[ name, `Float n ] + + let message ?span:_ ~data msg : unit = + let args = + (data : (string * Trace.user_data) list :> (string * full_arg) list) + in + let args = ("msg", `String msg) :: args in + emit_real_ ~args "msg" I + + let meta_ ~args name = emit_real_ ~args name M + let name_thread name = meta_ "thread_name" ~args:[ "name", `String name ] + let name_process name = meta_ "process_name" ~args:[ "name", `String name ] + let shutdown = B.teardown +end + +let[@inline] adapt (b : backend) : (module COLLECTOR) = + let module M = Mk_collector ((val b)) in + (module M) diff --git a/src/core/adapt_backend.mli b/src/core/adapt_backend.mli new file mode 100644 index 0000000..5928016 --- /dev/null +++ b/src/core/adapt_backend.mli @@ -0,0 +1,5 @@ +module type BACKEND = Backend.S +module type COLLECTOR = Trace_core.Collector.S + +val adapt : (module BACKEND) -> (module COLLECTOR) +(** Adapt a Catapult backend as a Trace collector *) diff --git a/src/core/arg.mli b/src/core/arg.mli deleted file mode 100644 index c3158e0..0000000 --- a/src/core/arg.mli +++ /dev/null @@ -1,10 +0,0 @@ -(** Custom arguments. - - These arguments can be emitted as part of most events, and can be used - to store custom data, debug messages, etc. -*) - -type t = - [ `Int of int | `String of string | `Float of float | `Bool of bool | `Null ] -(** Custum argument for events, spans, instants, etc. *) - diff --git a/src/core/backend.mli b/src/core/backend.mli index f9b9654..ce6af33 100644 --- a/src/core/backend.mli +++ b/src/core/backend.mli @@ -8,6 +8,8 @@ if no backend is installed, the tracing functions will do nothing. *) +type arg = [ `Float of float | Trace_core.user_data ] + module type S = sig val emit : id:string option -> @@ -17,7 +19,7 @@ module type S = sig pid:int -> cat:string list option -> ts_us:float -> - args:(string * Arg.t) list option -> + args:(string * [< arg ]) list option -> stack:string list option -> dur:float option -> ?extra:(string * string) list -> diff --git a/src/core/catapult.ml b/src/core/catapult.ml index bedb598..eb583a7 100644 --- a/src/core/catapult.ml +++ b/src/core/catapult.ml @@ -18,11 +18,16 @@ module type BACKEND = Backend.S module type IMPL = Impl.S -module Arg = Arg -module Control = Tracing.Control +type backend = (module BACKEND) +type arg = Backend.arg + +module Adapt_backend = Adapt_backend module Event_type = Event_type module Nil_impl = Nil_impl -module Tracing = Tracing + +(** Turn a catapult backend into a Trace collector *) +let trace_collector_of_backend : backend -> Trace_core.collector = + Adapt_backend.adapt (**/**) diff --git a/src/core/dune b/src/core/dune index da2ce51..0d139ea 100644 --- a/src/core/dune +++ b/src/core/dune @@ -1,8 +1,9 @@ (library (synopsis "Profiling system based on the Catapult format") - (modules_without_implementation backend impl arg) + (modules_without_implementation backend impl) (libraries threads + (re_export trace.core) (select clock.ml from diff --git a/src/core/tracing.ml b/src/core/tracing.ml deleted file mode 100644 index bd1d2b3..0000000 --- a/src/core/tracing.ml +++ /dev/null @@ -1,228 +0,0 @@ -module type BACKEND = Backend.S - -type backend = (module BACKEND) - -open Event_type - -let now_ = Clock.now_us - -type span_start = float - -let null_span = neg_infinity - -(* where to print events *) -let out_ : backend option ref = ref None -let[@inline] enabled () = !out_ != None - -module Control = struct - let setup b = - assert (!out_ = None); - out_ := b - - let teardown () = - match !out_ with - | None -> () - | Some (module B) -> - out_ := None; - B.teardown () -end - -let pid = Unix.getpid () - -type arg = - [ `Int of int | `String of string | `Float of float | `Bool of bool | `Null ] - -let () = - (* make sure Arg.t = arg *) - let _check_cast : Arg.t -> arg = fun x -> x in - () - -type 'a emit_fun_base = - ?pid:int -> ?tid:int -> ?args:(string * arg) list -> string -> 'a - -type 'a with_cat = ?cat:string list -> 'a -type 'a with_ts_us = ?ts_us:float -> 'a -type 'a with_stack = ?stack:string list -> 'a -type 'a emit_fun = 'a emit_fun_base with_cat with_ts_us - -(* actually emit an event via the backend *) -let[@inline never] emit_real_ (module B : BACKEND) ?ts_us ?cat ?(pid = pid) - ?(tid = Thread.self () |> Thread.id) ?stack ?args ?id ?extra ?dur name - (ev : Event_type.t) : unit = - let ts_us = - match ts_us with - | Some x -> x - | None -> now_ () - in - B.emit ~id ~pid ~cat ~tid ~ts_us ~stack ~args ~name ~ph:ev ~dur ?extra (); - () - -let[@inline] emit ?stack ?ts_us ?cat ?pid ?tid ?args name ?dur - (ev : Event_type.t) : unit = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args ?dur name ev - -let[@inline] instant ?stack ?ts_us ?cat ?pid ?tid ?args name = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args name I - -let[@inline] counter ?ts_us ?cat ?pid ?tid ?(args = []) name ~cs = - match !out_ with - | None -> () - | Some b -> - let args = List.rev_append args @@ List.map (fun (k, v) -> k, `Int v) cs in - emit_real_ b ?ts_us ?cat ?pid ?tid name ~args C - -let[@inline] meta ?ts_us ?cat ?pid ?tid ?args name = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ?cat ?pid ?tid name ?args M - -let meta_thread_name name = meta "thread_name" ~args:[ "name", `String name ] -let meta_process_name name = meta "process_name" ~args:[ "name", `String name ] - -let[@inline] begin_ () : span_start = - if !out_ == None then - null_span - else - now_ () - -let exit_with_ b ?stack ?cat ?pid ?tid ?args name start : unit = - let now = now_ () in - let dur = now -. start in - emit_real_ b ?cat ?pid ?tid ?args name ?stack ~ts_us:start ~dur X - -let[@inline] exit ?stack ?cat ?pid ?tid ?args name (sp : span_start) = - if sp == null_span then - () - else ( - match !out_ with - | None -> () - | Some b -> exit_with_ b ?stack ?cat ?pid ?tid ?args name sp - ) - -let[@inline] with1 ?cat ?pid ?tid ?args name f x = - match !out_ with - | None -> f x - | Some b -> - let start = now_ () in - (try - let y = f x in - exit_with_ b ?cat ?pid ?tid name ?args start; - y - with e -> - exit_with_ b ?cat ?pid ?tid name ?args start; - raise e) - -let[@inline] with_ ?cat ?pid ?tid ?args name f = - with1 ?cat ?pid ?tid ?args name f () - -let[@inline] with2 ?cat ?pid ?tid ?args name f x y = - with1 ?cat ?pid ?tid ?args name (fun () -> f x y) () - -let[@inline] with3 ?cat ?pid ?tid ?args name f x y z = - with1 ?cat ?pid ?tid ?args name (fun () -> f x y z) () - -let[@inline] begin' ?stack ?ts_us ?cat ?pid ?tid ?args name = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args name B - -let[@inline] exit' ?stack ?ts_us ?cat ?pid ?tid ?args name = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args name E - -let[@inline] span ?stack ?ts_us ?cat ?pid ?tid ?args name ~dur = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args ~dur name X - -let[@inline] obj_new ?stack ?ts_us ?cat ?pid ?tid ?args name ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args name ~id N - -let[@inline] obj_delete ?stack ?ts_us ?cat ?pid ?tid ?args name ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?stack ?ts_us ?cat ?pid ?tid ?args name ~id D - -let[@inline] obj_snap ?stack ?ts_us ?cat ?pid ?tid ?(args = []) name ~snapshot - ~id = - match !out_ with - | None -> () - | Some b -> - emit_real_ b ?stack ?ts_us ?cat ?pid ?tid name - ~args:(("snapshot", `String snapshot) :: args) - ~id O - -let with1_gen_ ?ts_us ?cat ?pid ?tid ?args ?id name ev1 ev2 f x = - match !out_ with - | None -> f x - | Some b -> - emit_real_ b ?ts_us ?cat ?pid ?tid ?args name ?id ev1; - (try - let y = f x in - (* exit: do not pass args *) - emit_real_ b ?ts_us ?cat ?pid ?tid name ?id ev2; - y - with e -> - emit_real_ b ?ts_us ?cat ?pid ?tid name ?id ev2; - raise e) - -let[@inline] obj_with1 ?ts_us ?cat ?pid ?tid ?args name ~id f x = - with1_gen_ ?ts_us ?cat ?pid ?tid ?args name ~id N D f x - -let[@inline] obj_with ?ts_us ?cat ?pid ?tid ?args name ~id f = - obj_with1 ?ts_us ?cat ?pid ?tid ?args name f () ~id - -let[@inline] a_begin ?ts_us ?pid ?tid ?args name ~cat ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ~cat ?pid ?tid ?args name ~id A_b - -let[@inline] a_exit ?ts_us ?pid ?tid ?args name ~cat ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ~cat ?pid ?tid ?args name ~id A_e - -let[@inline] a_snap ?ts_us ?pid ?tid ?args name ~cat ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ~cat ?pid ?tid ?args name A_n ~id - -let[@inline] a_with1 ?ts_us ?pid ?tid ?args name ~cat ~id f x = - with1_gen_ ?ts_us ~cat ?pid ?tid ?args name ~id A_b A_e f x - -let[@inline] a_with ?ts_us ?pid ?tid ?args name ~cat ~id f = - a_with1 ?ts_us ~cat ?pid ?tid ?args name f () ~id - -let[@inline] f_begin ?ts_us ?cat ?pid ?tid ?args name ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ?cat ?pid ?tid ?args name ~id F_s - -let[@inline] f_exit ?ts_us ?cat ?pid ?tid ?args name ~id = - match !out_ with - | None -> () - | Some b -> - emit_real_ b ?ts_us ?cat ?pid ?tid ?args name ~id F_f ~extra:[ "bp", "e" ] - -let[@inline] f_step ?ts_us ?cat ?pid ?tid ?args name ~id = - match !out_ with - | None -> () - | Some b -> emit_real_ b ?ts_us ?cat ?pid ?tid ?args name ~id F_t - -let[@inline] tick () = - match !out_ with - | None -> () - | Some (module B) -> B.tick () - -module Syntax = struct - let ( let@ ) x f = x f -end - -include Syntax diff --git a/src/core/tracing.mli b/src/core/tracing.mli deleted file mode 100644 index f3e8a79..0000000 --- a/src/core/tracing.mli +++ /dev/null @@ -1,108 +0,0 @@ -(** Profiling probes. - - This is the main API. The user can insert probes into their code, and - at runtime, these probes will use the {!Backend} (if present) to - emit tracing events to be replayed later. If no backend is present, - the probes will do nothing. -*) - -type backend = (module Backend.S) - -(* NOTE: this is equal to {!Arg.t} *) -type arg = - [ `Int of int | `String of string | `Float of float | `Bool of bool | `Null ] - -type 'a emit_fun_base = - ?pid:int -> ?tid:int -> ?args:(string * arg) list -> string -> 'a -(** Emitter function, without timestamp. See {!emit_fun} - for more details. *) - -type 'a with_cat = ?cat:string list -> 'a -type 'a with_ts_us = ?ts_us:float -> 'a - -type 'a with_stack = ?stack:string list -> 'a -(** Function that can take a stack trace *) - -type 'a emit_fun = 'a emit_fun_base with_cat with_ts_us -(** An emitter function. The positional string argument is the name. - - @param cat list of categories for filtering the event - @param pid the process ID - @param tid the thread ID - @param arguments list of arguments for the event, with a name for each - @param ts_us timestamp in microseconds - - @param name the name of this event -*) - -type span_start -(** Represents the beginning of a span, to emit compact spans *) - -val null_span : span_start - -val enabled : unit -> bool -(** Is tracing enabled? *) - -val emit : (?dur:float -> Event_type.t -> unit) emit_fun with_stack -(** Emit a generic event. *) - -val begin_ : unit -> span_start - -val exit : (span_start -> unit) emit_fun_base with_cat with_stack -(** Emit a "X" event with duration computed from the given span start *) - -val with_ : ((unit -> 'a) -> 'a) emit_fun_base with_cat -val with1 : (('a -> 'b) -> 'a -> 'b) emit_fun_base with_cat -val with2 : (('a -> 'b -> 'c) -> 'a -> 'b -> 'c) emit_fun_base with_cat - -val with3 : - (('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd) emit_fun_base with_cat - -val begin' : unit emit_fun with_stack -(** Emit a "B" event *) - -val exit' : unit emit_fun with_stack -(** Emit a "E" event *) - -val span : (dur:float -> unit) emit_fun with_stack -(** Emit a "X" event *) - -val obj_new : (id:string -> unit) emit_fun with_stack -val obj_snap : (snapshot:string -> id:string -> unit) emit_fun with_stack -val obj_delete : (id:string -> unit) emit_fun with_stack -val obj_with : (id:string -> (unit -> 'a) -> 'a) emit_fun -val obj_with1 : (id:string -> ('a -> 'b) -> 'a -> 'b) emit_fun -val a_begin : (cat:string list -> id:string -> unit) emit_fun_base with_ts_us -val a_exit : (cat:string list -> id:string -> unit) emit_fun_base with_ts_us -val a_snap : (cat:string list -> id:string -> unit) emit_fun_base with_ts_us - -val a_with : - (cat:string list -> id:string -> (unit -> 'a) -> 'a) emit_fun_base with_ts_us - -val a_with1 : - (cat:string list -> id:string -> ('a -> 'b) -> 'a -> 'b) emit_fun_base - with_ts_us - -val f_begin : (id:string -> unit) emit_fun -val f_exit : (id:string -> unit) emit_fun -val f_step : (id:string -> unit) emit_fun -val instant : unit emit_fun with_stack -val counter : (cs:(string * int) list -> unit) emit_fun -val meta_thread_name : string -> unit -val meta_process_name : string -> unit - -val tick : unit -> unit -(** Depending on the tracing backend, this needs to be - called regularly to ensure background work is done. *) - -module Syntax : sig - val ( let@ ) : ('a -> 'b) -> 'a -> 'b -end - -include module type of Syntax - -(** Controls the current backend. *) -module Control : sig - val setup : backend option -> unit - val teardown : unit -> unit -end diff --git a/src/daemon/catapult_daemon.ml b/src/daemon/catapult_daemon.ml index 42693f2..89fa57b 100644 --- a/src/daemon/catapult_daemon.ml +++ b/src/daemon/catapult_daemon.ml @@ -1,15 +1,15 @@ +module Trace = Trace_core module P = Catapult -module Tr = P.Tracing module P_db = Catapult_sqlite module Atomic = P.Atomic_shim_ module Log = (val Logs.src_log (Logs.Src.create "catapult.daemon")) open Catapult_utils -open Tr.Syntax type event = Ser.Event.t type batch = event list let now_us = P.Clock.now_us +let ( let@ ) = ( @@ ) (** Handler writers for each trace *) module Writer : sig @@ -71,12 +71,12 @@ end = struct ) let close_ (self : t) ~trace_id (db : db_conn) : unit = - Tr.instant "db.close" ~args:[ "trace_id", `String trace_id ]; + Trace.message "db.close" ~data:(fun () -> [ "trace_id", `String trace_id ]); flush_batch_ db; P_db.Writer.close db.writer let[@inline never] open_ (self : t) ~trace_id ~rc : db_conn = - Tr.instant "db.open" ~args:[ "trace_id", `String trace_id ]; + Trace.message "db.open" ~data:(fun () -> [ "trace_id", `String trace_id ]); let writer = P_db.Writer.create ~append:true ~dir:self.dir ~trace_id () in let db = { @@ -115,7 +115,7 @@ end = struct | None -> () let[@inline] str_of_ev_ (self : t) (ev : event) : string = - P_db.Ev_to_json.to_json self.buf ev + Ev_to_json.to_json self.buf ev let max_batch_size = 50 @@ -152,8 +152,11 @@ end = struct (fun trace_id db -> let age = now -. Atomic.get db.last_write in if age > close_after_us then ( - Tr.instant "db.gc" - ~args:[ "trace_id", `String trace_id; "age", `Float (age *. 1e-6) ]; + Trace.message "db.gc" ~data:(fun () -> + [ + "trace_id", `String trace_id; + "age", `Int (int_of_float (age *. 1e-6)); + ]); close_ self ~trace_id db; (* collect *) None @@ -203,12 +206,11 @@ end = struct sock let handle_client_msg (self : t) (msg : Ser.Client_message.t) : unit = - Log.debug (fun k -> k "client msg:@ %a" Ser.Client_message.pp msg); - + (* Log.debug (fun k -> k "client msg:@ %a" Ser.Client_message.pp msg); *) match msg with | Ser.Client_message.Client_open_trace { trace_id } -> Log.info (fun k -> k "client opened trace %S" trace_id); - Tr.instant "open.trace" ~args:[ "id", `String trace_id ]; + Trace.message "open.trace" ~data:(fun () -> [ "id", `String trace_id ]); Writer.incr_conn self.writer ~trace_id | Ser.Client_message.Client_emit { trace_id; ev } -> Writer.write self.writer ~trace_id ev @@ -225,7 +227,7 @@ end = struct let stop self = Atomic.set self.stop true let run (self : t) : unit = - let@ () = Tr.with_ "listen.loop" in + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "listen.loop" in Sys.catch_break true; let poll = Zmq.Poll.(mask_of [| self.sock, In |]) in @@ -240,37 +242,14 @@ end = struct handle_client_msg self msg | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> (* just poll *) - let@ () = Tr.with_ "poll" in + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "poll" in ignore (Zmq.Poll.poll ~timeout poll : _ option array) | exception Sys.Break -> - Tr.instant "sys.break"; + Trace.message "sys.break"; Atomic.set self.stop true done end -(** Background thread *) -module Ticker_thread = struct - open Catapult_utils - - let start ~server ~writer () = - let run () = - Tr.meta_thread_name "ticker"; - let pid = Unix.getpid () in - while true do - let@ () = Tr.with_ "tick" in - Thread.delay 0.2; - let now = P.Clock.now_us () in - - Tr.tick (); - Tr.counter "daemon" ~cs:[ "writer", Writer.size writer ]; - Gc_stats.maybe_emit ~now ~pid (); - Writer.tick writer - done - in - - ignore (Thread.create run () : Thread.t) -end - module Dir = Directories.Project_dirs (struct let qualifier = "ai" let organization = "imandra" @@ -293,10 +272,11 @@ let setup_logs ~debug () = let () = (* tracing for the daemon itself *) - let@ () = Catapult_sqlite.with_setup in + let@ writer = Catapult_sqlite.Writer.with_ () in + Trace.setup_collector (Catapult_sqlite.trace_collector_of_writer writer); - Tr.meta_process_name "catapult-daemon"; - Tr.meta_thread_name "main"; + Trace.set_process_name "catapult-daemon"; + Trace.set_thread_name "main"; let debug = ref false in let dir = @@ -329,6 +309,5 @@ let () = let writer = Writer.create ~dir:!dir () in let server = Server.create ~writer ~addr:!addr () in - Ticker_thread.start ~writer ~server (); Server.run server; () diff --git a/src/sqlite/backend.ml b/src/sqlite/backend.ml index e4f46b7..a97a54c 100644 --- a/src/sqlite/backend.ml +++ b/src/sqlite/backend.ml @@ -1,7 +1,6 @@ open Catapult_utils -module P = Catapult -module Tracing = P.Tracing -module Atomic = P.Atomic_shim_ +module Atomic = Catapult.Atomic_shim_ +module Clock = Catapult.Clock type event = Ser.Event.t @@ -9,7 +8,7 @@ module type ARG = sig val writer : Writer.t end -module Make (A : ARG) : P.BACKEND = struct +module Make (A : ARG) : Catapult.BACKEND = struct let writer = A.writer type local_buf = { @@ -23,7 +22,7 @@ module Make (A : ARG) : P.BACKEND = struct try int_of_string @@ Sys.getenv "TRACE_BATCH_SIZE" with _ -> 100 let max_batch_interval_us = 3. *. 1e6 (* max time between 2 flushes *) - let last_batch_flush = Atomic.make (P.Clock.now_us ()) + let last_batch_flush = Atomic.make (Clock.now_us ()) (* send current batch to the writer *) let flush_batch (self : local_buf) : unit = @@ -57,7 +56,7 @@ module Make (A : ARG) : P.BACKEND = struct Writer.close writer let tick () = - let now = P.Clock.now_us () in + let now = Clock.now_us () in Thread_local.iter buf ~f:(check_batch ~now) module Out = Catapult_utils.Json_out @@ -91,7 +90,7 @@ module Make (A : ARG) : P.BACKEND = struct field buf {|"name"|} Out.str_val name; field_sep buf; - field buf {|"ph"|} Out.char_val (P.Event_type.to_char ph); + field buf {|"ph"|} Out.char_val (Catapult.Event_type.to_char ph); field_sep buf; field buf {|"tid"|} any_val (string_of_int tid); @@ -141,7 +140,7 @@ module Make (A : ARG) : P.BACKEND = struct if i > 0 then field_sep buf; Out.str_val buf k; field_col buf; - Out.arg buf (v : P.Arg.t)) + Out.arg buf (v :> _ Out.arg)) args; Out.char buf '}'; field_sep buf); @@ -169,3 +168,9 @@ module Make (A : ARG) : P.BACKEND = struct () end + +let make (wr : Writer.t) : Catapult.backend = + let module M = Make (struct + let writer = wr + end) in + (module M) diff --git a/src/sqlite/backend.mli b/src/sqlite/backend.mli index c026791..74eac8d 100644 --- a/src/sqlite/backend.mli +++ b/src/sqlite/backend.mli @@ -3,3 +3,5 @@ module type ARG = sig end module Make (Arg : ARG) : Catapult.BACKEND + +val make : Writer.t -> Catapult.backend diff --git a/src/sqlite/catapult_sqlite.ml b/src/sqlite/catapult_sqlite.ml index 87518b2..88e270f 100644 --- a/src/sqlite/catapult_sqlite.ml +++ b/src/sqlite/catapult_sqlite.ml @@ -1,90 +1,22 @@ -module P = Catapult -module Tracing = P.Tracing -module Backend = Backend -module Writer = Writer -module Ev_to_json = Ev_to_json - -let trace_id = ref (try Sys.getenv "TRACE_ID" with _ -> "") -let set_trace_id s = trace_id := s -let file = ref (try Sys.getenv "TRACE_DB" with _ -> "") -let set_file f = file := f -let sqlite_sync_ = ref None -let set_sqlite_sync s = sqlite_sync_ := Some s -let multiproc_ = ref false -let set_multiproc b = multiproc_ := b - -(* try to make a non-stupid default id, based on PID + date. - This is not perfect, use a UUID4 if possible. *) -let[@inline never] invent_trace_id_ () : string = - let pid = Unix.getpid () in - let now = Unix.gettimeofday () in - let tm = Unix.gmtime now in - Printf.sprintf "catapult-%d-%d-%0d-%02d-%02d-%02d-pid-%d" (1900 + tm.tm_year) - (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec pid - -let[@inline] get_trace_id () = - if !trace_id = "" then trace_id := invent_trace_id_ (); - !trace_id - -let trace_in_env () = - List.mem (Sys.getenv_opt "TRACE") [ Some "1"; Some "true" ] +(** Backend that writes directly to a Sqlite database. -let mk_lazy_enable getenv = - let r = ref false in - let enabled_thunk = lazy (!r || getenv ()) in - let[@inline] enabled () = Lazy.force enabled_thunk in - let enable () = if not !r then r := true in - enable, enabled + Creating the database is done via {!Writer.create} + or {!Writer.with_}. Then {!Backend} can be used to + turn this {!Writer.t} into a Tracing collector. *) -let enable, enabled = mk_lazy_enable trace_in_env - -module Dir = Directories.Project_dirs (struct - let qualifier = "ai" - let organization = "imandra" - let application = "catapult" -end) - -let dir = - ref - @@ - match Dir.data_dir with - | None -> "." - | Some d -> d - -let set_dir d = dir := d +module Writer = Writer +module Backend = Backend -let setup_ = - lazy - (if enabled () then ( - at_exit P.Control.teardown; - let trace_id = get_trace_id () in - let file = - if !file = "" then - None - else - Some !file - in - let append = !multiproc_ in - (* do not truncate if others also write *) - let writer = - Writer.create ~append ?sync:!sqlite_sync_ ?file ~trace_id ~dir:!dir () - in - let module B = Backend.Make (struct - let writer = writer - end) in - let backend = (module B : P.BACKEND) in - P.Control.setup (Some backend) - )) +let backend_of_writer : Writer.t -> Catapult.backend = Backend.make -let setup () = Lazy.force setup_ -let teardown = P.Tracing.Control.teardown +(** Turn a writer into a Trace collector. *) +let trace_collector_of_writer : Writer.t -> Trace_core.collector = + fun wr -> backend_of_writer wr |> Catapult.trace_collector_of_backend -let with_setup f = - setup (); - try - let x = f () in - teardown (); - x - with e -> - teardown (); - raise e +(** [with_ () f] runs [f()] in a scope where a connection to + a Sqlite DB has been established and is used to store + tracing events emitted from within [f ()]. *) +let with_ ?sync ?append ?file ?trace_id ?dir () (f : unit -> 'a) : 'a = + Writer.with_ ?sync ?append ?file ?trace_id ?dir () @@ fun wr -> + Trace_core.setup_collector (trace_collector_of_writer wr); + f () diff --git a/src/sqlite/catapult_sqlite.mli b/src/sqlite/catapult_sqlite.mli deleted file mode 100644 index 296f944..0000000 --- a/src/sqlite/catapult_sqlite.mli +++ /dev/null @@ -1,35 +0,0 @@ -(** Backend that writes directly to a Sqlite database. - - The database path is either directly provided with "TRACE_DB" - or {!set_file}, or it's a file named after the trace ID in the directory - set by {!set_dir} (or the default directory otherwise). - - The trace ID is determined by "TRACE_ID" if present, otherwise auto-generated - or set via {!set_trace_id}. -*) - -include Catapult.IMPL - -val set_sqlite_sync : [ `OFF | `NORMAL | `FULL ] -> unit -(** Set level of crash safety for sqlite. - See {!Writer.create} for more details. *) - -val enable : unit -> unit -val enabled : unit -> bool -val set_trace_id : string -> unit -val get_trace_id : unit -> string - -val set_multiproc : bool -> unit -(** Multiprocess mode? - If true, then the file will not be truncated. *) - -val set_dir : string -> unit -(** Set directory in which to store the database by its trace ID. *) - -val set_file : string -> unit -(** Set database path to use. If not specified, it will be picked - from the trace ID, and the directory {!set_dir}. *) - -module Writer = Writer -module Backend = Backend -module Ev_to_json = Ev_to_json diff --git a/src/sqlite/writer.ml b/src/sqlite/writer.ml index 36ab551..1802260 100644 --- a/src/sqlite/writer.ml +++ b/src/sqlite/writer.ml @@ -44,7 +44,8 @@ let close self = done ) -let create ?(sync = `NORMAL) ?(append = false) ?file ~trace_id ~dir () : t = +let create ?(sync = `NORMAL) ?(append = false) ?file ?trace_id ?(dir = ".") () : + t = let file = match file with | Some f -> f @@ -54,6 +55,11 @@ let create ?(sync = `NORMAL) ?(append = false) ?file ~trace_id ~dir () : t = (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir)) : int) with _ -> ()); + let trace_id = + match trace_id with + | Some id -> id + | None -> "trace" + in Filename.concat dir (trace_id ^ ".db") in let db = Db.db_open file in @@ -79,6 +85,11 @@ let create ?(sync = `NORMAL) ?(append = false) ?file ~trace_id ~dir () : t = Gc.finalise close self; self +let with_ ?sync ?append ?file ?trace_id ?dir () f = + let wr = create ?sync ?append ?file ?trace_id ?dir () in + let@ () = Fun.protect ~finally:(fun () -> close wr) in + f wr + let cycle_stmt (self : t) = Db.finalize self.stmt_insert |> check_ret_; let stmt_insert = Db.prepare self.db "insert into events values (?);" in diff --git a/src/sqlite/writer.mli b/src/sqlite/writer.mli index 25fa3ed..1b1edb2 100644 --- a/src/sqlite/writer.mli +++ b/src/sqlite/writer.mli @@ -1,11 +1,15 @@ +(** DB writer. *) + type t +(** DB writer. This holds a sqlite DB and writes new + events to it. *) val create : ?sync:[ `OFF | `NORMAL | `FULL ] -> ?append:bool -> ?file:string -> - trace_id:string -> - dir:string -> + ?trace_id:string -> + ?dir:string -> unit -> t (** Open writer into a database file. @@ -24,6 +28,16 @@ val cycle_stmt : t -> unit val close : t -> unit (** Close writer. *) +val with_ : + ?sync:[ `OFF | `NORMAL | `FULL ] -> + ?append:bool -> + ?file:string -> + ?trace_id:string -> + ?dir:string -> + unit -> + (t -> 'a) -> + 'a + val write_string_l : t -> string list -> unit val write_string : t -> string -> unit diff --git a/src/utils/catapult_utils.ml b/src/utils/catapult_utils.ml index f8ae845..6db4d93 100644 --- a/src/utils/catapult_utils.ml +++ b/src/utils/catapult_utils.ml @@ -1,5 +1,6 @@ module Bare_encoding = Bare_encoding module Endpoint_address = Endpoint_address +module Ev_to_json = Ev_to_json module Gc_stats = Gc_stats module Json_out = Json_out module Ser = Ser diff --git a/src/utils/dune b/src/utils/dune index e326128..bda1af8 100644 --- a/src/utils/dune +++ b/src/utils/dune @@ -1,6 +1,7 @@ (library (name catapult_utils) (public_name catapult.utils) + (synopsis "Utilities for Catapult") (libraries catapult)) ; generate (de)ser code @@ -11,7 +12,7 @@ (deps ser.bare) (mode promote) (action - (run bare-codegen --pp -o %{targets} %{deps}))) + (run bare-codegen -o %{targets} %{deps}))) ; vendor runtime library for BARE diff --git a/src/sqlite/ev_to_json.ml b/src/utils/ev_to_json.ml similarity index 97% rename from src/sqlite/ev_to_json.ml rename to src/utils/ev_to_json.ml index 716b9d2..3669bf3 100644 --- a/src/sqlite/ev_to_json.ml +++ b/src/utils/ev_to_json.ml @@ -1,5 +1,4 @@ -open Catapult_utils -module Out = Catapult_utils.Json_out +module Out = Json_out let[@inline] field_col oc = Out.char oc ':' let[@inline] field_sep oc = Out.char oc ',' diff --git a/src/sqlite/ev_to_json.mli b/src/utils/ev_to_json.mli similarity index 69% rename from src/sqlite/ev_to_json.mli rename to src/utils/ev_to_json.mli index b76185b..3cb06e6 100644 --- a/src/sqlite/ev_to_json.mli +++ b/src/utils/ev_to_json.mli @@ -1,3 +1 @@ -open Catapult_utils - val to_json : Buffer.t -> Ser.Event.t -> string diff --git a/src/utils/gc_stats.ml b/src/utils/gc_stats.ml index 28049b6..674b2df 100644 --- a/src/utils/gc_stats.ml +++ b/src/utils/gc_stats.ml @@ -1,5 +1,6 @@ module P = Catapult module Atomic = P.Atomic_shim_ +module Trace = Trace_core (* store last time we emitted GC events *) let last_gc : float Atomic.t = Atomic.make (P.Clock.now_us ()) @@ -10,17 +11,17 @@ let set_gc_interval_us s = gc_interval_us := s (* emit a GC counter event *) let[@inline never] emit_gc_ ~pid () = let st = Gc.quick_stat () in - P.Tracing.counter "gc" - ~cs: - [ - Printf.sprintf "%d.major" pid, st.Gc.major_collections; - Printf.sprintf "%d.minor" pid, st.Gc.minor_collections; - Printf.sprintf "%d.compactions" pid, st.Gc.compactions; - Printf.sprintf "%d.heap_words" pid, st.Gc.heap_words; - ( Printf.sprintf "%d.heap_MB" pid, - st.Gc.heap_words * (Sys.word_size / 8) / 1024 / 1024 ); - Printf.sprintf "%d.minor_words" pid, int_of_float st.Gc.minor_words; - ] + Trace.counter_int (Printf.sprintf "%d.major" pid) st.Gc.major_collections; + Trace.counter_int (Printf.sprintf "%d.minor" pid) st.Gc.minor_collections; + Trace.counter_int (Printf.sprintf "%d.compactions" pid) st.Gc.compactions; + Trace.counter_int (Printf.sprintf "%d.heap_words" pid) st.Gc.heap_words; + Trace.counter_int + (Printf.sprintf "%d.heap_MB" pid) + (st.Gc.heap_words * (Sys.word_size / 8) / 1024 / 1024); + Trace.counter_int + (Printf.sprintf "%d.minor_words" pid) + (int_of_float st.Gc.minor_words); + () let maybe_emit ~now ~pid () = let must_emit_gc_ = diff --git a/src/utils/gc_stats.mli b/src/utils/gc_stats.mli index 46aacd4..a668fd1 100644 --- a/src/utils/gc_stats.mli +++ b/src/utils/gc_stats.mli @@ -1,3 +1,5 @@ +(** Utils to reflect GC statistics in traces *) + val set_gc_interval_us : float -> unit (** Set the interval, in microseconds, between 2 successive gathering of GC statistics, to be emitted as catapult counters. *) diff --git a/src/utils/json_out.ml b/src/utils/json_out.ml index b1542fe..ade5f43 100644 --- a/src/utils/json_out.ml +++ b/src/utils/json_out.ml @@ -1,5 +1,8 @@ (** Basic output of json values to a buffer *) +type 'a arg = [ Catapult.arg | `List of 'a list ] as 'a +(** Extended kind of argument *) + let char = Buffer.add_char let raw_string = Buffer.add_string let int out i = raw_string out (string_of_int i) @@ -30,12 +33,22 @@ let str_val oc (s : string) = String.iter encode_char s; char oc '"' -let arg oc = function +let rec arg oc : [< _ arg ] -> unit = function | `Int i -> int oc i | `String s -> str_val oc s | `Bool b -> bool oc b + | `None -> null oc | `Float f -> float oc f - | `Null -> null oc + | `List l -> list oc l + +and list oc l = + char oc '['; + List.iteri + (fun i x -> + if i > 0 then char oc ','; + arg oc x) + l; + char oc ']' let char_val oc (c : char) = char oc '"'; diff --git a/src/utils/ser.ml b/src/utils/ser.ml index 3fa9f5d..7e1495f 100644 --- a/src/utils/ser.ml +++ b/src/utils/ser.ml @@ -41,20 +41,6 @@ module Arg_value = struct Bare.Encode.uint enc 4L - let pp out (self:t) : unit = - match self with - | Int64 x -> - Format.fprintf out "(@[Int64@ %a@])" Bare.Pp.int64 x - | String x -> - Format.fprintf out "(@[String@ %a@])" Bare.Pp.string x - | Bool x -> - Format.fprintf out "(@[Bool@ %a@])" Bare.Pp.bool x - | Float64 x -> - Format.fprintf out "(@[Float64@ %a@])" Bare.Pp.float x - | Void -> - Format.fprintf out "Void" - - end module Arg = struct @@ -75,15 +61,6 @@ module Arg = struct Arg_value.encode enc self.value; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "key=%a;@ " Bare.Pp.string x.key; - Format.fprintf out "value=%a;@ " Arg_value.pp x.value; - Format.fprintf out "@]}"; - end) out self - end module Extra = struct @@ -104,15 +81,6 @@ module Extra = struct Bare.Encode.string enc self.value; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "key=%a;@ " Bare.Pp.string x.key; - Format.fprintf out "value=%a;@ " Bare.Pp.string x.value; - Format.fprintf out "@]}"; - end) out self - end module Event = struct @@ -198,28 +166,6 @@ module Event = struct Array.iter (fun xi -> Extra.encode enc xi) arr)) enc self.extra; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "id=%a;@ " (Bare.Pp.option Bare.Pp.string) x.id; - Format.fprintf out "name=%a;@ " Bare.Pp.string x.name; - Format.fprintf out "ph=%a;@ " Bare.Pp.int x.ph; - Format.fprintf out "pid=%a;@ " Bare.Pp.int64 x.pid; - Format.fprintf out "tid=%a;@ " Bare.Pp.int64 x.tid; - Format.fprintf out "cat=%a;@ " - (Bare.Pp.option (Bare.Pp.array Bare.Pp.string)) x.cat; - Format.fprintf out "ts_us=%a;@ " Bare.Pp.float x.ts_us; - Format.fprintf out "args=%a;@ " - (Bare.Pp.option (Bare.Pp.array Arg.pp)) x.args; - Format.fprintf out "stack=%a;@ " - (Bare.Pp.option (Bare.Pp.array Bare.Pp.string)) x.stack; - Format.fprintf out "dur=%a;@ " (Bare.Pp.option Bare.Pp.float) x.dur; - Format.fprintf out "extra=%a;@ " - (Bare.Pp.option (Bare.Pp.array Extra.pp)) x.extra; - Format.fprintf out "@]}"; - end) out self - end module Client_open_trace = struct @@ -234,14 +180,6 @@ module Client_open_trace = struct let encode (enc: Bare.Encode.t) (self: t) : unit = begin Bare.Encode.string enc self.trace_id; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "trace_id=%a;@ " Bare.Pp.string x.trace_id; - Format.fprintf out "@]}"; - end) out self - end module Client_close_trace = struct @@ -256,14 +194,6 @@ module Client_close_trace = struct let encode (enc: Bare.Encode.t) (self: t) : unit = begin Bare.Encode.string enc self.trace_id; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "trace_id=%a;@ " Bare.Pp.string x.trace_id; - Format.fprintf out "@]}"; - end) out self - end module Client_emit = struct @@ -281,15 +211,6 @@ module Client_emit = struct let encode (enc: Bare.Encode.t) (self: t) : unit = begin Bare.Encode.string enc self.trace_id; Event.encode enc self.ev; end - let pp out (self:t) : unit = - (fun out x -> - begin - Format.fprintf out "{ @["; - Format.fprintf out "trace_id=%a;@ " Bare.Pp.string x.trace_id; - Format.fprintf out "ev=%a;@ " Event.pp x.ev; - Format.fprintf out "@]}"; - end) out self - end module Client_message = struct @@ -323,16 +244,6 @@ module Client_message = struct Client_emit.encode enc x - let pp out (self:t) : unit = - match self with - | Client_open_trace x -> - Format.fprintf out "(@[Client_open_trace@ %a@])" Client_open_trace.pp x - | Client_close_trace x -> - Format.fprintf out "(@[Client_close_trace@ %a@])" Client_close_trace.pp x - | Client_emit x -> - Format.fprintf out "(@[Client_emit@ %a@])" Client_emit.pp x - - end