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)
#define xstat S_xstat
# endif
#endif
+#define lock Perl_lock
#if defined(PERL_OBJECT)
#endif
#define ck_anoncode Perl_ck_anoncode
#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)
#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
# endif
#endif
+Arp |SV* |lock |SV *sv
+
#if defined(PERL_OBJECT)
};
#endif
*/
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);
/* 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 */
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 */
# 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
# 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 */
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);
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) {
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));
}
# endif
#endif
+PERL_CALLCONV SV* Perl_lock(pTHX_ SV *sv) __attribute__((noreturn));
+
#if defined(PERL_OBJECT)
};
#endif
#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))
})
#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)
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
*/
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) ""
#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
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;
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;
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,
/* 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;
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);
}
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);
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;
/* 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;
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