fixup! Windows safe kill.

Author: tmcgilchrist

lib/olly_common/launch.ml

@@ -5,6 +5,12 @@ external is_process_alive : int -> bool = "olly_is_process_alive"
    On Unix it's the identity function since the handle IS the PID. *)
 external get_process_id : int -> int = "olly_get_process_id"
 
+(* Windows has no SIGKILL — Unix.kill only routes SIGTERM through
+   TerminateProcess. On Unix we want SIGKILL because some test programs
+   (e.g. tight integer loops) never reach a signal-poll point and so
+   ignore SIGTERM. *)
+let terminate_signal = if Sys.win32 then Sys.sigterm else Sys.sigkill
+
 let lost_events ring_id num =
   Printf.eprintf "[ring_id=%d] Lost %d events\n%!" ring_id num
 
@@ -89,11 +95,26 @@ let exec_process (config : runtime_events_config) (args : string list) :
   let child_pid = get_process_id child_handle in
   (* On Windows Unix.kill takes a PID (uses OpenProcess) but Unix.waitpid
      takes the HANDLE returned by create_process — they are different
-     values. On Unix the handle and PID coincide. *)
+     values. On Unix the handle and PID coincide.
+
+     We poll waitpid with WNOHANG rather than blocking indefinitely: if
+     the kill didn't take for any reason, hanging the test suite for
+     hours is worse than reporting and moving on. *)
   let kill () =
-    (try Unix.kill child_pid Sys.sigkill
+    (try Unix.kill child_pid terminate_signal
      with Unix.Unix_error _ | Invalid_argument _ -> ());
-    try ignore (Unix.waitpid [] child_handle) with Unix.Unix_error _ -> ()
+    let deadline = Unix.gettimeofday () +. 5.0 in
+    let rec wait () =
+      if Unix.gettimeofday () >= deadline then ()
+      else
+        match Unix.waitpid [ Unix.WNOHANG ] child_handle with
+        | 0, _ ->
+            Unix.sleepf 0.02;
+            wait ()
+        | _, _ -> ()
+        | exception Unix.Unix_error _ -> ()
+    in
+    wait ()
   in
   (* Poll until we can create a cursor for the child's ring buffer.
      The OCaml runtime creates the .events file then initializes it,
@@ -172,9 +193,10 @@ let attach_process (dir : string) (pid : int) : subprocess =
   let alive () = is_process_alive pid
   and close () = Runtime_events.free_cursor cursor in
   (* Best-effort: we did not create the process, so we have no handle to
-     waitpid on. Send SIGKILL and poll is_process_alive briefly. *)
+     waitpid on. Send the platform terminate signal and poll
+     is_process_alive briefly. *)
   let kill () =
-    (try Unix.kill pid Sys.sigkill
+    (try Unix.kill pid terminate_signal
      with Unix.Unix_error _ | Invalid_argument _ -> ());
     let deadline = Unix.gettimeofday () +. 2.0 in
     while is_process_alive pid && Unix.gettimeofday () < deadline do