Merge pull request #17 from talex5/link-domains

Link spawned domains to their parent

Author: talex5

lib/layout.ml

@@ -62,11 +62,16 @@ and item = {
 module Ring = struct
   type id = Trace.Ring.id
 
+  type root = {
+    mutable parent : (timestamp * int) option;
+    mutable cc : (timestamp * item) option;
+  }
+
   type t = {
     events : (timestamp * string list) array;
     mutable y : int;
     mutable height : int;
-    mutable roots : (timestamp * item) list;
+    mutable roots : root list;
   }
 end
 
@@ -149,7 +154,8 @@ let layout ~duration (ring : Ring.t) =
     max_y := max !max_y i.y;
     if debug_layout then Fmt.epr "%d is at %d+%d@." i.id y i.height;
   in
-  let visit_domain (_ts, (i : item)) =
+  let visit_domain root =
+    root.Ring.cc |> Option.iter @@ fun (_ts, (i : item)) ->
     i.y <- ring.y + 1;
     i.height <- 1;
     i.end_cc_label <- None;
@@ -160,8 +166,8 @@ let layout ~duration (ring : Ring.t) =
           visit ~y:(ring.y + i.height) child;
           i.height <- child.y - ring.y + child.height;
           if i.end_cc_label = None then (
-              i.end_cc_label <- child.end_cc_label;
-            );
+            i.end_cc_label <- child.end_cc_label;
+          );
       );
   in
   List.iter visit_domain ring.roots;
@@ -208,9 +214,15 @@ let of_trace (trace : Trace.t) =
   and import_events events =
     events |> List.rev |> List.map (fun (ts, x) -> (time ts, map_event import x)) |> Array.of_list
   in
+  let import_root { Trace.Ring.parent; cc } =
+    {
+      Ring.parent = Option.map (fun (ts, id) -> time ts, id) parent;
+      cc = Option.map (fun (ts, i) -> time ts, import i) cc;
+    }
+  in
   let import_ring r =
     let events = List.map (fun (ts, s) -> time ts, s) r.Trace.Ring.events |> List.rev |> Array.of_list in
-    let roots = List.map (fun (ts, i) -> time ts, import i) (List.rev r.roots) in
+    let roots = List.map import_root (List.rev r.roots) in
     { Ring.events; y = 0; height = 1; roots }
   in
   let rings = Trace.Rings.map import_ring trace.rings in

lib/render.ml

@@ -47,6 +47,9 @@ module Make (C : CANVAS) = struct
 
     let running_fiber cr =
       C.set_source_rgb cr ~r:0.4 ~g:0.8 ~b:0.4
+
+    let suspended_fiber cr =
+      C.set_source_rgb cr ~r:0.4 ~g:0.4 ~b:0.4
   end
 
   (** Draw [msg] in the area (min_x, max_x) and ideally centred at [x]. *)
@@ -155,7 +158,7 @@ module Make (C : CANVAS) = struct
             let x1 = View.x_of_time v t1 in
             let w = x1 -. x0 in
             begin match stack with
