test: update fiber tests

test/fiber/t_fib1.expected

@@ -27,8 +27,8 @@ main fiber exited
 ============
 start
 wait for subs
-await fiber 0
 fiber 0 resolved as ok
+await fiber 0
 res 0 = 0
 await fiber 1
 fiber 1 resolved as ok
@@ -46,9 +46,9 @@ await fiber 5
 fiber 5 resolved as ok
 res 5 = 5
 await fiber 6
+fiber 6 resolved as ok
 res 6 = 6
 await fiber 7
-fiber 6 resolved as ok
 I'm fiber 7 and I'm about to…
 sub-fiber 8 was cancelled
 fiber 8 resolved as error

test/fiber/t_fib1.ml

@@ -21,13 +21,13 @@ let () =
     let subs =
       List.init 5 (fun i ->
           F.spawn_link ~protect:false @@ fun () ->
-          Thread.delay 0.000_01;
+          Thread.delay (float i *. 0.01);
           i)
     in
 
     ignore
       (F.spawn_link ~protect:false @@ fun () ->
-       Thread.delay 0.2;
+       Thread.delay 0.4;
        logf "other fib done\n%!"
         : _ F.t);
     logf "wait for subs\n%!";

test/fiber/t_fls.ml

@@ -1 +1,170 @@
-(* TODO: test FLS *)
+open! Moonpool
+module A = Atomic
+module F = Moonpool_fib.Fiber
+module FLS = Moonpool_fib.Fls
+
+(* ### dummy little tracing system with local storage *)
+
+type span_id = int
+
+let k_parent : span_id option FLS.key = FLS.new_key ~init:(fun () -> None) ()
+let ( let@ ) = ( @@ )
+let spf = Printf.sprintf
+
+module Span = struct
+  let new_id_ : unit -> span_id =
+    let n = A.make 0 in
+    fun () -> A.fetch_and_add n 1
+
+  type t = {
+    id: span_id;
+    parent: span_id option;
+    msg: string;
+  }
+end
+
+module Tracer = struct
+  type t = { spans: Span.t list A.t }
+
+  let create () : t = { spans = A.make [] }
+  let get self = A.get self.spans
+
+  let add (self : t) span =
+    while
+      let old = A.get self.spans in
+      not (A.compare_and_set self.spans old (span :: old))
+    do
+      ()
+    done
+
+  let with_span self name f =
+    let id = Span.new_id_ () in
+    let parent = FLS.get k_parent in
+    let span = { Span.id; parent; msg = name } in
+    add self span;
+    FLS.with_value k_parent (Some id) f
+end
+
+module Render = struct
+  type span_tree = {
+    msg: string;  (** message of the span at the root *)
+    children: span_tree list;
+  }
+
+  type t = { roots: span_tree list }
+
+  let build (tracer : Tracer.t) : t =
+    let tops : (span_id, Span.t) Hashtbl.t = Hashtbl.create 16 in
+    let children : (span_id, Span.t list) Hashtbl.t = Hashtbl.create 16 in
+
+    (* everyone is a root at first *)
+    let all_spans = Tracer.get tracer in
+    List.iter (fun (sp : Span.t) -> Hashtbl.add tops sp.id sp) all_spans;
+
+    (* now consider the parenting relationships *)
+    let add_span_to_parent (span : Span.t) =
+      match span.parent with
+      | None -> ()
+      | Some p ->
+        Hashtbl.remove tops span.id;
+        let l = try Hashtbl.find children p with Not_found -> [] in
+        Hashtbl.replace children p (span :: l)
+    in
+    List.iter add_span_to_parent all_spans;
+
+    (* build the tree *)
+    let rec build_tree (sp : Span.t) : span_tree =
+      let children = try Hashtbl.find children sp.id with Not_found -> [] in
+      let children = List.map build_tree children |> List.sort Stdlib.compare in
+      { msg = sp.msg; children }
+    in
+
+    let roots =
+      Hashtbl.fold (fun _ sp l -> build_tree sp :: l) tops []
+      |> List.sort Stdlib.compare
+    in
+
+    { roots }
+
+  let pp (oc : out_channel) (self : t) : unit =
+    let rec pp_tree indent out (t : span_tree) =
+      let prefix = String.make indent ' ' in
+      Printf.fprintf out "%s%S\n" prefix t.msg;
+      List.iter (pp_tree (indent + 2) out) t.children
+    in
+    List.iter (pp_tree 2 oc) self.roots
+end
+
+let () =
+  let tracer = Tracer.create () in
+
+  let sub_sub_child ~idx ~idx_child ~idx_sub ~idx_sub_sub () =
+    let@ () =
+      Tracer.with_span tracer
+        (spf "child_%d.%d.%d.%d" idx idx_child idx_sub idx_sub_sub)
+    in
+
+    for j = 1 to 5 do
+      let@ () = Tracer.with_span tracer (spf "iter.loop %d" j) in
+      F.yield ()
+    done
+  in
+
+  let sub_child ~idx ~idx_child ~idx_sub () =
+    let@ () =
+      Tracer.with_span tracer (spf "child_%d.%d.%d" idx idx_child idx_sub)
+    in
+
+    for i = 1 to 10 do
+      let@ () = Tracer.with_span tracer (spf "iter.loop %02d" i) in
+      F.yield ()
+    done;
+
+    let subs =
+      List.init 2 (fun idx_sub_sub ->
+          F.spawn_link ~protect:true (fun () ->
+              sub_sub_child ~idx ~idx_child ~idx_sub ~idx_sub_sub ()))
+    in
+    List.iter F.await subs
+  in
+
+  let top_child ~idx ~idx_child () =
+    let@ () = Tracer.with_span tracer (spf "child.%d.%d" idx idx_child) in
+
+    let subs =
+      List.init 2 (fun k ->
+          F.spawn_link ~protect:true @@ fun () ->
+          sub_child ~idx ~idx_child ~idx_sub:k ())
+    in
+
+    let@ () =
+      Tracer.with_span tracer
+        (spf "child.%d.%d.99.await_children" idx idx_child)
+    in
+    List.iter F.await subs
+  in
+
+  let top idx =
+    let@ () = Tracer.with_span tracer (spf "top_%d" idx) in
+
+    let subs =
+      List.init 5 (fun j ->
+          F.spawn_link ~protect:true @@ fun () -> top_child ~idx ~idx_child:j ())
+    in
+
+    List.iter F.await subs
+  in
+
+  let@ pool = Ws_pool.with_ () in
+
+  let fibs =
+    List.init 8 (fun idx -> F.spawn_top ~on:pool (fun () -> top idx))
+  in
+  List.iter F.wait_block_exn fibs;
+
+  Printf.printf "tracing complete\n";
+  Printf.printf "spans:\n";
+  let tree = Render.build tracer in
+  Render.pp stdout tree;
+  Printf.printf "done\n%!";
+  ()