Merge pull request #48 from robur-coop/dom0

Fix an issue when we want to transfer a task to dom0 when dom0 is busy with infinite tasks

lib/miou.ml

@@ -810,6 +810,10 @@ module Domain = struct
     in
     Miou_sequence.iter_node ~f:apply domain.hooks
 
+  let[@inline always] no_transfer pool =
+    ((Stdlib.Domain.self () :> int) == 0 && Queue.is_empty pool.to_dom0)
+    || (Stdlib.Domain.self () :> int) != 0
+
   let rec run pool (domain : domain) =
     run_hooks domain;
     match Heapq.extract_min_exn domain.tasks with
@@ -822,7 +826,10 @@ module Domain = struct
         once pool domain elt;
         if system_events_suspended domain then
           unblock_awaits_with_system_events pool domain;
-        if Heapq.is_empty domain.tasks = false && Atomic.get pool.tasks_is_empty
+        if
+          Heapq.is_empty domain.tasks = false
+          && Atomic.get pool.tasks_is_empty
+          && no_transfer pool
         then run pool domain
 
   let self () =

test/test_core.ml

@@ -819,14 +819,26 @@ let test41 =
   | exception Invalid_argument str ->
       Test.check (str = "The given orphans is owned by another promise")
 
+let test42 =
+  let description = {text|Transfer parallel task to dom0|text} in
+  Test.test ~title:"test42" ~description @@ fun () ->
+  Miou.run @@ fun () ->
+  let prm0 =
+    Miou.async @@ fun () ->
+    let rec go () = go (Miou.yield ()) in
+    go ()
+  in
+  let prm1 = Miou.call @@ fun () -> Miou.yield () in
+  Miou.await_exn prm1; Miou.cancel prm0; Test.check true
+
 let () =
   let tests =
     [
       test01; test02; test03; test04; test05; test06; test07; test08; test09
     ; test10; test11; test12; test13; test14; test15; test16; test17; test18
     ; test19; test20; test21; test22; test23; test24; test25; test26; test27
     ; test28; test29; test30; test31; test32; test33; test34; test35; test36
-    ; test37; test38; test39; test40; test41
+    ; test37; test38; test39; test40; test41; test42
     ]
   in
   let ({ Test.directory } as runner) =