Peform table-based translation of runtime event names and tags

bin/dune

@@ -3,11 +3,16 @@
  (public_name olly)
  (name olly)
  (modules olly)
- (libraries olly_trace olly_gc_stats olly_format_json olly_format_fuchsia))
+ (libraries
+  olly_trace
+  olly_gc_stats
+  olly_gen_tables
+  olly_format_json
+  olly_format_fuchsia))
 
 (executable
  (package runtime_events_tools_bare)
  (public_name olly_bare)
  (name olly_bare)
  (modules olly_bare)
- (libraries olly_trace olly_format_json))
+ (libraries olly_trace olly_gen_tables olly_format_json))

bin/olly.ml

@@ -2,5 +2,6 @@ let () =
   let trace_cmd =
     Olly_trace.trace_cmd
       [ (module Olly_format_fuchsia); (module Olly_format_json) ]
-  and gc_stats_cmd = Olly_gc_stats.gc_stats_cmd in
-  Olly_common.Cli.main "olly" [ trace_cmd; gc_stats_cmd ]
+  and gc_stats_cmd = Olly_gc_stats.gc_stats_cmd
+  and gen_tables_cmd = Olly_gen_tables.cmd in
+  Olly_common.Cli.main "olly" [ trace_cmd; gc_stats_cmd; gen_tables_cmd ]

bin/olly_bare.ml

@@ -1,3 +1,4 @@
 let () =
-  let trace_cmd = Olly_trace.trace_cmd [ (module Olly_format_json) ] in
-  Olly_common.Cli.main "olly_bare" [ trace_cmd ]
+  let trace_cmd = Olly_trace.trace_cmd [ (module Olly_format_json) ]
+  and gen_tables_cmd = Olly_gen_tables.cmd in
+  Olly_common.Cli.main "olly_bare" [ trace_cmd; gen_tables_cmd ]

lib/olly_common/cli.ml

@@ -42,6 +42,21 @@ let exec_args p =
   in
   Arg.(required & pos p (some string) None & info [] ~docv:"EXECUTABLE" ~doc)
 
+let src_table_args =
+  let doc =
+    "Load a runtime events name table for event translation, for forwards \
+     compatibility with newer OCaml versions.\n\
+     See `olly-gen-tables`."
+  in
+  Arg.(
+    value & opt (some non_dir_file) None & info [ "table" ] ~docv:"PATH" ~doc)
+
+let common_args p =
+  let combine src_table_path exec_args : Launch.common_args =
+    { src_table_path; exec_args }
+  in
+  Term.(const combine $ src_table_args $ exec_args p)
+
 let main name commands =
   let help_cmd =
     let topic =

lib/olly_common/dune

@@ -1,3 +1,3 @@
 (library
  (name olly_common)
- (libraries runtime_events unix cmdliner))
+ (libraries olly_rte_shim unix cmdliner))

lib/olly_common/launch.ml

@@ -1,3 +1,6 @@
+open Olly_rte_shim
+open Event
+
 let lost_events ring_id num =
   Printf.eprintf "[ring_id=%d] Lost %d events\n%!" ring_id num
 
