various fixes for race conditions under threads: mutex locks based

on PL_threadnum were seriously flawed, since it means more than one
thread could enter the critical region; PL_na was global instead of
thread-local; child thread could finish and free thr structures
before Thread->new() got around to creating the Thread object;
cv_clone() needed locking, as it mucks with PL_comppad and other
global data; new_struct_thread() needed to lock template-thread's
mutex while copying its data

p4raw-id: //depot/perl@2385

diff --git a/embedvar.h b/embedvar.h
index 4d28711..bc1d495 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -47,6 +47,7 @@
 #define PL_markstack_ptr       (PL_curinterp->Tmarkstack_ptr)
 #define PL_maxscream           (PL_curinterp->Tmaxscream)
 #define PL_modcount            (PL_curinterp->Tmodcount)
+#define PL_na                  (PL_curinterp->Tna)
 #define PL_nrs                 (PL_curinterp->Tnrs)
 #define PL_ofs                 (PL_curinterp->Tofs)
 #define PL_ofslen              (PL_curinterp->Tofslen)
@@ -438,6 +439,7 @@
 #define PL_Tmarkstack_ptr      PL_markstack_ptr
 #define PL_Tmaxscream          PL_maxscream
 #define PL_Tmodcount           PL_modcount
+#define PL_Tna                 PL_na
 #define PL_Tnrs                        PL_nrs
 #define PL_Tofs                        PL_ofs
 #define PL_Tofslen             PL_ofslen
@@ -572,6 +574,7 @@
 #define PL_markstack_ptr       (thr->Tmarkstack_ptr)
 #define PL_maxscream           (thr->Tmaxscream)
 #define PL_modcount            (thr->Tmodcount)
+#define PL_na                  (thr->Tna)
 #define PL_nrs                 (thr->Tnrs)
 #define PL_ofs                 (thr->Tofs)
 #define PL_ofslen              (thr->Tofslen)
@@ -727,7 +730,6 @@
 #define PL_multi_end           (PL_Vars.Gmulti_end)
 #define PL_multi_open          (PL_Vars.Gmulti_open)
 #define PL_multi_start         (PL_Vars.Gmulti_start)
-#define PL_na                  (PL_Vars.Gna)
 #define PL_nexttoke            (PL_Vars.Gnexttoke)
 #define PL_nexttype            (PL_Vars.Gnexttype)
 #define PL_nextval             (PL_Vars.Gnextval)
@@ -860,7 +862,6 @@
 #define PL_Gmulti_end          PL_multi_end
 #define PL_Gmulti_open         PL_multi_open
 #define PL_Gmulti_start                PL_multi_start
-#define PL_Gna                 PL_na
 #define PL_Gnexttoke           PL_nexttoke
 #define PL_Gnexttype           PL_nexttype
 #define PL_Gnextval            PL_nextval

diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index 09751c5..e8dc4a2 100644 (file)
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -249,11 +249,13 @@ newthread (SV *startsv, AV *initargs, char *classname)
        XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
     XPUSHs(SvREFCNT_inc(startsv));
     PUTBACK;
+
+    /* On your marks... */
+    MUTEX_LOCK(&thr->mutex);
+
 #ifdef THREAD_CREATE
     err = THREAD_CREATE(thr, threadstart);
 #else    
-    /* On your marks... */
-    MUTEX_LOCK(&thr->mutex);
     /* Get set...  */
     sigfillset(&fullmask);
     if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
@@ -272,10 +274,10 @@ newthread (SV *startsv, AV *initargs, char *classname)
     }
     if (err == 0)
        err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr);
-    /* Go */
-    MUTEX_UNLOCK(&thr->mutex);
 #endif
+
     if (err) {
+       MUTEX_UNLOCK(&thr->mutex);
         DEBUG_S(PerlIO_printf(PerlIO_stderr(),
                              "%p: create of %p failed %d\n",
                              savethread, thr, err));
@@ -288,16 +290,23 @@ newthread (SV *startsv, AV *initargs, char *classname)
        SvREFCNT_dec(startsv);
        return NULL;
     }
+
 #ifdef THREAD_POST_CREATE
     THREAD_POST_CREATE(thr);
 #else
     if (sigprocmask(SIG_SETMASK, &oldmask, 0))
        croak("panic: sigprocmask");
 #endif
+
     sv = newSViv(thr->tid);
     sv_magic(sv, thr->oursv, '~', 0, 0);
     SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
-    return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
+    sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
+
+    /* Go */
+    MUTEX_UNLOCK(&thr->mutex);
+
+    return sv;
 #else
     croak("No threads in this perl");
     return &PL_sv_undef;

