diff options
| -rw-r--r-- | doio.c | 2 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 2 | ||||
| -rw-r--r-- | gv.c | 9 | ||||
| -rw-r--r-- | intrpvar.h | 8 | ||||
| -rw-r--r-- | objXSUB.h | 4 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | pp.c | 19 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | sv.h | 60 | ||||
| -rw-r--r-- | util.c | 34 | ||||
| -rw-r--r-- | vmesa/vmesa.c | 10 | ||||
| -rw-r--r-- | win32/win32.c | 4 |
14 files changed, 130 insertions, 35 deletions
@@ -476,11 +476,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); + FDPID_LOCK; sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(PL_fdpid,fd,TRUE); + FDPID_UNLOCK; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) @@ -1129,6 +1129,7 @@ #define xstat S_xstat # endif #endif +#define lock Perl_lock #if defined(PERL_OBJECT) #endif #define ck_anoncode Perl_ck_anoncode @@ -2570,6 +2571,7 @@ #define xstat(a) S_xstat(aTHX_ a) # endif #endif +#define lock(a) Perl_lock(aTHX_ a) #if defined(PERL_OBJECT) #endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) @@ -4986,6 +4988,8 @@ #define xstat S_xstat # endif #endif +#define Perl_lock CPerlObj::Perl_lock +#define lock Perl_lock #if defined(PERL_OBJECT) #endif #define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode @@ -2498,6 +2498,8 @@ s |void |xstat |int # endif #endif +Arp |SV* |lock |SV *sv + #if defined(PERL_OBJECT) }; #endif @@ -435,9 +435,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + ENTER; + +#ifdef USE_THREADS + Perl_lock(aTHX_ (SV *)varstash); +#endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); + LEAVE; varsv = GvSV(vargv); +#ifdef USE_THREADS + Perl_lock(aTHX_ varsv); +#endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); diff --git a/intrpvar.h b/intrpvar.h index 9d513f71b4..d68641315c 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -140,6 +140,10 @@ PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */ /* subprocess state */ PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */ +#ifdef USE_THREADS +PERLVAR(Ifdpid_mutex, perl_mutex) /* mutex for fdpid array */ +#endif + /* internal state */ PERLVAR(Itainting, bool) /* doing taint checks */ PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */ @@ -456,4 +460,8 @@ PERLVAR(IProc, struct IPerlProc*) PERLVAR(Iptr_table, PTR_TBL_t*) #endif +#if defined(USE_THREADS) +PERLVAR(Isv_lock_mutex, perl_mutex) /* Mutex for SvLOCK macro */ +#endif + PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ @@ -2261,6 +2261,10 @@ # if defined(LEAKTEST) # endif #endif +#undef Perl_lock +#define Perl_lock pPerl->Perl_lock +#undef lock +#define lock Perl_lock #if defined(PERL_OBJECT) #endif @@ -180,6 +180,8 @@ perl_construct(pTHXx) # endif /* EMULATE_ATOMIC_REFCOUNTS */ MUTEX_INIT(&PL_cred_mutex); + MUTEX_INIT(&PL_sv_lock_mutex); + MUTEX_INIT(&PL_fdpid_mutex); thr = init_main_thread(); #endif /* USE_THREADS */ @@ -728,6 +730,7 @@ perl_destruct(pTHXx) MUTEX_DESTROY(&PL_sv_mutex); MUTEX_DESTROY(&PL_eval_mutex); MUTEX_DESTROY(&PL_cred_mutex); + MUTEX_DESTROY(&PL_fdpid_mutex); COND_DESTROY(&PL_eval_cond); #ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_DESTROY(&PL_svref_mutex); @@ -5257,24 +5257,7 @@ PP(pp_lock) dTOPss; SV *retsv = sv; #ifdef USE_THREADS - MAGIC *mg; - - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } + Perl_lock(aTHX_ sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { @@ -891,6 +891,10 @@ PP(pp_sort) PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); PL_sortstash = stash; } +#ifdef USE_THREADS + Perl_lock(aTHX_ (SV *)PL_firstgv); + Perl_lock(aTHX_ (SV *)PL_secondgv); +#endif SAVESPTR(GvSV(PL_firstgv)); SAVESPTR(GvSV(PL_secondgv)); } @@ -1260,6 +1260,8 @@ STATIC void S_xstat(pTHX_ int); # endif #endif +PERL_CALLCONV SV* Perl_lock(pTHX_ SV *sv) __attribute__((noreturn)); + #if defined(PERL_OBJECT) }; #endif @@ -123,21 +123,26 @@ perform the upgrade if necessary. See C<svtype>. #ifdef USE_THREADS -# ifdef EMULATE_ATOMIC_REFCOUNTS -# define ATOMIC_INC(count) STMT_START { \ - MUTEX_LOCK(&PL_svref_mutex); \ - ++count; \ - MUTEX_UNLOCK(&PL_svref_mutex); \ - } STMT_END -# define ATOMIC_DEC_AND_TEST(res,count) STMT_START { \ - MUTEX_LOCK(&PL_svref_mutex); \ - res = (--count == 0); \ - MUTEX_UNLOCK(&PL_svref_mutex); \ - } STMT_END -# else -# define ATOMIC_INC(count) atomic_inc(&count) -# define ATOMIC_DEC_AND_TEST(res,count) (res = atomic_dec_and_test(&count)) -# endif /* EMULATE_ATOMIC_REFCOUNTS */ +# if defined(VMS) +# define ATOMIC_INC(count) __ATOMIC_INCREMENT_LONG(&count) +# define ATOMIC_DEC_AND_TEST(res,count) res=(1==__ATOMIC_DECREMENT_LONG(&count)) + # else +# ifdef EMULATE_ATOMIC_REFCOUNTS + # define ATOMIC_INC(count) STMT_START { \ + MUTEX_LOCK(&PL_svref_mutex); \ + ++count; \ + MUTEX_UNLOCK(&PL_svref_mutex); \ + } STMT_END +# define ATOMIC_DEC_AND_TEST(res,count) STMT_START { \ + MUTEX_LOCK(&PL_svref_mutex); \ + res = (--count == 0); \ + MUTEX_UNLOCK(&PL_svref_mutex); \ + } STMT_END +# else +# define ATOMIC_INC(count) atomic_inc(&count) +# define ATOMIC_DEC_AND_TEST(res,count) (res = atomic_dec_and_test(&count)) +# endif /* EMULATE_ATOMIC_REFCOUNTS */ +# endif /* VMS */ #else # define ATOMIC_INC(count) (++count) # define ATOMIC_DEC_AND_TEST(res, count) (res = (--count == 0)) @@ -153,7 +158,12 @@ perform the upgrade if necessary. See C<svtype>. }) #else # if defined(CRIPPLED_CC) || defined(USE_THREADS) -# define SvREFCNT_inc(sv) sv_newref((SV*)sv) +# if defined(VMS) && defined(__ALPHA) +# define SvREFCNT_inc(sv) \ + (PL_Sv=(SV*)(sv), (PL_Sv && __ATOMIC_INCREMENT_LONG(&(SvREFCNT(PL_Sv)))), (SV *)PL_Sv) +# else +# define SvREFCNT_inc(sv) sv_newref((SV*)sv) +# endif # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)), (PL_Sv && ATOMIC_INC(SvREFCNT(PL_Sv))), (SV*)PL_Sv) @@ -997,6 +1007,13 @@ indicated number of bytes (remember to reserve space for an extra trailing NUL character). Calls C<sv_grow> to perform the expansion if necessary. Returns a pointer to the character buffer. +=for apidoc Am|void|SvLOCK|SV* sv +Aquires an internal mutex for a SV. Used to make sure multiple threads +don't stomp on the guts of an SV at the same time + +=for apidoc Am|void|SvUNLOCK|SV* sv +Release the internal mutex for an SV. + =cut */ @@ -1032,6 +1049,9 @@ Returns a pointer to the character buffer. SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) #ifdef DEBUGGING + +#define SvLOCK(sv) MUTEX_LOCK(&PL_sv_lock_mutex) +#define SvUNLOCK(sv) MUTEX_UNLOCK(&PL_sv_lock_mutex) #define SvPEEK(sv) sv_peek(sv) #else #define SvPEEK(sv) "" @@ -1045,3 +1065,11 @@ Returns a pointer to the character buffer. #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) #define Sv_Grow sv_grow + +#ifdef USE_THREADS +# define FDPID_LOCK MUTEX_LOCK(&PL_fdpid_mutex) +# define FDPID_UNLOCK MUTEX_UNLOCK(&PL_fdpid_mutex) +#else +# define FDPID_LOCK +# define FDPID_UNLOCK +#endif @@ -2402,7 +2402,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } + FDPID_LOCK; sv = *av_fetch(PL_fdpid,p[This],TRUE); + FDPID_UNLOCK; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; @@ -2620,7 +2622,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int saved_win32_errno; #endif + FDPID_LOCK; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); + FDPID_UNLOCK; pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -3492,6 +3496,36 @@ Perl_condpair_magic(pTHX_ SV *sv) return mg; } +SV * +Perl_lock(pTHX_ SV *osv) +{ + MAGIC *mg; + SV *sv = osv; + + SvLOCK(osv); + if (SvROK(sv)) { + sv = SvRV(sv); + SvUNLOCK(osv); + SvLOCK(sv); + } + + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) + MUTEX_UNLOCK(MgMUTEXP(mg)); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); + } + SvUNLOCK(sv); + return sv; +} + /* * Make a new perl thread structure using t as a prototype. Some of the * fields for the new thread are copied from the prototype thread, t, diff --git a/vmesa/vmesa.c b/vmesa/vmesa.c index 0e7894aeb9..b39638086f 100644 --- a/vmesa/vmesa.c +++ b/vmesa/vmesa.c @@ -182,11 +182,13 @@ do_aspawn(SV* really, SV **mark, SV **sp) /* be used by my_pclose */ /*---------------------------------------------*/ close(fd); + FDPID_LOCK; p_sv = av_fetch(PL_fdpid,fd,TRUE); fd = (int) SvIVX(*p_sv); SvREFCNT_dec(*p_sv); *p_sv = &PL_sv_undef; sv = *av_fetch(PL_fdpid,fd,TRUE); + FDPID_UNLOCK; (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; status = 0; @@ -408,11 +410,13 @@ my_popen(char *cmd, char *mode) Perl_stdin_fd = pFd[that]; if (strNE(cmd,"-")) { - PERL_FLUSHALL_FOR_CHILD; + PERL_FLUSHALL_FOR_CHILD; pid = spawn_cmd(cmd, Perl_stdin_fd, Perl_stdout_fd); if (pid >= 0) { + FDPID_LOCK; sv = *av_fetch(PL_fdpid,pFd[this],TRUE); + FDPID_UNLOCK; (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; fd = PerlIO_fdopen(pFd[this], mode); @@ -423,7 +427,9 @@ my_popen(char *cmd, char *mode) } else { + FDPID_LOCK; sv = *av_fetch(PL_fdpid,pFd[that],TRUE); + FDPID_UNLOCK; (void) SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pFd[this]; fd = PerlIO_fdopen(pFd[this], mode); @@ -460,7 +466,9 @@ my_pclose(FILE *fp) SV **sv; FILE *other; + FDPID_LOCK; sv = av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); + FDPID_UNLOCK; pid = (int) SvIVX(*sv); SvREFCNT_dec(*sv); *sv = &PL_sv_undef; diff --git a/win32/win32.c b/win32/win32.c index 1ba2e51758..c94d4c5126 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -2393,7 +2393,9 @@ win32_popen(const char *command, const char *mode) /* close saved handle */ win32_close(oldfd); + FDPID_LOCK; sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + FDPID_UNLOCK; /* set process id so that it can be returned by perl's open() */ PL_forkprocess = childpid; @@ -2429,7 +2431,9 @@ win32_pclose(FILE *pf) int childpid, status; SV *sv; + FDPID_LOCK; sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE); + FDPID_UNLOCK; if (SvIOK(sv)) childpid = SvIVX(sv); else |