[thread] protect threads against sigalrm

This makes the implementation of Timeout on unix more reliable
since only the main thread will receive the signal for
timeout.

7 files changed, 16 insertions, 6 deletions

diff --git a/clib/cThread.ml b/clib/cThread.ml
index 0b7955aa28..c50768b88d 100644
--- a/clib/cThread.ml
+++ b/clib/cThread.ml
@@ -97,3 +97,10 @@ let thread_friendly_input_value ic =
     end
   with Unix.Unix_error _ | Sys_error _ -> raise End_of_file
 
+let protect_sigalrm f x =
+  begin try ignore(Thread.sigmask Unix.SIG_BLOCK [Sys.sigalrm])
+  with Invalid_argument _ -> () end;
+  f x
+
+let create f x =
+  Thread.create (protect_sigalrm f) x
diff --git a/clib/cThread.mli b/clib/cThread.mli
index acc5a60c09..b090479c4c 100644
--- a/clib/cThread.mli
+++ b/clib/cThread.mli
@@ -26,3 +26,6 @@ val thread_friendly_really_read :
   thread_ic -> Bytes.t -> off:int -> len:int -> unit
 val thread_friendly_really_read_line : thread_ic -> string
 
+(* Wrapper around Thread.create that blocks signals such as Sys.sigalrm (used
+ * for Timeout *)
+val create : ('a -> 'b) -> 'a -> Thread.t
diff --git a/lib/control.ml b/lib/control.ml
index e09068740d..ffb3584f1e 100644
--- a/lib/control.ml
+++ b/lib/control.ml
@@ -57,7 +57,7 @@ let windows_timeout n f x e =
     done
   in
   let init = Unix.gettimeofday () in
-  let _id = Thread.create thread init in
+  let _id = CThread.create thread init in
   try
     let res = f x in
     let () = killed := true in
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
index 51166cf238..2f8129bbfd 100644
--- a/stm/asyncTaskQueue.ml
+++ b/stm/asyncTaskQueue.ml
@@ -190,7 +190,7 @@ module Make(T : Task) () = struct
         let () = TQueue.broadcast queue in
         Worker.kill proc
     in
-    let _ = Thread.create kill_if () in
+    let _ = CThread.create kill_if () in
 
     try while true do
       report_status ~id "Idle";
@@ -250,7 +250,7 @@ module Make(T : Task) () = struct
     {
       active = Pool.create queue ~size;
       queue;
-      cleaner = if size > 0 then Some (Thread.create cleaner queue) else None;
+      cleaner = if size > 0 then Some (CThread.create cleaner queue) else None;
     }
 
   let destroy { active; queue } =
diff --git a/stm/spawned.ml b/stm/spawned.ml
index a5d6ea96f9..bd772d825d 100644
--- a/stm/spawned.ml
+++ b/stm/spawned.ml
@@ -38,7 +38,7 @@ let controller h pr pw =
         prerr_endline ("control channel broken: " ^ Printexc.to_string e);
         exit 1 in
     loop () in
-  ignore(Thread.create main ())
+  ignore(CThread.create main ())
 
 let main_channel = ref None
 let control_channel = ref None
diff --git a/stm/stm.ml b/stm/stm.ml
index 169d608d2d..9bd61f226d 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -739,7 +739,7 @@ end = struct (* {{{ *)
       else begin
         set_last_job job;
         if Option.is_empty !worker then
-          worker := Some (Thread.create run_command ())
+          worker := Some (CThread.create run_command ())
       end
 
   end
diff --git a/stm/workerPool.ml b/stm/workerPool.ml
index 0ff66686e4..2432e72c8a 100644
--- a/stm/workerPool.ml
+++ b/stm/workerPool.ml
@@ -86,7 +86,7 @@ let rec create_worker extra pool id =
   let exit () = cancel := true; cleanup pool; Thread.exit () in
   let cancelled () = !cancel in
   let cpanel = { exit; cancelled; extra } in
-  let manager = Thread.create (Model.manager cpanel) worker in
+  let manager = CThread.create (Model.manager cpanel) worker in
   { name; cancel; manager; process }
   
 and cleanup x = locking x begin fun { workers; count; extra_arg } ->