Merge pull request #802 from patricoferris/process-groups

Add process groups to unix backends

Author: talex5

lib_eio/unix/fork_action.c

@@ -237,3 +237,24 @@ static void action_dups(int errors, value v_config) {
 CAMLprim value eio_unix_fork_dups(value v_unit) {
   return Val_fork_fn(action_dups);
 }
+
+static void action_setpgid(int errors, value v_config) {
+  #ifdef _WIN32
+  eio_unix_fork_error(errors, "setpgid", "Unsupported operation on windows");
+  _exit(1);
+  #else
+  value vpid = Field(v_config, 1);
+  value vpgid = Field(v_config, 2);
+
+  int r;
+  r = setpgid(Int_val(vpid), Int_val(vpgid));
+  if (r != 0) {
+    eio_unix_fork_error(errors, "setpgid", strerror(errno));
+    _exit(1);
+  }
+  #endif
+}
+
+CAMLprim value eio_unix_fork_setpgid(value v_unit) {
+  return Val_fork_fn(action_setpgid);
+}

lib_eio/unix/fork_action.ml

@@ -68,3 +68,9 @@ let inherit_fds m =
   with_fds m @@ fun m ->
   let plan : action list = Inherit_fds.plan m in
   { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) }
+
+external action_setpgid : unit -> fork_fn = "eio_unix_fork_setpgid"
+let action_setpgid = action_setpgid ()
+
+let setpgid pgid =
+  { run = fun k -> k (Obj.repr (action_setpgid, 0, pgid)) }

lib_eio/unix/fork_action.mli

@@ -58,3 +58,9 @@ val inherit_fds : (int * Fd.t * [< blocking]) list -> t
     A mapping from an FD to itself simply clears the close-on-exec flag.
 
     After this, the new FDs may also be set as blocking or non-blocking, depending on [flags]. *)
+
+val setpgid : int -> t
+(** [setpgid pgid] sets the child's process group ID to [pgid].
+
+    If [pgid] is [0] the child's process ID will be used as the PGID, placing
+    the child in a {e new} process group. *)

lib_eio/unix/process.ml

@@ -83,6 +83,7 @@ module Pi = struct
       t ->
       sw:Switch.t ->
       ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
+      ?pgid:int ->
       env:string array ->
       fds:(int * Fd.t * Fork_action.blocking) list ->
       executable:string ->
@@ -107,6 +108,7 @@ module Make_mgr (X : sig
     t ->
     sw:Switch.t ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
+    ?pgid:int ->
     env:string array ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
     executable:string ->
@@ -138,11 +140,11 @@ end) = struct
   let spawn_unix = X.spawn_unix
 end
 
-let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?cwd ~fds ?env ?executable args =
+let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?cwd ?pgid ~fds ?env ?executable args =
   let module X = (val (Eio.Resource.get ops Pi.Mgr_unix)) in
   let executable = get_executable executable ~args in
   let env = get_env env in
-  X.spawn_unix v ~sw ?cwd ~fds ~env ~executable args
+  X.spawn_unix v ~sw ?cwd ?pgid ~fds ~env ~executable args
 
 let sigchld = Eio.Condition.create ()
 

lib_eio/unix/process.mli

@@ -20,6 +20,7 @@ module Pi : sig
       t ->
       sw:Switch.t ->
       ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
+      ?pgid:int ->
       env:string array ->
       fds:(int * Fd.t * Fork_action.blocking) list ->
       executable:string ->
@@ -42,6 +43,7 @@ module Make_mgr (X : sig
     t ->
     sw:Switch.t ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
+    ?pgid:int ->
     env:string array ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
     executable:string ->
@@ -53,6 +55,7 @@ val spawn_unix :
     sw:Switch.t ->
     _ mgr ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
+    ?pgid:int ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
     ?env:string array ->
     ?executable:string ->

lib_eio_linux/eio_linux.ml

@@ -219,11 +219,15 @@ module Process_mgr = struct
   module T = struct
     type t = unit 
 
-    let spawn_unix () ~sw ?cwd ~env ~fds ~executable args =
+    let spawn_unix () ~sw ?cwd ?pgid ~env ~fds ~executable args =
       let actions = Low_level.Process.Fork_action.[
           Eio_unix.Private.Fork_action.inherit_fds fds;
           execve executable ~argv:(Array.of_list args) ~env
       ] in
+      let actions = match pgid with
+        | None -> actions
+        | Some pgid -> Eio_unix.Private.Fork_action.setpgid pgid :: actions
+      in
       let with_actions cwd fn = match cwd with
         | None -> fn actions
         | Some (fd, s) ->

lib_eio_posix/process.ml

@@ -23,11 +23,15 @@ module Impl = struct
   module T = struct
     type t = unit
 
-    let spawn_unix () ~sw ?cwd ~env ~fds ~executable args =
+    let spawn_unix () ~sw ?cwd ?pgid ~env ~fds ~executable args =
       let actions = Low_level.Process.Fork_action.[
           inherit_fds fds;
           execve executable ~argv:(Array.of_list args) ~env
       ] in
+      let actions = match pgid with
+        | None -> actions
+        | Some pgid -> Low_level.Process.Fork_action.setpgid pgid :: actions
+      in
       let with_actions cwd fn = match cwd with
         | None -> fn actions
         | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) ->