initial commit

.gitignore

@@ -0,0 +1,2 @@
+_opam
+_build

.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

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

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))

dune

@@ -0,0 +1,4 @@
+
+(env
+  (_ (flags :standard -strict-sequence -warn-error -a+8 -w +a-4-40-70)))
+

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

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

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))))
+          

src/gen/dune

@@ -0,0 +1,3 @@
+
+(executable
+  (name gen))

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
+  )

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 ()

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

src/types.ml

@@ -0,0 +1,2 @@
+type span = int64
+(** A span identifier. *)

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"