Merge pull request #562 from talex5/waitpid-interop

Eio_posix: don't reap non-Eio child processes

lib_eio/unix/process.ml

@@ -102,3 +102,8 @@ let spawn_unix ~sw (mgr:#mgr) ?cwd ~fds ?env ?executable args =
   let executable = get_executable executable ~args in
   let env = get_env env in
   mgr#spawn_unix ~sw ?cwd ~fds ~env ~executable args
+
+let sigchld = Eio.Condition.create ()
+
+let install_sigchld_handler () =
+  Sys.(set_signal sigchld) (Signal_handle (fun (_:int) -> Eio.Condition.broadcast sigchld))

lib_eio/unix/process.mli

@@ -45,3 +45,14 @@ val spawn_unix :
     The arguments are as for {!Eio.Process.spawn},
     except that it takes a list of FD mappings for {!Fork_action.inherit_fds}
     directly, rather than just flows for the standard streams. *)
+
+val sigchld : Eio.Condition.t
+(** {b If} an Eio backend installs a SIGCHLD handler, the handler will broadcast on this condition.
+
+    This allows non-Eio libraries (such as Lwt) to share its signal handler.
+
+    Note: Not all backends install a handler (e.g. eio_linux uses process descriptors instead),
+    so be sure to call {!install_sigchld_handler} if you need to use this. *)
+
+val install_sigchld_handler : unit -> unit
+(** [install_sigchld_handler ()] sets the signal handler for SIGCHLD to broadcast {!sigchld}. *)

lib_eio_posix/eio_posix.ml

@@ -21,7 +21,7 @@ type stdenv = Eio_unix.Stdenv.base
 let run main =
   (* SIGPIPE makes no sense in a modern application. *)
   Sys.(set_signal sigpipe Signal_ignore);
-  Sys.(set_signal sigchld (Signal_handle (fun (_:int) -> Children.handle_sigchld ())));
+  Eio_unix.Process.install_sigchld_handler ();
   let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> Eio_unix.source) in
   let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> Eio_unix.sink) in
   let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> Eio_unix.sink) in

lib_eio_posix/low_level.ml

@@ -229,7 +229,9 @@ module Process = struct
   type t = {
     pid : int;
     exit_status : Unix.process_status Promise.t;
+    lock : Mutex.t;
   }
+  (* When [lock] is unlocked, [exit_status] is resolved iff the process has been reaped. *)
 
   let exit_status t = t.exit_status
   let pid t = t.pid
@@ -249,36 +251,53 @@ module Process = struct
     fn r w
 
   let signal t signal =
-    (* The lock here ensures we don't signal the PID after reaping it. *)
-    Children.with_lock @@ fun () ->
+    (* We need the lock here so that one domain can't signal the process exactly as another is reaping it. *)
+    Mutex.lock t.lock;
+    Fun.protect ~finally:(fun () -> Mutex.unlock t.lock) @@ fun () ->
     if not (Promise.is_resolved t.exit_status) then (
       Unix.kill t.pid signal
-    )
+    ) (* else process has been reaped and t.pid is invalid *)
 
   external eio_spawn : Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> int = "caml_eio_posix_spawn"
 
+  (* Wait for [pid] to exit and then resolve [exit_status] to its status. *)
+  let reap t exit_status =
+    Eio.Condition.loop_no_mutex Eio_unix.Process.sigchld (fun () ->
+         Mutex.lock t.lock;
+         match Unix.waitpid [WNOHANG] t.pid with
+         | 0, _ -> Mutex.unlock t.lock; None                (* Not ready; wait for next SIGCHLD *)
+         | p, status ->
+           assert (p = t.pid);
+           Promise.resolve exit_status status;
+           Mutex.unlock t.lock;
+           Some ()
+      )
+
   let spawn ~sw actions =
     with_pipe @@ fun errors_r errors_w ->
     Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions ->
     Switch.check sw;
+    let exit_status, set_exit_status = Promise.create () in
     let t =
-      (* We take the lock to ensure that the signal handler won't reap the
-         process before we've registered it. *)
-      Children.with_lock (fun () ->
-          let pid =
-            Fd.use_exn "errors-w" errors_w @@ fun errors_w ->
-            eio_spawn errors_w c_actions
-          in
-          Fd.close errors_w;
-          { pid; exit_status = Children.register pid }
-        )
+      let pid =
+        Fd.use_exn "errors-w" errors_w @@ fun errors_w ->
+        eio_spawn errors_w c_actions
+      in
+      Fd.close errors_w;
+      { pid; exit_status; lock = Mutex.create () }
     in
-    let hook = Switch.on_release_cancellable sw (fun () -> signal t Sys.sigkill) in
-    (* Removing the hook must be done from our own domain, not from the signal handler,
-       so fork a fiber to deal with that. If the switch gets cancelled then this won't
-       run, but then the [on_release] handler will run the hook soon anyway. *)
+    let hook = Switch.on_release_cancellable sw (fun () ->
+        (* Kill process (if still running) *)
+        signal t Sys.sigkill;
+        (* The switch is being released, so either the daemon fiber got
+           cancelled or it hasn't started yet (and never will start). *)
+        if not (Promise.is_resolved t.exit_status) then (
+          (* Do a (non-cancellable) waitpid here to reap the child. *)
+          reap t set_exit_status
+        )
+      ) in
     Fiber.fork_daemon ~sw (fun () ->
-        ignore (Promise.await t.exit_status : Unix.process_status);
+        reap t set_exit_status;
         Switch.remove_hook hook;
         `Stop_daemon
       );

tests/process.md

@@ -165,3 +165,20 @@ A custom environment:
   Process.parse_out mgr Eio.Buf_read.line ["sh"; "-c"; "echo $DISPLAY"] ~env;;
 - : string = ":2"
 ```
+
+Eio's child reaping code doesn't interfere with OCaml's process spawning:
+
+```ocaml
+let rec waitpid_with_retry flags pid =
+  try Unix.waitpid flags pid
+  with Unix.Unix_error(Unix.EINTR, _, _) -> waitpid_with_retry flags pid
+```
+
+```ocaml
+# Eio_main.run @@ fun env ->
+  let p = Unix.(create_process "/usr/bin/env" [|"env"; "echo"; "hi"|] stdin stdout stderr) in
+  Eio.Time.Mono.sleep env#mono_clock 0.01;
+  waitpid_with_retry [] p |> snd;;
+hi
+- : Unix.process_status = Unix.WEXITED 0
+```