-              | `Suspend _ :: _ -> C.set_source_rgb cr ~r:0.4 ~g:0.4 ~b:0.4
+              | `Suspend _ :: _ -> Style.suspended_fiber cr
               | `Span _ :: _ -> C.set_source_rgb cr ~r:0.5 ~g:0.9 ~b:0.5
               | [] -> Style.running_fiber cr
             end;
@@ -210,7 +213,7 @@ module Make (C : CANVAS) = struct
     done;
     fn (v.View.layout.duration, [])
 
-  let render_gc_events v cr (ring : Layout.Ring.t) =
+  let render_gc_events v cr (ring : Layout.Ring.t) layer =
     let y = y_of_row v ring.y in
     let h = float ring.height *. Style.line_spacing in
     let prev_stack = ref [] in
@@ -227,23 +230,52 @@ module Make (C : CANVAS) = struct
           | [] -> ()
           | op :: p ->
             let g = 1.0 -. min 1.0 (0.1 *. float (List.length stack)) in
-            C.set_source_rgba cr ~r:g ~g:g ~b:(g /. 2.) ~a:0.9;
-            C.rectangle cr ~x:x0 ~y ~w ~h;
-            C.fill cr;
-            if p == !prev_stack then (
-              let clip_area = (w -. 0.2, v.height) in
-              if g < 0.5 then C.set_source_rgb cr ~r:1.0 ~g:1.0 ~b:1.0
-              else C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0;
-              C.paint_text cr ~x:(x0 +. 2.) ~y:(y +. 12.) op
-                ~clip_area
-            )
+            match layer with
+            | `Bg ->
+              C.set_source_rgb cr ~r:g ~g:g ~b:(g /. 2.);
+              C.rectangle cr ~x:x0 ~y ~w ~h;
+              C.fill cr
+            | `Fg ->
+              if p == !prev_stack then (
+                let clip_area = (w -. 0.2, v.height) in
+                if g < 0.5 then C.set_source_rgb cr ~r:1.0 ~g:1.0 ~b:1.0
+                else C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0;
+                C.paint_text cr ~x:(x0 +. 2.) ~y:(y +. 12.) op
+                  ~clip_area
+              )
         end;
         prev_stack := stack
       )
 
-  let render_ring v cr ring =
-    render_gc_events v cr ring;
-    List.iter (fun (_ts, cc) -> render_events v cr cc) ring.roots
+  let link_domain v cr ~x (fiber : Layout.item) (ring : Layout.Ring.t) =
+    let fiber_y = y_of_row v fiber.y +. Style.fiber_padding_top in
+    let ring_y = y_of_row v ring.y in
+    let (y1, y2) =
+      if fiber.y < ring.y then (
+        (fiber_y +. Style.fiber_height, ring_y +. float ring.height *. View.pixels_per_row)
+      ) else (
+        fiber_y, ring_y
+      )
+    in
+    Style.suspended_fiber cr;
+    C.move_to cr ~x ~y:y1;
+    C.line_to cr ~x ~y:y2;
+    C.stroke cr
+
+  let render_ring_bg v cr ring =
+    render_gc_events v cr ring `Bg;
+    ring.roots |> List.iter @@ fun (root : Layout.Ring.root) ->
+    C.set_line_width cr 4.0;
+    root.parent |> Option.iter (fun (ts, parent) ->
+        Layout.get v.layout parent |> Option.iter @@ fun (parent : Layout.item) ->
+        let x = View.x_of_time v ts in
+        link_domain v cr ~x parent ring
+      )
+
+  let render_ring v cr (ring : Layout.Ring.t) =
+    render_gc_events v cr ring `Fg;
+    ring.roots |> List.iter @@ fun (root : Layout.Ring.root) ->
+    root.cc |> Option.iter (fun (_ts, cc) -> render_events v cr cc)
 
   let render_grid v cr =
     C.set_line_width cr 1.0;
@@ -272,6 +304,7 @@ module Make (C : CANVAS) = struct
   let render (v : View.t) cr =
     C.set_source_rgb cr ~r:0.9 ~g:0.9 ~b:0.9;
     C.paint cr;
+    v.layout.rings |> Trace.Rings.iter (fun _id -> render_ring_bg v cr);
     render_grid v cr;
     C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0;
     v.layout.rings |> Trace.Rings.iter (fun _id -> render_ring v cr)

lib/trace.ml

@@ -32,10 +32,15 @@ and item = {
 module Ring = struct
   type id = int
 
+  type root = {
+    mutable parent : (timestamp * int) option;
+    mutable cc : (timestamp * item) option;
+  }
+
   type t = {
     mutable current_fiber : int option;
     mutable events : (timestamp * string list) list;
-    mutable roots : (timestamp * item) list;
+    mutable roots : root list;
   }
 
   let push t ts e =
@@ -136,7 +141,12 @@ let process_event t e =
         cc.parent <- Some parent_item;
         parent_fiber.inner_cc <- id
     | None ->
-      ring.roots <- (timestamp, cc) :: ring.roots
+        begin match ring.roots with
+        | root :: _ when root.cc = None -> root.cc <- Some (timestamp, cc)
+        | _ ->
+          let root = { Ring.parent = None; cc = Some (timestamp, cc) } in
+          ring.roots <- root :: ring.roots
+        end
     end
   | "eio", "cc", Duration_end ->
     fiber_of_thread t thread |> Option.iter @@ fun fiber ->
@@ -189,6 +199,12 @@ let process_event t e =
   | "gc", _, Duration_end ->
     let r = ring_of_thread t thread |> Option.get in
     Ring.pop r timestamp
+  | "eio", "domain-spawn", Instant ->
+    ring_of_thread t thread |> Option.iter (fun (ring : Ring.t) ->
+        let parent = List.assoc_opt "parent" args |> Option.get |> id_of_pointer in
+        let root = { Ring.parent = Some (timestamp, parent); cc = None } in
+        ring.roots <- root :: ring.roots
+      )
   | _ -> ()
 
 let process t reader =

src/record.ml

@@ -82,6 +82,8 @@ let callbacks t =
          Write.thread_wakeup ~cpu:ring_id ~ts t.fxt (Int64.of_int id)
        in
        (* Fmt.epr "%a@." Eio_runtime_events.pp_event e; *)
+       (* Allow matching unknown events so we can build with older Eio versions if needed. *)
+       let e = (e : Eio_runtime_events.event :> [> Eio_runtime_events.event]) in
        match e with
        | `Fiber id ->
          set_current_fiber id;
@@ -136,6 +138,10 @@ let callbacks t =
          Write.duration_begin t.fxt ~thread:(ring_thread t ring_id) ~ts ~name:"suspend-domain" ~category:"eio"
        | `Suspend_domain End ->
          Write.duration_end t.fxt ~thread:(ring_thread t ring_id) ~ts ~name:"suspend-domain" ~category:"eio"
+       | `Domain_spawn parent ->
+         Write.instant_event t.fxt ~thread ~ts ~name:"domain-spawn" ~category:"eio" ~args:[
+           "parent", `Pointer (Int64.of_int parent);
+         ];
        | _ -> ()
     )