Prevent zombie process with mccollect(wait=FALSE).

git-svn-id: https://svn.r-project.org/R/trunk@75451 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Oct 18, 2018 · 5bd33ff · 5bd33ff
1 parent 24fc047
commit 5bd33ff
Show file tree

Hide file tree

Showing 3 changed files with 17 additions and 9 deletions.
diff --git a/src/library/parallel/R/unix/mcfork.R b/src/library/parallel/R/unix/mcfork.R
@@ -1,7 +1,7 @@
 #  File src/library/parallel/R/unix/mcfork.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2017 The R Core Team
+#  Copyright (C) 1995-2018 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -66,7 +66,7 @@ selectChildren <- function(children = NULL, timeout = 0)
     .Call(C_mc_select_children, as.double(timeout), as.integer(children))
 }
 
-## not used
+## used by mccollect
 rmChild <- function(child)
 {
     if (inherits(child, "process")) child <- processID(child)

diff --git a/src/library/parallel/R/unix/mcparallel.R b/src/library/parallel/R/unix/mcparallel.R
@@ -63,10 +63,15 @@ mccollect <- function(jobs, wait = TRUE, timeout = 0, intermediate = FALSE)
 
     if (!wait) {
         s <- selectChildren(jobs, timeout)
-        if (is.logical(s) || !length(s)) return(NULL)
+        if (is.logical(s) || !length(s)) return(NULL) ## select error
         res <- lapply(s, function(x) {
             r <- readChild(x)
-            if (is.raw(r)) unserialize(r) else NULL
+            if (is.raw(r)) {
+                rmChild(x) ## avoid zombie process without waiting
+                unserialize(r)
+            } else
+                ## error
+                NULL
         })
         names(res) <- pnames[match(s, pids)]
     } else {
@@ -78,13 +83,16 @@ mccollect <- function(jobs, wait = TRUE, timeout = 0, intermediate = FALSE)
             if (is.integer(s)) {
                 for (pid in s) {
                     r <- readChild(pid)
-                    if (is.integer(r) || is.null(r)) fin[pid == pids] <- TRUE
-                    if (is.raw(r)) # unserialize(r) might be null
+                    if (is.raw(r))
+                        ## unserialize(r) might be null
                         res[which(pid == pids)] <- list(unserialize(r))
+                    else
+                        ## child exiting or error
+                        fin[pid == pids] <- TRUE 
                 }
                 if (is.function(intermediate)) intermediate(res)
             } else
-                ## should not happen
+                ## should not happen (select error)
                 if (all(is.na(match(pids, processID(children()))))) break
         }
     }

diff --git a/src/library/parallel/src/fork.c b/src/library/parallel/src/fork.c
@@ -363,7 +363,7 @@ SEXP mc_cleanup(SEXP sKill, SEXP sDetach, SEXP sShutdown)
 	    /* only kills if not waited for */
 	    kill_detached_child_ci(ci, sig);
 	if (!ci->detached && detach) {
-	    /* With sKill ==  FALSE (mclapply mc.cleanup=FALSE), send
+	    /* With sKill == FALSE (mclapply mc.cleanup=FALSE), send
 	       SIGUSR1 to just detach the child. Detaching also closes the file
 	       descriptors which contributes to termination probably even more,
 	       as it is not likely that the child will be finished and just
@@ -886,7 +886,7 @@ static SEXP read_child_ci(child_info_t *ci)
     Dprintf("read_child_ci(%d) - read length returned %lld\n", pid, (long long)n);
 #endif
     if (n != sizeof(len) || len == 0) {
-	/* child is exiting (len==0), or error */
+	/* child is exiting (n==0), or error */
 	terminate_and_detach_child_ci(ci);
 	return ScalarInteger(pid);
     } else {