From: Gurusamy Sarathy Date: Fri, 20 Jul 2001 18:38:48 +0000 (+0000) Subject: Make perl fork()-safe (in a slightly limited way) even on X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=52e18b1f277416a33dff2c066a83fdab0520a2d7;p=p5sagit%2Fp5-mst-13.2.git 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. p4raw-link: @11151 on //depot/perl: 50dd6e574ff39b609595ddb16b2fe9f625a26f8c p4raw-id: //depot/perl@11423 --- diff --git a/embed.h b/embed.h index f6176db..9093f9b 100644 --- a/embed.h +++ b/embed.h @@ -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) diff --git a/embed.pl b/embed.pl index f125ef0..2e473b6 100755 --- a/embed.pl +++ b/embed.pl @@ -1769,6 +1769,9 @@ Anp |char* |my_bzero |char* loc|I32 len 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 diff --git a/global.sym b/global.sym index 5301739..73493c3 100644 --- a/global.sym +++ b/global.sym @@ -233,6 +233,9 @@ Perl_my_bzero 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 diff --git a/iperlsys.h b/iperlsys.h index 081d8b2..89b551b 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -1074,7 +1074,7 @@ struct IPerlProcInfo #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 diff --git a/miniperlmain.c b/miniperlmain.c index 620fed7..2c924eb 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -48,7 +48,16 @@ main(int argc, char **argv, char **env) 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); diff --git a/objXSUB.h b/objXSUB.h index 43a10fa..564bd9c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -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 diff --git a/perl.c b/perl.c index 25cdcd6..322960d 100644 --- a/perl.c +++ b/perl.c @@ -58,29 +58,6 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); } 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) { \ diff --git a/perlapi.c b/perlapi.c index fb5c407..9b90154 100644 --- a/perlapi.c +++ b/perlapi.c @@ -1678,6 +1678,30 @@ Perl_my_fflush_all(pTHXo) 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) diff --git a/pp_sys.c b/pp_sys.c index 6a74b11..ac7ca20 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -104,11 +104,6 @@ extern int h_errno; # 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 @@ PP(pp_fork) 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 @@ PP(pp_system) 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 @@ PP(pp_system) (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; diff --git a/proto.h b/proto.h index d03b3da..def3db1 100644 --- a/proto.h +++ b/proto.h @@ -496,6 +496,9 @@ PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len); 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); diff --git a/thread.h b/thread.h index 3b26b17..fae53f1 100644 --- a/thread.h +++ b/thread.h @@ -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) \ diff --git a/util.c b/util.c index e01e836..5262e6a 100644 --- a/util.c +++ b/util.c @@ -26,17 +26,6 @@ #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef I_SYS_WAIT # include #endif @@ -1858,7 +1847,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* 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 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #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 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) 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 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #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 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #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)