Add ?verbose flag to test scheduler and add a test of fairness

Author: polytypic

example/guards.ml

@@ -97,7 +97,7 @@ let () =
      likely use e.g. the multififo or the random scheduler to compute with
      guarded case statements. *)
   let max_domains = Picos_domain.recommended_domain_count () in
-  Test_scheduler.run ~max_domains @@ fun () ->
+  Test_scheduler.run ~verbose:true ~max_domains @@ fun () ->
   Run.all
     [
       (fun () -> assert (42 = guard1 ()));

test/dune

@@ -241,6 +241,7 @@
   backoff
   domain_shims
   picos
+  picos_domain
   picos_std.finally
   picos_std.structured
   picos_std.sync

test/lib/test_scheduler/test_scheduler.ocaml4.ml

@@ -23,15 +23,22 @@ let init () =
     propagate ()
   end
 
-let run_fiber ?max_domains:_ ?allow_lwt:_ ?avoid_threads:_ ?fatal_exn_handler
-    fiber main =
+let explain () = Printf.printf "Testing with scheduler: threads\n%!"
+
+let run_fiber ?(verbose = false) ?max_domains:_ ?allow_lwt:_ ?avoid_threads:_
+    ?fatal_exn_handler fiber main =
   init ();
-  Picos_mux_thread.run_fiber ?fatal_exn_handler fiber main
+  if verbose then explain ();
+  try Picos_mux_thread.run_fiber ?fatal_exn_handler fiber main
+  with exn ->
+    if not verbose then explain ();
+    raise exn
 
-let run ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
+let run ?verbose ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
     ?(forbid = false) main =
   let computation = Computation.create ~mode:`LIFO () in
   let fiber = Fiber.create ~forbid computation in
   let main _ = Computation.capture computation main () in
-  run_fiber ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler fiber main;
+  run_fiber ?verbose ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
+    fiber main;
   Computation.await computation

test/lib/test_scheduler/test_scheduler.ocaml5.ml

@@ -26,7 +26,28 @@ let init () =
     propagate ()
   end
 
-let rec run_fiber ?(max_domains = 1) ?(allow_lwt = true)
+let explain scheduler ~quota ~n_domains =
+  let quota =
+    match scheduler with
+    | `Fifos | `Multififos -> Printf.sprintf " ~quota:%d" quota
+    | `Randos | `Thread | `Lwt -> ""
+  in
+  let n_domains =
+    match scheduler with
+    | `Multififos | `Randos -> Printf.sprintf " ~n_domains:%d" n_domains
+    | `Fifos | `Thread | `Lwt -> ""
+  in
+  let scheduler =
+    match scheduler with
+    | `Fifos -> "fifos"
+    | `Multififos -> "multififos"
+    | `Randos -> "randos"
+    | `Thread -> "thread"
+    | `Lwt -> "lwt"
+  in
+  Printf.printf "Testing with scheduler: %s%s%s\n%!" scheduler quota n_domains
+
+let rec run_fiber ?(verbose = false) ?(max_domains = 1) ?(allow_lwt = true)
     ?(avoid_threads = false) ?fatal_exn_handler fiber main =
   init ();
   let scheduler =
@@ -80,26 +101,21 @@ let rec run_fiber ?(max_domains = 1) ?(allow_lwt = true)
             (fun () -> Picos_mux_thread.run_fiber ?fatal_exn_handler fiber main)
   with
   | None ->
-      run_fiber ~max_domains ~allow_lwt ~avoid_threads ?fatal_exn_handler fiber
-        main
+      run_fiber ~verbose ~max_domains ~allow_lwt ~avoid_threads
+        ?fatal_exn_handler fiber main
   | Some run -> begin
+      if verbose then explain scheduler ~quota ~n_domains;
       try run ()
       with exn ->
-        Printf.printf "Test_scheduler: %s ~quota:%d ~n_domains:%d\n%!"
-          (match scheduler with
-          | `Fifos -> "fifos"
-          | `Multififos -> "multififos"
-          | `Randos -> "randos"
-          | `Thread -> "thread"
-          | `Lwt -> "lwt")
-          quota n_domains;
+        if not verbose then explain scheduler ~quota ~n_domains;
         raise exn
     end
 
-let run ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
+let run ?verbose ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
     ?(forbid = false) main =
   let computation = Computation.create ~mode:`LIFO () in
   let fiber = Fiber.create ~forbid computation in
   let main _ = Computation.capture computation main () in
-  run_fiber ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler fiber main;
+  run_fiber ?verbose ?max_domains ?allow_lwt ?avoid_threads ?fatal_exn_handler
+    fiber main;
   Computation.await computation

test/test_schedulers.ml

@@ -181,6 +181,60 @@ let test_cross_scheduler_wakeup () =
     end
   done
 
+let () =
+  let max_domains = Random.int (Picos_domain.recommended_domain_count ()) + 1 in
+  Test_scheduler.run ~verbose:true ~max_domains @@ fun () ->
+  let n_fibers = 100 in
+  let min_yields_per_fiber = 10_000 in
+  let yields = Float.Array.make n_fibers 0.0 in
+  begin
+    let countdown = Atomic.make n_fibers in
+    Flock.join_after @@ fun () ->
+    for i = 0 to n_fibers - 1 do
+      Flock.fork @@ fun () ->
+      let counter = ref 0 in
+      try
+        while true do
+          Control.yield ();
+          incr counter;
+          if !counter = min_yields_per_fiber then
+            if 1 = Atomic.fetch_and_add countdown (-1) then Flock.terminate ()
+        done
+      with Control.Terminate ->
+        Float.Array.set yields i (float !counter /. float min_yields_per_fiber)
+    done
+  end;
+  let mean_of xs =
+    Float.Array.fold_left ( +. ) 0.0 xs /. Float.of_int (Float.Array.length xs)
+  in
+  let sd_of xs ~mean =
+    Float.sqrt
+      (mean_of
+         (Float.Array.map
+            (fun v ->
+              let d = v -. mean in
+              d *. d)
+            xs))
+  in
+  let median_of xs =
+    Float.Array.sort Float.compare xs;
+    let n = Float.Array.length xs in
+    if n land 1 = 0 then
+      (Float.Array.get xs ((n asr 1) - 1) +. Float.Array.get xs (n asr 1))
+      /. 2.0
+    else Float.Array.get xs (n asr 1)
+  in
+  let mean = mean_of yields in
+  let median = median_of yields in
+  let sd = sd_of yields ~mean in
+  Printf.printf
+    "Fairness of %d fibers performing at least %d yields:\n\
+    \      sd: %f -- ideally 0\n\
+    \    mean: %f -- ideally 1\n\
+    \  median: %f -- ideally 1\n\
+     %!"
+    n_fibers min_yields_per_fiber sd mean median
+
 let () =
   [
     ("Trivial main returns", [ Alcotest.test_case "" `Quick test_returns ]);