[infer] Explicitly exit when SIGINT is given

Summary:
There were two problems: (1) `Signal.Expert.handle` does not call exit by itself; (2) it calls `flush` inside, which introduced deadlock, result in zombie processes.

This diff changes overall processes of the signal handler.

1. It uses `Caml.Sys.set_signal` instead of `Signal.Expert.handle`.
2. Inside the signal handler it raises an exception, then which is catched in `uncaught_exception_handler` of `Config.ml`. Epilogues are executed there.

Reviewed By: jvillard

Differential Revision: D21769246

fbshipit-source-id: cecd998c6

infer/src/base/Epilogues.ml

@@ -38,16 +38,11 @@ let run () =
   late ()
 
 
-(* Run the epilogues when we get SIGINT (Control-C). *)
-let () =
-  let run_epilogues_on_signal s =
-    F.eprintf "*** %s: Caught %s, time to die@."
-      (Filename.basename Sys.executable_name)
-      (Signal.to_string s) ;
-    run ()
-  in
-  Signal.Expert.handle Signal.int run_epilogues_on_signal
+(** Raised when we are interrupted by SIGINT *)
+exception Sigint
 
+(* Raise a specific exception when we get SIGINT (Control-C). *)
+let () = Caml.Sys.(set_signal sigint (Signal_handle (fun _ -> raise Sigint)))
 
 let reset () =
   (early_callback := fun () -> ()) ;

infer/src/base/ProcessPool.ml

@@ -189,6 +189,7 @@ let killall pool ~slot status =
       try Unix.wait (`Pid pid) |> ignore
       with Unix.Unix_error (ECHILD, _, _) ->
         (* some children may have died already, it's fine *) () ) ;
+  ProcessPoolState.has_running_children := false ;
   L.die InternalError "Subprocess %d: %s" slot status
 
 
@@ -322,6 +323,7 @@ let wait_all pool =
             (* Collect all children errors and die only at the end to avoid creating zombies. *)
             (slot, status) :: errors )
   in
+  ProcessPoolState.has_running_children := false ;
   ( if not (List.is_empty errors) then
     let pp_error f (slot, status) =
       F.fprintf f "Error in infer subprocess %d: %s@." slot
@@ -444,6 +446,12 @@ let create :
         let child_pipe = List.nth_exn children_pipes slot in
         fork_child ~file_lock ~child_prelude ~slot child_pipe ~f ~epilogue:child_epilogue )
   in
+  ProcessPoolState.has_running_children := true ;
+  Epilogues.register ~description:"Wait children processes exit" ~f:(fun () ->
+      if !ProcessPoolState.has_running_children then (
+        Array.iter slots ~f:(fun {pid} ->
+            ignore (Unix.wait (`Pid pid) : Pid.t * Unix.Exit_or_signal.t) ) ;
+        ProcessPoolState.has_running_children := false ) ) ;
   (* we have forked the child processes and are now in the parent *)
   let children_updates = List.map children_pipes ~f:(fun (pipe_child_r, _) -> pipe_child_r) in
   let children_states = Array.create ~len:jobs Initializing in

infer/src/base/ProcessPoolState.ml

@@ -17,3 +17,5 @@ let pid = ref (lazy (Unix.getpid ()))
 let reset_pid () = pid := lazy (Unix.getpid ())
 
 let get_pid () = Lazy.force !pid
+
+let has_running_children = ref false

infer/src/base/ProcessPoolState.mli

@@ -17,3 +17,5 @@ val update_status : (Mtime.t -> string -> unit) ref
 val get_pid : unit -> Pid.t
 
 val reset_pid : unit -> unit
+
+val has_running_children : bool ref