@@ -53,47 +56,39 @@ let collect_events child callbacks =
   (* Do one more poll in case there are any remaining events we've missed *)
   Runtime_events.read_poll child.cursor callbacks None |> ignore
 
-type 'r acceptor_fn = int -> Runtime_events.Timestamp.t -> 'r
-
 type consumer_config = {
-  runtime_begin : (Runtime_events.runtime_phase -> unit) acceptor_fn;
-  runtime_end : (Runtime_events.runtime_phase -> unit) acceptor_fn;
-  runtime_counter : (Runtime_events.runtime_counter -> int -> unit) acceptor_fn;
-  lifecycle : (Runtime_events.lifecycle -> int option -> unit) acceptor_fn;
-  extra : Runtime_events.Callbacks.t -> Runtime_events.Callbacks.t;
+  handler : shim_callback;
   init : unit -> unit;
   cleanup : unit -> unit;
 }
 
 let empty_config =
-  {
-    runtime_begin = (fun _ _ _ -> ());
-    runtime_end = (fun _ _ _ -> ());
-    runtime_counter = (fun _ _ _ _ -> ());
-    lifecycle = (fun _ _ _ _ -> ());
-    extra = Fun.id;
-    init = (fun () -> ());
-    cleanup = (fun () -> ());
-  }
+  { handler = (fun _ -> ()); init = (fun () -> ()); cleanup = (fun () -> ()) }
+
+type common_args = { exec_args : string; src_table_path : string option }
+
+let our_handler (k : shim_callback) (evt : event) =
+  match evt.tag with
+  | Lost_events -> (
+      match evt.kind with Counter num -> lost_events evt.ring_id num | _ -> ())
+  | _ -> k evt
+
+let make_shim_callback src_table_path handler =
+  let map_names =
+    match src_table_path with
+    | None -> Construct.builtin_names
+    | Some path ->
+        Tabling.tabled_names_and_tags
+          ~actual:(Tabling.parse_from_yaml_file path)
+          ~builtin:Construct.builtin_name_table
+  in
+  our_handler (map_names handler)
 
-let olly config exec_args =
+let olly config { exec_args; src_table_path } =
   config.init ();
   Fun.protect ~finally:config.cleanup (fun () ->
       let child = exec_process exec_args in
       Fun.protect ~finally:child.close (fun () ->
-          let callbacks =
-            let {
-              runtime_begin;
-              runtime_end;
-              runtime_counter;
-              lifecycle;
-              extra;
-              _;
-            } =
-              config
-            in
-            Runtime_events.Callbacks.create ~runtime_begin ~runtime_end
-              ~runtime_counter ~lifecycle ~lost_events ()
-            |> extra
-          in
+          let cb = make_shim_callback src_table_path config.handler in
+          let callbacks = Construct.make_callbacks cb in
           collect_events child callbacks))

lib/olly_gc_stats/olly_gc_stats.ml

@@ -8,14 +8,47 @@ let wall_time = { start_time = 0.; end_time = 0. }
 let total_cpu_time = ref 0.
 let domain_gc_times = Array.make 128 0
 
-let lifecycle _domain_id _ts lifecycle_event _data =
-  match lifecycle_event with
-  | Runtime_events.EV_RING_START -> wall_time.start_time <- Unix.gettimeofday ()
-  | Runtime_events.EV_RING_STOP ->
-      wall_time.end_time <- Unix.gettimeofday ();
-      let times = Unix.times () in
-      total_cpu_time := times.tms_utime +. times.tms_cutime
-  | _ -> ()
+let make_callbacks hist =
+  let open Olly_rte_shim in
+  let open Event in
+  let current_event = Hashtbl.create 13 in
+  let is_gc_phase phase =
+    match phase with
+    | Runtime_events.EV_MAJOR | Runtime_events.EV_STW_LEADER
+    | Runtime_events.EV_INTERRUPT_REMOTE ->
+        true
+    | _ -> false
+  in
+  let handle evt =
+    let { ring_id; ts; _ } = evt in
+    match evt.tag with
+    | Runtime_phase phase -> (
+        if evt.kind = SpanBegin then (
+          if is_gc_phase phase then
+            match Hashtbl.find_opt current_event ring_id with
+            | None -> Hashtbl.add current_event ring_id (phase, ts)
+            | _ -> ())
+        else
+          match Hashtbl.find_opt current_event ring_id with
+          | Some (saved_phase, saved_ts) when saved_phase = phase ->
+              Hashtbl.remove current_event ring_id;
+              let latency = Int64.to_int (Int64.sub ts saved_ts) in
+              assert (H.record_value hist latency);
+              total_gc_time := !total_gc_time + latency;
+              domain_gc_times.(ring_id) <- domain_gc_times.(ring_id) + latency
+          | _ -> ())
+    | Lifecycle lifecycle_event -> (
+        match lifecycle_event with
+        | Runtime_events.EV_RING_START ->
+            wall_time.start_time <- Unix.gettimeofday ()
+        | Runtime_events.EV_RING_STOP ->
+            wall_time.end_time <- Unix.gettimeofday ();
+            let times = Unix.times () in
+            total_cpu_time := times.tms_utime +. times.tms_cutime
+        | _ -> ())
+    | _ -> ()
+  in
+  handle
 
 let print_percentiles json output hist =
   let ms ns = ns /. 1000000. in
@@ -89,40 +122,14 @@ let print_percentiles json output hist =
           (float_of_int (H.value_at_percentile hist p) |> ms)))
 
 let gc_stats json output exec_args =
-  let current_event = Hashtbl.create 13 in
   let hist =
     H.init ~lowest_discernible_value:10 ~highest_trackable_value:10_000_000_000
       ~significant_figures:3
   in
-  let is_gc_phase phase =
-    match phase with
-    | Runtime_events.EV_MAJOR | Runtime_events.EV_STW_LEADER
-    | Runtime_events.EV_INTERRUPT_REMOTE ->
-        true
-    | _ -> false
-  in
-  let runtime_begin ring_id ts phase =
-    if is_gc_phase phase then
-      match Hashtbl.find_opt current_event ring_id with
-      | None -> Hashtbl.add current_event ring_id (phase, Ts.to_int64 ts)
-      | _ -> ()
-  in
-  let runtime_end ring_id ts phase =
-    match Hashtbl.find_opt current_event ring_id with
-    | Some (saved_phase, saved_ts) when saved_phase = phase ->
-        Hashtbl.remove current_event ring_id;
-        let latency = Int64.to_int (Int64.sub (Ts.to_int64 ts) saved_ts) in
-        assert (H.record_value hist latency);
-        total_gc_time := !total_gc_time + latency;
-        domain_gc_times.(ring_id) <- domain_gc_times.(ring_id) + latency
-    | _ -> ()
-  in
-  let init = Fun.id in
-  let cleanup () = print_percentiles json output hist in
-  let open Olly_common.Launch in
-  olly
-    { empty_config with runtime_begin; runtime_end; lifecycle; init; cleanup }
-    exec_args
+  let handler = make_callbacks hist
+  and init () = ()
+  and cleanup () = print_percentiles json output hist in
+  Olly_common.Launch.olly { handler; init; cleanup } exec_args
 
 let gc_stats_cmd =
   let open Cmdliner in
