From 68bcc7c9e2c5d336c4e392874bb0f2d5909ef5ab Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 8 Jun 2023 21:25:34 -0400 Subject: [PATCH] initial commit --- .gitignore | 2 ++ .ocamlformat | 15 ++++++++ Makefile | 19 +++++++++++ README.md | 10 ++++++ dune | 4 +++ dune-project | 23 +++++++++++++ src/collector.ml | 28 +++++++++++++++ src/dune | 18 ++++++++++ src/gen/dune | 3 ++ src/gen/gen.ml | 89 ++++++++++++++++++++++++++++++++++++++++++++++++ src/trace.ml | 65 +++++++++++++++++++++++++++++++++++ src/trace.mli | 41 ++++++++++++++++++++++ src/types.ml | 2 ++ trace.opam | 31 +++++++++++++++++ 14 files changed, 350 insertions(+) create mode 100644 .gitignore create mode 100644 .ocamlformat create mode 100644 Makefile create mode 100644 README.md create mode 100644 dune create mode 100644 dune-project create mode 100644 src/collector.ml create mode 100644 src/dune create mode 100644 src/gen/dune create mode 100644 src/gen/gen.ml create mode 100644 src/trace.ml create mode 100644 src/trace.mli create mode 100644 src/types.ml create mode 100644 trace.opam diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f485c7c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +_opam +_build diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..2124d7d --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,15 @@ +version = 0.24.1 +profile=conventional +margin=80 +if-then-else=k-r +parens-ite=true +parens-tuple=multi-line-only +sequence-style=terminator +type-decl=sparse +break-cases=toplevel +cases-exp-indent=2 +field-space=tight-decl +leading-nested-match-parens=true +module-item-spacing=compact +quiet=true +ocaml-version=4.08.0 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..de0d203 --- /dev/null +++ b/Makefile @@ -0,0 +1,19 @@ + +DUNE_OPTS?= +all: + dune build @all $(DUNE_OPTS) + +clean: + @dune clean + +test: + @dune runtest $(DUNE_OPTS) + +doc: + @dune build $(DUNE_OPTS) @doc + +WATCH?=@all +watch: + dune build $(DUNE_OPTS) -w $(WATCH) + +.PHONY: test clean watch diff --git a/README.md b/README.md new file mode 100644 index 0000000..c78f877 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ + +# Trace + +This small library provides basic types that can be used to instrument +a library or application, either by hand or via a ppx. + +Backends, using concrete tracing or observability formats such as: +- Fuchsia (see [tracing](https://github.com/janestreet/tracing)) +- Catapult (see [ocaml-catapult](https://github.com/imandra-ai/catapult)) +- Tracy (see [ocaml-tracy](https://github.com/imandra-ai/ocaml-tracy)) diff --git a/dune b/dune new file mode 100644 index 0000000..69fd3ec --- /dev/null +++ b/dune @@ -0,0 +1,4 @@ + +(env + (_ (flags :standard -strict-sequence -warn-error -a+8 -w +a-4-40-70))) + diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..f52d747 --- /dev/null +++ b/dune-project @@ -0,0 +1,23 @@ +(lang dune 2.9) + +(name trace) +(generate_opam_files true) + +(source + (github c-cube/trace)) +(authors "Simon Cruanes") +(maintainers "Simon Cruanes") +(license MIT) + +;(documentation https://url/to/documentation) + +(package + (name trace) + (synopsis "A stub for tracing/observability") + (depends + (ocaml (>= 4.03)) + dune) + (tags + (tracing observability profiling))) + +; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project diff --git a/src/collector.ml b/src/collector.ml new file mode 100644 index 0000000..a04cb5e --- /dev/null +++ b/src/collector.ml @@ -0,0 +1,28 @@ +(** A global collector. + + The collector, if present, is responsible for collecting messages + and spans, and storing them, recording them, forward them, or + offering them to other services and processes. +*) + +open Types + +let dummy_span : span = Int64.min_int + +module type S = sig + val enabled : unit -> bool + (** Is the collector enabled? This should be extremely fast so that + the traced program can check it before creating any span or + message *) + + val create_span : + ?__FUNCTION__:string -> __FILE__:string -> __LINE__:int -> string -> span + + val exit_span : span -> unit + + val message : + ?__FUNCTION__:string -> __FILE__:string -> __LINE__:int -> string -> unit + + val shutdown : unit -> unit + (** Shutdown collector, possibly waiting for it to finish sending data. *) +end diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..7772f29 --- /dev/null +++ b/src/dune @@ -0,0 +1,18 @@ +(library + (public_name trace) + (synopsis "Lightweight stub for tracing") + (name trace) +) + +(rule + (targets atomic_.ml) + (action + (with-stdout-to %{targets} + (run ./gen/gen.exe --ocaml %{ocaml_version} --atomic)))) + +(rule + (targets domain_.ml) + (action + (with-stdout-to %{targets} + (run ./gen/gen.exe --ocaml %{ocaml_version} --domain)))) + diff --git a/src/gen/dune b/src/gen/dune new file mode 100644 index 0000000..cd463d8 --- /dev/null +++ b/src/gen/dune @@ -0,0 +1,3 @@ + +(executable + (name gen)) diff --git a/src/gen/gen.ml b/src/gen/gen.ml new file mode 100644 index 0000000..9e6b91e --- /dev/null +++ b/src/gen/gen.ml @@ -0,0 +1,89 @@ +let atomic_pre_412 = + {| +type 'a t = { mutable x: 'a } + +let[@inline] make x = { x } +let[@inline] get { x } = x +let[@inline] set r x = r.x <- x + +let[@inline never] exchange r x = + (* atomic *) + let y = r.x in + r.x <- x; + (* atomic *) + y + +let[@inline never] compare_and_set r seen v = + (* atomic *) + if r.x == seen then ( + r.x <- v; + (* atomic *) + true + ) else + false + +let[@inline never] fetch_and_add r x = + (* atomic *) + let v = r.x in + r.x <- x + r.x; + (* atomic *) + v + +let[@inline never] incr r = + (* atomic *) + r.x <- 1 + r.x +(* atomic *) + +let[@inline never] decr r = + (* atomic *) + r.x <- r.x - 1 + (* atomic *) + +|} + +let atomic_post_412 = {| +include Atomic +|} + +let domain_pre_5 = {| + +let relax () = Thread.yield () +|} + +let domain_post_5 = {| +let relax = Domain.cpu_relax +|} + +let p_version s = Scanf.sscanf s "%d.%d" (fun x y -> x, y) + +let () = + let atomic = ref false in + let domain = ref false in + let ocaml = ref Sys.ocaml_version in + Arg.parse + [ + "--atomic", Arg.Set atomic, " atomic"; + "--domain", Arg.Set domain, " domain"; + "--ocaml", Arg.Set_string ocaml, " set ocaml version"; + ] + ignore ""; + + let major, minor = p_version !ocaml in + + if !atomic then ( + let code = + if (major, minor) < (4, 12) then + atomic_pre_412 + else + atomic_post_412 + in + print_endline code + ) else if !domain then ( + let code = + if (major, minor) < (5, 0) then + domain_pre_5 + else + domain_post_5 + in + print_endline code + ) diff --git a/src/trace.ml b/src/trace.ml new file mode 100644 index 0000000..94966e4 --- /dev/null +++ b/src/trace.ml @@ -0,0 +1,65 @@ +include Types +module A = Atomic_ + +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 (module C) -> C.enabled () + +let[@inline] create_span ?__FUNCTION__ ~__FILE__ ~__LINE__ name : span = + match A.get collector with + | None -> Collector.dummy_span + | Some (module C) -> C.create_span ?__FUNCTION__ ~__FILE__ ~__LINE__ name + +let[@inline] exit_span span : unit = + match A.get collector with + | None -> () + | Some (module C) -> C.exit_span span + +let with_ ?__FUNCTION__ ~__FILE__ ~__LINE__ name f = + match A.get collector with + | None -> f Collector.dummy_span + | Some (module C) -> + let sp = C.create_span ?__FUNCTION__ ~__FILE__ ~__LINE__ 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] message ?__FUNCTION__ ~__FILE__ ~__LINE__ msg : unit = + match A.get collector with + | None -> () + | Some (module C) -> C.message ?__FUNCTION__ ~__FILE__ ~__LINE__ msg + +let messagef ?__FUNCTION__ ~__FILE__ ~__LINE__ k = + match A.get collector with + | None -> () + | Some (module C) -> + k (fun fmt -> + Format.kasprintf + (fun str -> C.message ?__FUNCTION__ ~__FILE__ ~__LINE__ str) + fmt) + +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 + Domain_.relax () + done + +let shutdown () = + match A.exchange collector None with + | None -> () + | Some (module C) -> C.shutdown () diff --git a/src/trace.mli b/src/trace.mli new file mode 100644 index 0000000..53e30ef --- /dev/null +++ b/src/trace.mli @@ -0,0 +1,41 @@ +(** Trace. *) + +include module type of Types + +(** {2 Tracing} *) + +val enabled : unit -> bool + +val create_span : + ?__FUNCTION__:string -> __FILE__:string -> __LINE__:int -> string -> span + +val exit_span : span -> unit + +val with_ : + ?__FUNCTION__:string -> + __FILE__:string -> + __LINE__:int -> + string -> + (span -> 'a) -> + 'a + +val message : + ?__FUNCTION__:string -> __FILE__:string -> __LINE__:int -> string -> unit + +val messagef : + ?__FUNCTION__:string -> + __FILE__:string -> + __LINE__:int -> + ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> + unit + +(** {2 Collector} *) + +type collector = (module Collector.S) + +val setup_collector : collector -> unit +(** [setup_collector c] installs [c] as the collector. + @raise Invalid_argument if there already is an established + collector. *) + +val shutdown : unit -> unit diff --git a/src/types.ml b/src/types.ml new file mode 100644 index 0000000..e3ae3ac --- /dev/null +++ b/src/types.ml @@ -0,0 +1,2 @@ +type span = int64 +(** A span identifier. *) diff --git a/trace.opam b/trace.opam new file mode 100644 index 0000000..e04d5bc --- /dev/null +++ b/trace.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A stub for tracing/observability" +maintainer: ["Simon Cruanes"] +authors: ["Simon Cruanes"] +license: "MIT" +tags: ["tracing" "observability" "profiling"] +homepage: "https://github.com/c-cube/trace" +bug-reports: "https://github.com/c-cube/trace/issues" +depends: [ + "ocaml" {>= "4.03"} + "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/c-cube/trace.git"