Permalink
Browse files

[perl #78494] Pipes cause threads to hang on join()

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.
  • Loading branch information...
1 parent c222ef4 commit 2e0cfa16dea85dd33fe3cbf38f3324f4a8418181 Father Chrysostomos committed Feb 16, 2011
Showing with 67 additions and 5 deletions.
  1. +31 −0 perlio.c
  2. +1 −0 perliol.h
  3. +5 −0 pod/perldiag.pod
  4. +4 −0 pod/perlfunc.pod
  5. +11 −1 t/op/threads.t
  6. +15 −4 util.c
View
@@ -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)
{
View
@@ -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);
View
@@ -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
View
@@ -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
View
@@ -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
View
19 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__)

0 comments on commit 2e0cfa1

Please sign in to comment.