add hmap as a depopt

if present, we use `Mmap.t` as the meta map for manual spans

.github/workflows/main.yml

@@ -42,3 +42,7 @@ jobs:
       - run: opam install trace
       - run: opam exec -- dune runtest -p trace-tef,trace-fuchsia
 
+      # with depopts
+      - run: opam install hmap
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
+

dune-project

@@ -19,6 +19,7 @@
    (ocaml (>= 4.08))
    dune)
  (depopts
+   hmap
    (mtime (>= 2.0)))
  (tags
   (trace tracing observability profiling)))

src/core/dune

@@ -2,6 +2,9 @@
 (library
  (name trace_core)
  (public_name trace.core)
+ (libraries (select meta_map.ml from
+                    (hmap -> meta_map.hmap.ml)
+                    (-> meta_map.ourown.ml)))
  (synopsis "Lightweight stub for tracing")
 )
 

src/core/meta_map.hmap.ml

@@ -0,0 +1,3 @@
+include Hmap
+
+let find_exn = get

src/core/meta_map.mli

@@ -1,37 +0,0 @@
-(** Associative containers with Heterogeneous Values *)
-
-(** Keys with a type witness. *)
-module Key : sig
-  type 'a t
-  (** A key of type ['a t] is used to access the portion of the
-      map or table that associates keys of type ['a] to values. *)
-
-  val create : unit -> 'a t
-  (** Make a new key. This is generative, so calling [create ()] twice with the
-      same return type will produce incompatible keys that cannot see each
-      other's bindings. *)
-
-  val equal : 'a t -> 'a t -> bool
-  (** Compare two keys that have compatible types. *)
-end
-
-type pair = Pair : 'a Key.t * 'a -> pair
-
-type t
-(** Immutable map from {!Key.t} to values *)
-
-val empty : t
-val mem : _ Key.t -> t -> bool
-val add : 'a Key.t -> 'a -> t -> t
-val remove : _ Key.t -> t -> t
-val length : t -> int
-val cardinal : t -> int
-val find : 'a Key.t -> t -> 'a option
-
-val find_exn : 'a Key.t -> t -> 'a
-(** @raise Not_found if the key is not in the table. *)
-
-val iter : (pair -> unit) -> t -> unit
-val add_list : t -> pair list -> t
-val of_list : pair list -> t
-val to_list : t -> pair list

src/core/meta_map.ourown.ml

@@ -23,20 +23,24 @@ module Key = struct
     end in
     (module K : KEY_IMPL with type t = k)
 
-  let id (type k) (module K : KEY_IMPL with type t = k) = K.id
+  let[@inline] id (type k) (module K : KEY_IMPL with type t = k) = K.id
 
   let equal : type a b. a t -> b t -> bool =
    fun (module K1) (module K2) -> K1.id = K2.id
 end
 
-type pair = Pair : 'a Key.t * 'a -> pair
+type 'a key = 'a Key.t
-type exn_pair = E_pair : 'a Key.t * exn -> exn_pair
+type binding = B : 'a Key.t * 'a -> binding
 
-let pair_of_e_pair (E_pair (k, e)) =
+open struct
-  let module K = (val k) in
+  type exn_pair = E_pair : 'a Key.t * exn -> exn_pair
-  match e with
+
-  | K.Store v -> Pair (k, v)
+  let pair_of_e_pair (E_pair (k, e)) =
-  | _ -> assert false
+    let module K = (val k) in
+    match e with
+    | K.Store v -> B (k, v)
+    | _ -> assert false
+end
 
 module M = Map.Make (struct
   type t = int
@@ -47,7 +51,7 @@ end)
 type t = exn_pair M.t
 
 let empty = M.empty
-let mem k t = M.mem (Key.id k) t
+let[@inline] mem k t = M.mem (Key.id k) t
 
 let find_exn (type a) (k : a Key.t) t : a =
   let module K = (val k) in
@@ -62,10 +66,12 @@ let add_e_pair_ p t =
   let (E_pair ((module K), _)) = p in
   M.add K.id p t
 
-let add_pair_ p t =
+open struct
-  let (Pair (((module K) as k), v)) = p in
+  let add_pair_ p t =
-  let p = E_pair (k, K.Store v) in
+    let (B (((module K) as k), v)) = p in
-  M.add K.id p t
+    let p = E_pair (k, K.Store v) in
+    M.add K.id p t
+end
 
 let add (type a) (k : a Key.t) v t =
   let module K = (val k) in

src/core/types.ml

@@ -17,6 +17,9 @@ type explicit_span = {
   span: span;
       (** Identifier for this span. Several explicit spans might share the same
       identifier since we can differentiate between them via [meta]. *)
-  mutable meta: Meta_map.t;  (** Metadata for this span (and its context) *)
+  mutable meta: Meta_map.t;
+      (** Metadata for this span (and its context). This can be used by collectors to
+        carry collector-specific information from the beginning
+        of the span, to the end of the span. *)
 }
 (** Explicit span, with collector-specific metadata *)

src/fuchsia/fcollector.ml

@@ -110,7 +110,7 @@ type async_span_info = {
   mutable data: (string * user_data) list;
 }
 
-let key_async_data : async_span_info Meta_map.Key.t = Meta_map.Key.create ()
+let key_async_data : async_span_info Meta_map.key = Meta_map.Key.create ()
 
 open struct
   let state_id_ = A.make 0

src/tef/trace_tef.ml

@@ -92,12 +92,12 @@ type span_info = {
 }
 
 (** key used to carry a unique "id" for all spans in an async context *)
-let key_async_id : int Meta_map.Key.t = Meta_map.Key.create ()
+let key_async_id : int Meta_map.key = Meta_map.Key.create ()
 
-let key_async_data : (string * [ `Sync | `Async ] option) Meta_map.Key.t =
+let key_async_data : (string * [ `Sync | `Async ] option) Meta_map.key =
   Meta_map.Key.create ()
 
-let key_data : (string * user_data) list ref Meta_map.Key.t =
+let key_data : (string * user_data) list ref Meta_map.key =
   Meta_map.Key.create ()
 
 (** Writer: knows how to write entries to a file in TEF format *)

trace.opam

@@ -15,6 +15,7 @@ depends: [
   "odoc" {with-doc}
 ]
 depopts: [
+  "hmap"
   "mtime" {>= "2.0"}
 ]
 build: [