Merge pull request #28 from talex5/fix-staircasing

talex5 · web-flow · commit 36995a9d9531 · 2024-05-13T14:10:07.000+01:00
Fix staircasing in layout
diff --git a/examples/limiter/dune b/examples/limiter/dune
@@ -0,0 +1,3 @@
+(executable
+  (name main)
+  (libraries eio.mock))
diff --git a/examples/limiter/main.ml b/examples/limiter/main.ml
@@ -0,0 +1,14 @@
+(* This runs jobs 4 at a time. It's useful to check eio-trace's layout algorithm. *)
+
+open Eio.Std
+
+let lock = Eio.Mutex.create ()
+
+let main () =
+  List.init 15 Fun.id
+  |> Fiber.List.iter ~max_fibers:4 (fun i ->
+      if i = 4 then Fiber.both Fiber.yield Fiber.yield;
+      Eio.Mutex.use_ro lock Fiber.yield)
+
+let () =
+  Eio_mock.Backend.run main
diff --git a/lib/layout.ml b/lib/layout.ml
@@ -104,73 +104,88 @@ let as_string = function
   | `String s -> s
   | _ -> failwith "Not a string"
 
-let layout ~duration (ring : Ring.t) =
+(* Walk the tree rooted at [i], calculating heights and positions.
+   Note: visited items have their [y] fields set to their position relative to
+   their parent. This gets turned into an absolute position later. *)
+let rec layout_item ~duration (i : item) =
+  i.y <- 0;
+  i.height <- 1;
+  i.end_cc_label <- None;
+  let intervals = ref [] in
+  (* Position CCs at the same place as [i]. *)
+  i.events |> Array.iter (fun (ts, e) ->
+      match e with
+      | Log _ | Error _ ->
+        if i.end_cc_label = None then (
+          i.end_cc_label <- Some ts;
+        )
+      | Add_fiber _ -> ()
+      | Create_cc (_, child) ->
+        if debug_layout then Fmt.epr "%d creates cc %d (%a)@." i.id child.id Fmt.(option string) child.name;
+        if i.end_cc_label = None then (
+          i.end_cc_label <- Some ts;
+        );
+        layout_item ~duration child;
+        i.height <- max i.height child.height;
+        let stop = Option.value child.end_time ~default:duration in
+        intervals := { Itv.value = child; start = ts; stop } :: !intervals;
+    );
+  if i.end_cc_label = None then i.end_cc_label <- i.end_time;
+  let n_ccs = List.length !intervals in
+  (* Position fibers where there is space, not overlapping CCs or other fibers. *)
+  i.events |> Array.iter (fun (ts, e) ->
+      match e with
+      | Log _ | Error _ | Create_cc _ -> ()
+      | Add_fiber { parent; child } ->
+        if debug_layout then Fmt.epr "%d gets fiber %d, created by %d@." i.id child.id parent;
+        let stop = Option.value child.end_time ~default:duration in
+        intervals := { Itv.value = child; start = ts; stop } :: !intervals;
+    );
+  let intervals = List.rev !intervals in
+  let itv = Itv.create intervals in
+  let height = ref i.height in
+  intervals |> List.to_seq |> Seq.drop n_ccs |> Seq.iter (fun (interval : _ Itv.interval) ->
+      let space = Space.create 1 in
+      let adjust other = Space.mark_range space other.y (other.y + other.height) in
+      Itv.iter_overlaps adjust interval.start interval.stop itv;
+      let f = interval.Itv.value in
+      layout_item ~duration f;
+      f.y <- Space.first_free space f.height;
+      height := max !height (f.y + f.height);
+    );
+  i.height <- !height
+
+(* Walk the tree rooted at [i] converting relative [y] values to absolute ones,
+   using [parent] for zero. *)
+let rec make_y_absolute i parent =
+  i.y <- i.y + parent;
+  if debug_layout then Fmt.epr "%d is at %d (height %d)@." i.id i.y i.height;
+  i.events |> Array.iter (fun (_ts, e) ->
+      match e with
+      | Log _ | Error _ -> ()
+      | Add_fiber { parent = _; child }
+      | Create_cc (_, child) -> make_y_absolute child i.y
+    )
+
+let layout_ring ~duration (ring : Ring.t) =
   let max_y = ref 1 in
-  let rec visit ~y (i : item) =
-    if debug_layout then Fmt.epr "%d is at %d@." i.id y;
-    i.y <- y;
-    i.height <- 1;
-    i.end_cc_label <- None;
-    let intervals = ref [] in
-    i.events |> Array.iter (fun (ts, e) ->
-        match e with
-        | Log _ | Error _ ->
-          if i.end_cc_label = None then (
-              i.end_cc_label <- Some ts;
-            )
-        | Add_fiber _ -> ()
-        | Create_cc (_, child) ->
-          if debug_layout then Fmt.epr "%d creates cc %d (%a)@." i.id child.id Fmt.(option string) child.name;
-          if i.end_cc_label = None then (
-              i.end_cc_label <- Some ts;
-            );
-          visit ~y child;
-          i.height <- max i.height child.height;
-          let stop = Option.value child.end_time ~default:duration in
-          intervals := { Itv.value = child; start = ts; stop } :: !intervals;
-      );
-    if i.end_cc_label = None then i.end_cc_label <- i.end_time;
-    let start_fibers = List.length !intervals in
-    i.events |> Array.iter (fun (ts, e) ->
-        match e with
-        | Log _ | Error _ | Create_cc _ -> ()
-        | Add_fiber { parent; child } ->
-          if debug_layout then Fmt.epr "%d gets fiber %d, created by %d@." i.id child.id parent;
-          let stop = Option.value child.end_time ~default:duration in
-          intervals := { Itv.value = child; start = ts; stop } :: !intervals;
-      );
-    let intervals = List.rev !intervals in
-    let itv = Itv.create intervals in
-    let height = ref i.height in
-    intervals |> List.to_seq |> Seq.drop start_fibers |> Seq.iter (fun (interval : _ Itv.interval) ->
-        let y = ref (i.y + 1) in
-        let adjust other =
-          y := max !y (other.y + other.height);
-        in
-        Itv.iter_overlaps adjust interval.start interval.stop itv;
-        let f = interval.Itv.value in
-        visit ~y:!y f;
-        height := max !height (f.y - i.y + f.height);
-      );
-    i.height <- !height;
-    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 root =
     root.Ring.cc |> Option.iter @@ fun (_ts, (i : item)) ->
-    i.y <- ring.y + 1;
+    i.y <- 1;
     i.height <- 1;
     i.end_cc_label <- None;
     i.events |> Array.iter (fun (_ts, e) ->
         match e with
         | Log _ | Error _ | Create_cc _ -> ()
         | Add_fiber { parent = _; child } ->
-          visit ~y:(ring.y + i.height) child;
-          i.height <- child.y - ring.y + child.height;
+          layout_item ~duration child;
+          i.height <- max i.height (child.y + child.height);
           if i.end_cc_label = None then (
             i.end_cc_label <- child.end_cc_label;
           );
       );
+    make_y_absolute i ring.y;
+    max_y := max !max_y (i.y + i.height - 1);
   in
   List.iter visit_domain ring.roots;
   ring.height <- (!max_y + 1) - ring.y
@@ -233,7 +248,7 @@ let of_trace (trace : Trace.t) =
   let y = ref 0 in
   rings |> Trace.Rings.iter (fun _ (ring : Ring.t) ->
       ring.y <- !y;
-      layout ring ~duration;
+      layout_ring ring ~duration;
       y := !y + ring.height;
     );
   let height = !y in
diff --git a/lib/space.ml b/lib/space.ml
@@ -0,0 +1,53 @@
+(* Tracks which of a set of rows have free space.
+   For large sets it might be more efficient to use an integer tree,
+   but layouts that large are fairly unusable anyway. *)
+
+type t = {
+  start : int;
+  mutable buf : bytes;
+}
+
+let create start = { start; buf = Bytes.empty }
+
+let mark t row =
+  let i = row - t.start in
+  if i >= 0 then (
+    let byte = i lsr 3 in
+    if byte >= Bytes.length t.buf then (
+      let old_buf = t.buf in
+      let old_len = Bytes.length old_buf in
+      let new_len = max (byte + 1) (old_len * 2) in
+      let new_buf = Bytes.extend old_buf 0 (new_len - old_len) in
+      Bytes.fill new_buf old_len (new_len - old_len) (Char.chr 0);
+      t.buf <- new_buf
+    );
+    let buf = t.buf in
+    let v = Bytes.get_uint8 buf byte lor (1 lsl (i land 0x7)) in
+    Bytes.set_uint8 buf byte v
+  )
+
+let mark_range t a b =
+  let a = max a t.start in
+  for i = a to b - 1 do
+    mark t i
+  done
+
+let rec find_free_bit v start =
+  if v land 1 = 0 then start
+  else find_free_bit (v lsr 1) (start + 1)
+
+let (.%[]) t row =
+  let i = row - t.start in
+  let buf = t.buf in
+  let byte = i lsr 3 in
+  if byte >= Bytes.length buf then false
+  else (Bytes.get_uint8 buf byte land (1 lsl (i land 7))) <> 0
+
+let first_free t len =
+  assert (len >= 0);
+  let rec check i need =
+    if need = 0 then i - len
+    else if t.%[i] then check (i + 1) len
+    else check (i + 1) (need - 1)
+  in
+  check t.start len
diff --git a/test/test.ml b/test/test.ml
@@ -1,4 +1,5 @@
 module Itv = Eio_trace.Itv
+module Space = Eio_trace.Space
 
 let span = Crowbar.(map [uint8; uint8]) (fun start len -> (float start, float (start + len)))
 
@@ -24,5 +25,15 @@ let test_ivt spans (start, stop) =
       )
     )
 
+let test_space start used height =
+  let s = Space.create start in
+  List.iter (Space.mark s) used;
+  let free = Space.first_free s height in
+  for i = free to free + height - 1 do
+    if List.mem i used then
+      Crowbar.failf "Row %d is used, but was returned as free (%d+%d)!" i free height
+  done
+
 let () =
-  Crowbar.(add_test ~name:"ivt" [list span; span] test_ivt)
+  Crowbar.(add_test ~name:"ivt" [list span; span] test_ivt);
+  Crowbar.(add_test ~name:"space" [int8; list int8; uint8] test_space)

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+(executable`
	`2`	`+ (name main)`
	`3`	`+ (libraries eio.mock))`