[perl #78494] Pipes cause threads to hang on join()
authorFather Chrysostomos <sprout@cpan.org>
Wed, 16 Feb 2011 00:33:24 +0000 (16:33 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 16 Feb 2011 00:34:22 +0000 (16:34 -0800)
or on close() in either thread.

close() in one thread blocks until close() is called in the other
thread, because both closes are waiting for the child process to end.

Since we have a reference-counting mechanism for the underlying
fileno, we can use that to determine whether close() should wait.

This does not solve the problem of close $OUT block when it has been
duplicated via open $OUT2, ">&" and $OUT2 is still in scope.

perlio.c
perliol.h
pod/perldiag.pod
pod/perlfunc.pod
t/op/threads.t
util.c

index 07e297e..6a092d0 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -2455,6 +2455,37 @@ PerlIOUnix_refcnt_dec(int fd)
     return cnt;
 }
 
+int
+PerlIOUnix_refcnt(int fd)
+{
+    dTHX;
+    int cnt = 0;
+    if (fd >= 0) {
+       dVAR;
+#ifdef USE_ITHREADS
+       MUTEX_LOCK(&PL_perlio_mutex);
+#endif
+       if (fd >= PL_perlio_fd_refcnt_size) {
+           /* diag_listed_as: refcnt: fd %d%s */
+           Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
+                      fd, PL_perlio_fd_refcnt_size);
+       }
+       if (PL_perlio_fd_refcnt[fd] <= 0) {
+           /* diag_listed_as: refcnt: fd %d%s */
+           Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
+                      fd, PL_perlio_fd_refcnt[fd]);
+       }
+       cnt = PL_perlio_fd_refcnt[fd];
+#ifdef USE_ITHREADS
+       MUTEX_UNLOCK(&PL_perlio_mutex);
+#endif
+    } else {
+       /* diag_listed_as: refcnt: fd %d%s */
+       Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
+    }
+    return cnt;
+}
+
 void
 PerlIO_cleanup(pTHX)
 {
index 34065e5..a51f99b 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -279,6 +279,7 @@ PERL_EXPORT_C IV        PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV
 PERL_EXPORT_C SSize_t   PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
 PERL_EXPORT_C int       PerlIOUnix_refcnt_dec(int fd);
 PERL_EXPORT_C void      PerlIOUnix_refcnt_inc(int fd);
+PERL_EXPORT_C int       PerlIOUnix_refcnt(int fd);
 PERL_EXPORT_C IV        PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
 PERL_EXPORT_C Off_t     PerlIOUnix_tell(pTHX_ PerlIO *f);
 PERL_EXPORT_C SSize_t   PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count);
index 1c259ee..7a3b962 100644 (file)
@@ -3906,6 +3906,11 @@ which is why it's currently left out of your copy.
 believes it found an infinite loop in the C<@ISA> hierarchy.  This is a
 crude check that bails out after 100 levels of C<@ISA> depth.
 
+=item refcnt: fd %d%s
+
+(P) Perl's I/O implementation failed an internal consistency check. If
+you see this message, something is very wrong.
+
 =item Reference found where even-sized list expected
 
 (W misc) You gave a single reference where Perl was expecting a list
index d85b3d7..2047dd6 100644 (file)
@@ -910,6 +910,10 @@ on the pipe to exit--in case you wish to look at the output of the pipe
 afterwards--and implicitly puts the exit status value of that command into
 C<$?> and C<${^CHILD_ERROR_NATIVE}>.
 
+If there are multiple threads running, C<close> on a filehandle from a
+piped open returns true without waiting for the child process to terminate,
+if the filehandle is still open in another thread.
+
 Closing the read end of a pipe before the process writing to it at the
 other end is done writing results in the writer receiving a SIGPIPE.  If
 the other end can't handle that, be sure to read all the data before
index 240c00f..4b731f0 100644 (file)
@@ -16,7 +16,7 @@ BEGIN {
        exit 0;
      }
 
-     plan(23);
+     plan(24);
 }
 
 use strict;
@@ -349,4 +349,14 @@ threads->create(
 
 EOI
 
+# [perl #78494] Pipes shared between threads block when closed
+watchdog 10;
+{
+  my $perl = which_perl;
+  $perl = qq'"$perl"' if $perl =~ /\s/;
+  open(my $OUT, "|$perl") || die("ERROR: $!");
+  threads->create(sub { })->join;
+  ok(1, "Pipes shared between threads do not block when closed");
+}
+
 # EOF
diff --git a/util.c b/util.c
index 22940dd..4b4bfe1 100644 (file)
--- a/util.c
+++ b/util.c
@@ -25,6 +25,8 @@
 #define PERL_IN_UTIL_C
 #include "perl.h"
 
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+
 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR
@@ -3118,11 +3120,16 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     int status;
     SV **svp;
     Pid_t pid;
-    Pid_t pid2;
+    Pid_t pid2 = 0;
     bool close_failed;
     dSAVEDERRNO;
+    const int fd = PerlIO_fileno(ptr);
+
+    /* Find out whether the refcount is low enough for us to wait for the
+       child proc without blocking. */
+    const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
 
-    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+    svp = av_fetch(PL_fdpid,fd,TRUE);
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -3141,7 +3148,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
-    do {
+    if (should_wait) do {
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
 #ifndef PERL_MICRO
@@ -3153,7 +3160,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        RESTORE_ERRNO;
        return -1;
     }
-    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+    return(
+      should_wait
+       ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+       : 0
+    );
 }
 #else
 #if defined(__LIBCATAMOUNT__)