@@ -171,4 +178,4 @@ let gc_stats_cmd =
   in
   let doc = "Report the GC latency profile and stats." in
   let info = Cmd.info "gc-stats" ~doc ~sdocs ~man in
-  Cmd.v info Term.(const gc_stats $ json_option $ output_option $ exec_args 0)
+  Cmd.v info Term.(const gc_stats $ json_option $ output_option $ common_args 0)

lib/olly_rte_shim/construct.ml

@@ -0,0 +1,75 @@
+open Event
+open Runtime_events
+
+let builtin_names (k : shim_callback) (evt : event) : unit =
+  k
+  @@
+  match evt.tag with
+  | Runtime_phase ph -> { evt with name = runtime_phase_name ph }
+  | Runtime_counter cnt -> { evt with name = runtime_counter_name cnt }
+  | Lifecycle lc -> { evt with name = lifecycle_name lc }
+  | _ -> evt
+
+let builtin_name_table = Builtin_name_table.name_table
+
+let make_callbacks (sc : shim_callback) : Callbacks.t =
+  let runtime_begin ring_id ts ph =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = "?";
+        tag = Runtime_phase ph;
+        kind = SpanBegin;
+      }
+  and runtime_end ring_id ts ph =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = "?";
+        tag = Runtime_phase ph;
+        kind = SpanEnd;
+      }
+  and runtime_counter ring_id ts cntr cnt =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = "?";
+        tag = Runtime_counter cntr;
+        kind = Counter cnt;
+      }
+  and alloc ring_id ts allocs =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = "alloc";
+        tag = Alloc;
+        kind = IntArray allocs;
+      }
+  and lifecycle ring_id ts lc arg =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = "?";
+        tag = Lifecycle lc;
+        kind = MaybeInt arg;
+      }
+  and lost_events ring_id cnt =
+    sc
+      {
+        ring_id;
+        ts = 0L;
+        name = "lost_events";
+        tag = Lost_events;
+        kind = Counter cnt;
+      }
+  in
+  let cb =
+    Callbacks.create ~runtime_begin ~runtime_end ~runtime_counter ~alloc
+      ~lifecycle ~lost_events ()
+  in
+  Custom_events.add_to cb sc

lib/olly_rte_shim/custom_events.no.ml

@@ -0,0 +1 @@
+let add_to cb _ = cb

lib/olly_rte_shim/custom_events.yes.ml

@@ -0,0 +1,33 @@
+open Event
+open Runtime_events
+
+type _ custom_type = ..
+
+type _ custom_type +=
+  | Span : Type.span custom_type
+  | Int : int custom_type
+  | Unit : unit custom_type
+
+type tag += Custom : 'a User.t * 'a custom_type -> tag
+
+let from_int x = Counter x
+let from_unit () = Instant
+
+let from_span (s : Type.span) =
+  match s with Begin -> SpanBegin | End -> SpanEnd
+
+let add_to cb sc =
+  let emit cty get_kind ring_id ts evt value =
+    sc
+      {
+        ring_id;
+        ts = ts_to_int64 ts;
+        name = User.name evt;
+        tag = Custom (evt, cty);
+        kind = get_kind value;
+      }
+  in
+  cb
+  |> Callbacks.add_user_event Type.span (emit Span from_span)
+  |> Callbacks.add_user_event Type.int (emit Int from_int)
+  |> Callbacks.add_user_event Type.unit (emit Unit from_unit)

lib/olly_rte_shim/dune

@@ -0,0 +1,37 @@
+(library
+ (name olly_rte_shim)
+ (modules construct custom_events event tabling builtin_name_table)
+ (libraries runtime_events))
+
+(library
+ (name olly_gen_tables)
+ (modules olly_gen_tables)
+ (libraries str cmdliner))
+
+(executable
+ (name gen_tables)
+ (libraries olly_gen_tables)
+ (modules gen_tables))
+
+(rule
+ (target custom_events.ml)
+ (enabled_if
+  (>= %{ocaml_version} 5.1.0))
+ (action
+  (copy# custom_events.yes.ml %{target})))
+
+(rule
+ (target custom_events.ml)
+ (enabled_if
+  (< %{ocaml_version} 5.1.0))
+ (action
+  (copy# custom_events.no.ml %{target})))
+
+(rule
+ (target builtin_name_table.ml)
+ (action
+  (run
+   ./gen_tables.exe
+   --output=%{target}
+   --format=ml
+   %{ocaml_where}/caml/runtime_events.h)))