Merge pull request #36 from c-cube/simon/fix-35

fix domain pool: block signals in background threads

src/core/worker_loop_.ml

@@ -144,22 +144,7 @@ module Fine_grained (Args : FINE_GRAINED_ARGS) () = struct
     if !state <> New then invalid_arg "worker_loop.setup: not a new instance";
     state := Ready;
 
-    if block_signals then (
+    if block_signals then Signals_.ignore_signals_ ();
-      try
-        ignore
-          (Unix.sigprocmask SIG_BLOCK
-             [
-               Sys.sigterm;
-               Sys.sigpipe;
-               Sys.sigint;
-               Sys.sigchld;
-               Sys.sigalrm;
-               Sys.sigusr1;
-               Sys.sigusr2;
-             ]
-            : _ list)
-      with _ -> ()
-    );
 
     TLS.set Runner.For_runner_implementors.k_cur_runner runner;
 

src/dpool/moonpool_dpool.ml

@@ -15,19 +15,23 @@ module Bb_queue = struct
     if was_empty then Condition.broadcast self.cond;
     Mutex.unlock self.mutex
 
-  let pop (self : 'a t) : 'a =
+  let pop (type a) (self : a t) : a =
-    Mutex.lock self.mutex;
+    let module M = struct
-    let rec loop () =
+      exception Found of a
-      if Queue.is_empty self.q then (
+    end in
-        Condition.wait self.cond self.mutex;
+    try
-        (loop [@tailcall]) ()
+      Mutex.lock self.mutex;
-      ) else (
+      while true do
-        let x = Queue.pop self.q in
+        if Queue.is_empty self.q then
-        Mutex.unlock self.mutex;
+          Condition.wait self.cond self.mutex
-        x
+        else (
-      )
+          let x = Queue.pop self.q in
-    in
+          Mutex.unlock self.mutex;
-    loop ()
+          raise (M.Found x)
+        )
+      done;
+      assert false
+    with M.Found x -> x
 end
 
 module Lock = struct
@@ -38,13 +42,13 @@ module Lock = struct
 
   let create content : _ t = { mutex = Mutex.create (); content }
 
-  let with_ (self : _ t) f =
+  let[@inline never] with_ (self : _ t) f =
     Mutex.lock self.mutex;
-    try
+    match f self.content with
-      let x = f self.content in
+    | x ->
       Mutex.unlock self.mutex;
       x
-    with e ->
+    | exception e ->
       Mutex.unlock self.mutex;
       raise e
 
@@ -95,6 +99,7 @@ let domains_ : (worker_state option * Domain_.t option) Lock.t array =
       a [Pool.with_] or [Pool.create() … Pool.shutdown()] in a tight loop), and
       if nothing happens it tries to stop to free resources. *)
 let work_ idx (st : worker_state) : unit =
+  Signals_.ignore_signals_ ();
   let main_loop () =
     let continue = ref true in
     while !continue do

src/private/signals_.ml

@@ -0,0 +1,15 @@
+let ignore_signals_ () =
+  try
+    Thread.sigmask SIG_BLOCK
+      [
+        Sys.sigpipe;
+        Sys.sigbus;
+        Sys.sigterm;
+        Sys.sigchld;
+        Sys.sigalrm;
+        Sys.sigint;
+        Sys.sigusr1;
+        Sys.sigusr2;
+      ]
+    |> ignore
+  with _ -> ()