Change 11423 by gsar@auger on 2001/07/20 18:38:48
Make perl fork()-safe (in a slightly limited way) even on
platforms that don't have pthread_atfork() (extension of
the fix in change#11151).
Note that this will not help extensions that call fork()
directly in C, or that link to libraries that call fork()
directly. Such cases must be fixed to either call
PerlProc_fork(), or call atfork_lock() in parent before the
calling the function that forks and call atfork_unlock()
in both parent and child immediately after the fork().
(There are no worries if C code calls exec() in the child
immediately after a fork(). Only cases where the child
calls perl's API functions (including New()) after the
fork() are problematic.)
This change also eliminates the use of vfork() from perl,
since all such uses were violating the severe restrictions
on modifying the state of the process between the vfork()
and the exec().
This is a modified version of patches suggested by Abhijit
Menon-Sen and Richard Soderberg.
Affected files ...
... //depot/perl/embed.h#277 edit
... //depot/perl/embed.pl#261 edit
... //depot/perl/global.sym#173 edit
... //depot/perl/iperlsys.h#47 edit
... //depot/perl/miniperlmain.c#26 edit
... //depot/perl/objXSUB.h#176 edit
... //depot/perl/perl.c#348 edit
... //depot/perl/perlapi.c#118 edit
... //depot/perl/pp_sys.c#249 edit
... //depot/perl/proto.h#321 edit
... //depot/perl/thread.h#80 edit
... //depot/perl/util.c#288 edit
Differences ...
==== //depot/perl/embed.h#277 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Fri Jul 20 12:45:05 2001
+++ perl/embed.h Fri Jul 20 12:45:05 2001
@@ -430,6 +430,9 @@
#define my_exit Perl_my_exit
#define my_failure_exit Perl_my_failure_exit
#define my_fflush_all Perl_my_fflush_all
+#define my_fork Perl_my_fork
+#define atfork_lock Perl_atfork_lock
+#define atfork_unlock Perl_atfork_unlock
#define my_lstat Perl_my_lstat
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
#define my_memcmp Perl_my_memcmp
@@ -1941,6 +1944,9 @@
#define my_exit(a) Perl_my_exit(aTHX_ a)
#define my_failure_exit() Perl_my_failure_exit(aTHX)
#define my_fflush_all() Perl_my_fflush_all(aTHX)
+#define my_fork Perl_my_fork
+#define atfork_lock Perl_atfork_lock
+#define atfork_unlock Perl_atfork_unlock
#define my_lstat() Perl_my_lstat(aTHX)
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
#define my_memcmp Perl_my_memcmp
@@ -3806,6 +3812,12 @@
#define my_failure_exit Perl_my_failure_exit
#define Perl_my_fflush_all CPerlObj::Perl_my_fflush_all
#define my_fflush_all Perl_my_fflush_all
+#define Perl_my_fork CPerlObj::Perl_my_fork
+#define my_fork Perl_my_fork
+#define Perl_atfork_lock CPerlObj::Perl_atfork_lock
+#define atfork_lock Perl_atfork_lock
+#define Perl_atfork_unlock CPerlObj::Perl_atfork_unlock
+#define atfork_unlock Perl_atfork_unlock
#define Perl_my_lstat CPerlObj::Perl_my_lstat
#define my_lstat Perl_my_lstat
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
==== //depot/perl/embed.pl#261 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~ Fri Jul 20 12:45:05 2001
+++ perl/embed.pl Fri Jul 20 12:45:05 2001
@@ -1769,6 +1769,9 @@
Apr |void |my_exit |U32 status
Apr |void |my_failure_exit
Ap |I32 |my_fflush_all
+Anp |Pid_t |my_fork
+Anp |void |atfork_lock
+Anp |void |atfork_unlock
Ap |I32 |my_lstat
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
Anp |I32 |my_memcmp |const char* s1|const char* s2|I32 len
==== //depot/perl/global.sym#173 (text+w) ====
Index: perl/global.sym
--- perl/global.sym.~1~ Fri Jul 20 12:45:05 2001
+++ perl/global.sym Fri Jul 20 12:45:05 2001
@@ -233,6 +233,9 @@
Perl_my_exit
Perl_my_failure_exit
Perl_my_fflush_all
+Perl_my_fork
+Perl_atfork_lock
+Perl_atfork_unlock
Perl_my_lstat
Perl_my_memcmp
Perl_my_memset
==== //depot/perl/iperlsys.h#47 (text) ====
Index: perl/iperlsys.h
--- perl/iperlsys.h.~1~ Fri Jul 20 12:45:05 2001
+++ perl/iperlsys.h Fri Jul 20 12:45:05 2001
@@ -1074,7 +1074,7 @@
#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
#define PerlProc_signal(n, h) signal((n), (h))
-#define PerlProc_fork() fork()
+#define PerlProc_fork() my_fork()
#define PerlProc_getpid() getpid()
#ifdef WIN32
==== //depot/perl/miniperlmain.c#26 (text) ====
Index: perl/miniperlmain.c
--- perl/miniperlmain.c.~1~ Fri Jul 20 12:45:05 2001
+++ perl/miniperlmain.c Fri Jul 20 12:45:05 2001
@@ -48,7 +48,16 @@
PERL_SYS_INIT3(&argc,&argv,&env);
-#ifdef USE_ITHREADS
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ /* XXX Ideally, this should really be happening in perl_alloc() or
+ * perl_construct() to keep libperl.a transparently fork()-safe.
+ * It is currently done here only because Apache/mod_perl have
+ * problems due to lack of a call to cancel pthread_atfork()
+ * handlers when shared objects that contain the handlers may
+ * be dlclose()d. This forces applications that embed perl to
+ * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
+ * been called at least once before in the current process.
+ * --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
==== //depot/perl/objXSUB.h#176 (text+w) ====
Index: perl/objXSUB.h
--- perl/objXSUB.h.~1~ Fri Jul 20 12:45:05 2001
+++ perl/objXSUB.h Fri Jul 20 12:45:05 2001
@@ -909,6 +909,18 @@
#define Perl_my_fflush_all pPerl->Perl_my_fflush_all
#undef my_fflush_all
#define my_fflush_all Perl_my_fflush_all
+#undef Perl_my_fork
+#define Perl_my_fork pPerl->Perl_my_fork
+#undef my_fork
+#define my_fork Perl_my_fork
+#undef Perl_atfork_lock
+#define Perl_atfork_lock pPerl->Perl_atfork_lock
+#undef atfork_lock
+#define atfork_lock Perl_atfork_lock
+#undef Perl_atfork_unlock
+#define Perl_atfork_unlock pPerl->Perl_atfork_unlock
+#undef atfork_unlock
+#define atfork_unlock Perl_atfork_unlock
#undef Perl_my_lstat
#define Perl_my_lstat pPerl->Perl_my_lstat
#undef my_lstat
==== //depot/perl/perl.c#348 (text) ====
Index: perl/perl.c
--- perl/perl.c.~1~ Fri Jul 20 12:45:05 2001
+++ perl/perl.c Fri Jul 20 12:45:05 2001
@@ -58,29 +58,6 @@
} STMT_END
#else
# if defined(USE_ITHREADS)
-
-/* this is called in parent before the fork() */
-void
-Perl_atfork_lock(void)
-{
- /* locks must be held in locking order (if any) */
-#ifdef MYMALLOC
- MUTEX_LOCK(&PL_malloc_mutex);
-#endif
- OP_REFCNT_LOCK;
-}
-
-/* this is called in both parent and child after the fork() */
-void
-Perl_atfork_unlock(void)
-{
- /* locks must be released in same order as in S_atfork_lock() */
-#ifdef MYMALLOC
- MUTEX_UNLOCK(&PL_malloc_mutex);
-#endif
- OP_REFCNT_UNLOCK;
-}
-
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
==== //depot/perl/perlapi.c#118 (text+w) ====
Index: perl/perlapi.c
--- perl/perlapi.c.~1~ Fri Jul 20 12:45:05 2001
+++ perl/perlapi.c Fri Jul 20 12:45:05 2001
@@ -1678,6 +1678,30 @@
return ((CPerlObj*)pPerl)->Perl_my_fflush_all();
}
+#undef Perl_my_fork
+Pid_t
+Perl_my_fork()
+{
+ dTHXo;
+ return ((CPerlObj*)pPerl)->Perl_my_fork();
+}
+
+#undef Perl_atfork_lock
+void
+Perl_atfork_lock()
+{
+ dTHXo;
+ ((CPerlObj*)pPerl)->Perl_atfork_lock();
+}
+
+#undef Perl_atfork_unlock
+void
+Perl_atfork_unlock()
+{
+ dTHXo;
+ ((CPerlObj*)pPerl)->Perl_atfork_unlock();
+}
+
#undef Perl_my_lstat
I32
Perl_my_lstat(pTHXo)
==== //depot/perl/pp_sys.c#249 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c.~1~ Fri Jul 20 12:45:05 2001
+++ perl/pp_sys.c Fri Jul 20 12:45:05 2001
@@ -104,11 +104,6 @@
# endif
#endif
-/* Put this after #includes because fork and vfork prototypes may conflict. */
-#ifndef HAS_VFORK
-# define vfork fork
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
@@ -3874,13 +3869,9 @@
Pid_t childpid;
GV *tmpgv;
-# if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
- Perl_croak(aTHX_ "No pthread_atfork() -- fork() too unsafe");
-# endif
-
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
- childpid = fork();
+ childpid = PerlProc_fork();
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
@@ -3991,7 +3982,7 @@
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
- while ((childpid = vfork()) == -1) {
+ while ((childpid = PerlProc_fork()) == -1) {
if (errno != EAGAIN) {
value = -1;
SP = ORIGMARK;
@@ -4019,7 +4010,7 @@
(void)rsignal_restore(SIGQUIT, &qhand);
#endif
STATUS_NATIVE_SET(result == -1 ? -1 : status);
- do_execfree(); /* free any memory child malloced on vfork */
+ do_execfree(); /* free any memory child malloced on fork */
SP = ORIGMARK;
if (did_pipes) {
int errkid;
==== //depot/perl/proto.h#321 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Fri Jul 20 12:45:05 2001
+++ perl/proto.h Fri Jul 20 12:45:05 2001
@@ -496,6 +496,9 @@
PERL_CALLCONV void Perl_my_exit(pTHX_ U32 status) __attribute__((noreturn));
PERL_CALLCONV void Perl_my_failure_exit(pTHX) __attribute__((noreturn));
PERL_CALLCONV I32 Perl_my_fflush_all(pTHX);
+PERL_CALLCONV Pid_t Perl_my_fork(void);
+PERL_CALLCONV void Perl_atfork_lock(void);
+PERL_CALLCONV void Perl_atfork_unlock(void);
PERL_CALLCONV I32 Perl_my_lstat(pTHX);
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
PERL_CALLCONV I32 Perl_my_memcmp(const char* s1, const char* s2, I32 len);
==== //depot/perl/thread.h#80 (text) ====
Index: perl/thread.h
--- perl/thread.h.~1~ Fri Jul 20 12:45:05 2001
+++ perl/thread.h Fri Jul 20 12:45:05 2001
@@ -302,9 +302,6 @@
} STMT_END
#endif
-void Perl_atfork_lock(void);
-void Perl_atfork_unlock(void);
-
#ifndef PTHREAD_ATFORK
# ifdef HAS_PTHREAD_ATFORK
# define PTHREAD_ATFORK(prepare,parent,child) \
==== //depot/perl/util.c#288 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Fri Jul 20 12:45:05 2001
+++ perl/util.c Fri Jul 20 12:45:05 2001
@@ -26,17 +26,6 @@
#endif
#endif
-#ifdef I_VFORK
-# include <vfork.h>
-#endif
-
-/* Put this after #includes because fork and vfork prototypes may
- conflict.
-*/
-#ifndef HAS_VFORK
-# define vfork fork
-#endif
-
#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif
@@ -1858,7 +1847,7 @@
/* Try for another pipe pair for error return */
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
- while ((pid = vfork()) < 0) {
+ while ((pid = PerlProc_fork()) < 0) {
if (errno != EAGAIN) {
PerlLIO_close(p[This]);
if (did_pipes) {
@@ -1910,7 +1899,7 @@
#undef THAT
}
/* Parent */
- do_execfree(); /* free any memory malloced by child on vfork */
+ do_execfree(); /* free any memory malloced by child on fork */
/* Close child's end of pipe */
PerlLIO_close(p[that]);
if (did_pipes)
@@ -1991,7 +1980,7 @@
return Nullfp;
if (doexec && PerlProc_pipe(pp) >= 0)
did_pipes = 1;
- while ((pid = (doexec?vfork():fork())) < 0) {
+ while ((pid = PerlProc_fork()) < 0) {
if (errno != EAGAIN) {
PerlLIO_close(p[This]);
if (did_pipes) {
@@ -2052,7 +2041,7 @@
#undef THIS
#undef THAT
}
- do_execfree(); /* free any memory malloced by child on vfork */
+ do_execfree(); /* free any memory malloced by child on fork */
PerlLIO_close(p[that]);
if (did_pipes)
PerlLIO_close(pp[1]);
@@ -2127,6 +2116,53 @@
#endif /* !DOSISH */
+/* this is called in parent before the fork() */
+void
+Perl_atfork_lock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ /* locks must be held in locking order (if any) */
+# ifdef MYMALLOC
+ MUTEX_LOCK(&PL_malloc_mutex);
+# endif
+ OP_REFCNT_LOCK;
+#endif
+}
+
+/* this is called in both parent and child after the fork() */
+void
+Perl_atfork_unlock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ /* locks must be released in same order as in atfork_lock() */
+# ifdef MYMALLOC
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+# endif
+ OP_REFCNT_UNLOCK;
+#endif
+}
+
+Pid_t
+Perl_my_fork(void)
+{
+#if defined(HAS_FORK)
+ Pid_t pid;
+#if (defined(USE_THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
+ atfork_lock();
+ pid = fork();
+ atfork_unlock();
+#else
+ /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
+ * handlers elsewhere in the code */
+ pid = fork();
+#endif
+ return pid;
+#else
+ /* this "canna happen" since nothing should be calling here if !HAS_FORK */
+ Perl_croak_nocontext("fork() not available");
+#endif /* HAS_FORK */
+}
+
#ifdef DUMP_FDS
void
Perl_dump_fds(pTHX_ char *s)
End of Patch.