diff --git a/gv.c b/gv.c
index 85ac8f9..1c4c129 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -112,6 +112,7 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
     if (doproto) {                     /* Replicate part of newSUB here. */
        SvIOK_off(gv);
        ENTER;
+       /* XXX unsafe for threads if eval_owner isn't held */
        start_subparse(0,0);            /* Create CV in compcv. */
        GvCV(gv) = PL_compcv;
        LEAVE;

diff --git a/op.c b/op.c
index d98cbd9..85ed393 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3690,7 +3690,11 @@ cv_clone2(CV *proto, CV *outside)
 CV *
 cv_clone(CV *proto)
 {
-    return cv_clone2(proto, CvOUTSIDE(proto));
+    CV *cv;
+    MUTEX_LOCK(&PL_cred_mutex);                /* XXX create separate mutex */
+    cv = cv_clone2(proto, CvOUTSIDE(proto));
+    MUTEX_UNLOCK(&PL_cred_mutex);      /* XXX create separate mutex */
+    return cv;
 }
 
 void
@@ -4002,6 +4006,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
     return cv;
 }
 
+/* XXX unsafe for threads if eval_owner isn't held */
 void
 newCONSTSUB(HV *stash, char *name, SV *sv)
 {

diff --git a/perl.c b/perl.c
index 9ddf917..991f514 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1145,6 +1145,7 @@ CV*
 perl_get_cv(char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+    /* XXX unsafe for threads if eval_owner isn't held */
     if (create && !GvCVu(gv))
        return newSUB(start_subparse(FALSE, 0),
                      newSVOP(OP_CONST, 0, newSVpv(name,0)),

diff --git a/perlvars.h b/perlvars.h
index 17924a9..3860345 100644 (file)
--- a/perlvars.h
+++ b/perlvars.h
@@ -73,8 +73,6 @@ PERLVAR(Gnice_chunk_size,     U32)    /* how nice the chunk of memory is */
 PERLVARI(Grunops,      runops_proc_t,  FUNC_NAME_TO_PTR(RUNOPS_DEFAULT))
 
 PERLVAR(Gtokenbuf[256],        char)
-PERLVAR(Gna,           STRLEN)         /* for use in SvPV when length is
-                                          Not Applicable */
 
 PERLVAR(Gsv_undef,     SV)
 PERLVAR(Gsv_no,                SV)

diff --git a/pp_hot.c b/pp_hot.c
index 9b1791d..733b6b0 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2170,8 +2170,7 @@ PP(pp_entersub)
         * (3) instead of (2) so we'd have to clone. Would the fact
         * that we released the mutex more quickly make up for this?
         */
-       if (PL_threadnum &&
-           (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
+       if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
        {
            /* We already have a clone to use */
            MUTEX_UNLOCK(CvMUTEXP(cv));

diff --git a/thrdvar.h b/thrdvar.h
index 39405e1..69f17fb 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -52,6 +52,8 @@ PERLVAR(Tretstack_max,        I32)
 
 PERLVAR(TSv,           SV *)           /* used to hold temporary values */
 PERLVAR(TXpv,          XPV *)          /* used to hold temporary values */
+PERLVAR(Tna,           STRLEN)         /* for use in SvPV when length is
+                                          Not Applicable */
 
 /* stat stuff */
 PERLVAR(Tstatbuf,      Stat_t)

diff --git a/thread.h b/thread.h
index 1312b30..1455683 100644 (file)
--- a/thread.h
+++ b/thread.h
@@ -216,6 +216,8 @@ struct perl_thread *getTHR _((void));
  * from thrsv which is cached in the per-interpreter structure.
  * Systems with very fast pthread_get_specific (which should be all systems
  * but unfortunately isn't) may wish to simplify to "...*thr = THR".
+ *
+ * The use of PL_threadnum should be safe here.
  */
 #ifndef dTHR
 #  define dTHR \
@@ -238,30 +240,27 @@ struct perl_thread *getTHR _((void));
  * try only locking them if there may be more than one thread in existence.
  * Systems with very fast mutexes (and/or slow conditionals) may wish to
  * remove the "if (threadnum) ..." test.
+ * XXX do NOT use C<if (PL_threadnum) ...> -- it sets up race conditions!
  */
 #define LOCK_SV_MUTEX                          \
     STMT_START {                               \
-       if (PL_threadnum)                       \
-           MUTEX_LOCK(&PL_sv_mutex);           \
+       MUTEX_LOCK(&PL_sv_mutex);               \
     } STMT_END
 
 #define UNLOCK_SV_MUTEX                                \
     STMT_START {                               \
-       if (PL_threadnum)                       \
-           MUTEX_UNLOCK(&PL_sv_mutex);         \
+       MUTEX_UNLOCK(&PL_sv_mutex);             \
     } STMT_END
 
 /* Likewise for strtab_mutex */
 #define LOCK_STRTAB_MUTEX                      \
     STMT_START {                               \
-       if (PL_threadnum)                       \
-           MUTEX_LOCK(&PL_strtab_mutex);       \
+       MUTEX_LOCK(&PL_strtab_mutex);           \
     } STMT_END
 
 #define UNLOCK_STRTAB_MUTEX                    \
     STMT_START {                               \
-       if (PL_threadnum)                       \
-           MUTEX_UNLOCK(&PL_strtab_mutex);     \
+       MUTEX_UNLOCK(&PL_strtab_mutex);         \
     } STMT_END
 
 #ifndef THREAD_RET_TYPE

diff --git a/util.c b/util.c
index 10f1cc7..3be6a91 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2837,11 +2837,6 @@ new_struct_thread(struct perl_thread *t)
     thr->flags = THRf_R_JOINABLE;
     MUTEX_INIT(&thr->mutex);
 
-    PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
-    PL_defstash = t->Tdefstash;   /* XXX maybe these should */
-    PL_curstash = t->Tcurstash;   /* always be set to main? */
-
-
     /* top_env needs to be non-zero. It points to an area
        in which longjmp() stuff is stored, as C callstack
        info there at least is thread specific this has to
@@ -2858,6 +2853,25 @@ new_struct_thread(struct perl_thread *t)
     PL_in_eval = FALSE;
     PL_restartop = 0;
 
+    PL_statname = NEWSV(66,0);
+    PL_maxscream = -1;
+    PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
+    PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
+    PL_regindent = 0;
+    PL_reginterp_cnt = 0;
+    PL_lastscream = Nullsv;
+    PL_screamfirst = 0;
+    PL_screamnext = 0;
+    PL_reg_start_tmp = 0;
+    PL_reg_start_tmpl = 0;
+
+    /* parent thread's data needs to be locked while we make copy */
+    MUTEX_LOCK(&t->mutex);
+
+    PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
+    PL_defstash = t->Tdefstash;   /* XXX maybe these should */
+    PL_curstash = t->Tcurstash;   /* always be set to main? */
+
     PL_tainted = t->Ttainted;
     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
     PL_nrs = newSVsv(t->Tnrs);
@@ -2871,18 +2885,6 @@ new_struct_thread(struct perl_thread *t)
     PL_bodytarget = newSVsv(t->Tbodytarget);
     PL_toptarget = newSVsv(t->Ttoptarget);
 
-    PL_statname = NEWSV(66,0);
-    PL_maxscream = -1;
-    PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
-    PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
-    PL_regindent = 0;
-    PL_reginterp_cnt = 0;
-    PL_lastscream = Nullsv;
-    PL_screamfirst = 0;
-    PL_screamnext = 0;
-    PL_reg_start_tmp = 0;
-    PL_reg_start_tmpl = 0;
-    
     /* Initialise all per-thread SVs that the template thread used */
     svp = AvARRAY(t->threadsv);
     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
@@ -2905,6 +2907,9 @@ new_struct_thread(struct perl_thread *t)
     thr->next->prev = thr;
     MUTEX_UNLOCK(&PL_threads_mutex);
 
+    /* done copying parent's state */
+    MUTEX_UNLOCK(&t->mutex);
+
 #ifdef HAVE_THREAD_INTERN
     init_thread_intern(thr);
 #endif /* HAVE_THREAD_INTERN */

diff --git a/win32/win32thread.c b/win32/win32thread.c
index 1eb0e87..b40c5aa 100644 (file)
--- a/win32/win32thread.c
+++ b/win32/win32thread.c
@@ -92,7 +92,6 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn)
     DWORD junk;
     unsigned long th;
 
-    MUTEX_LOCK(&thr->mutex);
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
                          "%p: create OS thread\n", thr));
 #ifdef USE_RTL_THREAD_API
@@ -126,7 +125,6 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn)
 #endif /* !USE_RTL_THREAD_API */
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
                          "%p: OS thread = %p, id=%ld\n", thr, thr->self, junk));
-    MUTEX_UNLOCK(&thr->mutex);
     return thr->self ? 0 : -1;
 }
 #endif