[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.

6 files changed, 67 insertions, 5 deletions

diff --git a/perlio.c b/perlio.c
index 07e297ec8e..6a092d0b93 100644
--- 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)
 {
diff --git a/perliol.h b/perliol.h
index 34065e5d85..a51f99b903 100644
--- 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);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1c259eece5..7a3b962451 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -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
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index d85b3d7fd0..2047dd6047 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -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
diff --git a/t/op/threads.t b/t/op/threads.t
index 240c00f7c6..4b731f07f9 100644
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -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 22940dd1a9..4b4bfe17e3 100644
--- 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__)