integrate cfgperl changes#6207..6210 into mainline

p4raw-link: @6210 on //depot/cfgperl: b8b4c9f3cf6ef09c878a80ff97526a69902a44ca
p4raw-link: @6207 on //depot/cfgperl: b37a7757477319a5fcdd5131db15046064f631c4

p4raw-id: //depot/perl@6345

14 files changed, 130 insertions, 35 deletions

diff --git a/doio.c b/doio.c
index 0121633c84..6d03b20306 100644
--- a/doio.c
+++ b/doio.c
@@ -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)
diff --git a/embed.h b/embed.h
index ed1f34ecb5..ad2e738e26 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/embed.pl b/embed.pl
index 16a0697ea4..7afe36de8f 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2498,6 +2498,8 @@ s	|void	|xstat		|int
 #  endif
 #endif
 
+Arp	|SV*	|lock		|SV *sv
+
 #if defined(PERL_OBJECT)
 };
 #endif
diff --git a/gv.c b/gv.c
index 1868114325..1c3a95354e 100644
--- a/gv.c
+++ b/gv.c
@@ -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 */
diff --git a/objXSUB.h b/objXSUB.h
index b5ee2123eb..88ea89c016 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -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
 
diff --git a/perl.c b/perl.c
index 3947f28c5f..3c32a4e69a 100644
--- a/perl.c
+++ b/perl.c
@@ -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);
diff --git a/pp.c b/pp.c
index fc3a4a723e..428b2e4760 100644
--- a/pp.c
+++ b/pp.c
@@ -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) {
diff --git a/pp_ctl.c b/pp_ctl.c
index 9af9e8262c..94007601ed 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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));
 	    }
diff --git a/proto.h b/proto.h
index e16fcd617a..b3888d5870 100644
--- a/proto.h
+++ b/proto.h
@@ -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
diff --git a/sv.h b/sv.h
index c0ce96783d..f35049862a 100644
--- a/sv.h
+++ b/sv.h
@@ -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
diff --git a/util.c b/util.c
index 8962fff609..38591e9ea5 100644
--- a/util.c
+++ b/util.c
@@ -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