Threadsafe patches

To: perl5-porters@perl.org
Message-Id: <4.3.1.0.20000508180729.02182de0@24.8.96.48>

p4raw-id: //depot/cfgperl@6207

diff --git a/embed.pl b/embed.pl
index f2628e9..f807d96 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2497,6 +2497,8 @@ s |void   |xstat          |int
 #  endif
 #endif
 
+Arp    |SV*    |lock           |SV *sv
+
 #if defined(PERL_OBJECT)
 };
 #endif

diff --git a/global.sym b/global.sym
index ec6180b..1d7eb97 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -542,3 +542,4 @@ Perl_ptr_table_fetch
 Perl_ptr_table_store
 Perl_ptr_table_split
 Perl_sys_intern_init
+Perl_lock

diff --git a/gv.c b/gv.c
index 1868114..39dbd1b 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -435,9 +435,13 @@ 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;
+    Perl_lock(aTHX_ (SV *)varstash);
     if (!isGV(vargv))
        gv_init(vargv, varstash, autoload, autolen, FALSE);
+    LEAVE;
     varsv = GvSV(vargv);
+    Perl_lock(aTHX_ varsv);
     sv_setpv(varsv, HvNAME(stash));
     sv_catpvn(varsv, "::", 2);
     sv_catpvn(varsv, name, len);

diff --git a/intrpvar.h b/intrpvar.h
index d7e4025..0540d2e 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -443,6 +443,10 @@ PERLVAR(IProc,             struct IPerlProc*)
 #if defined(USE_ITHREADS)
 PERLVAR(Iptr_table,    PTR_TBL_t*)
 #endif
+
+#if defined(USE_THREADS)
+PERLVAR(Isv_lock_mutex,        perl_mutex)     /* Mutex for SvLOCK macro */
+#endif
 PERLVARI(Ibeginav_save, AV*, Nullav)   /* save BEGIN{}s when compiling */
 
 PERLVAR(Inullstash,    HV *)           /* illegal symbols end up here */

diff --git a/perl.c b/perl.c
index b40e617..b36eb89 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -180,6 +180,7 @@ perl_construct(pTHXx)
 #  endif /* EMULATE_ATOMIC_REFCOUNTS */
        
        MUTEX_INIT(&PL_cred_mutex);
+       MUTEX_INIT(&PL_sv_lock_mutex);
 
        thr = init_main_thread();
 #endif /* USE_THREADS */

diff --git a/pp.c b/pp.c
index fc3a4a7..428b2e4 100644 (file)
--- 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 801f3f1..995c202 100644 (file)
--- 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 28c9581..afe67b1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1259,6 +1259,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 c0ce967..4251fe4 100644 (file)
--- 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) ""

diff --git a/util.c b/util.c
index 8962fff..dd8c842 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3492,6 +3492,38 @@ Perl_condpair_magic(pTHX_ SV *sv)
     return mg;
 }
 
+SV *
+Perl_lock(pTHX_ SV *osv)
+{
+#ifdef USE_THREADS
+    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": pp_lock lock 0x%"UVxf"\n",
+                             PTR2UV(thr), PTR2UV(sv));)
+       MUTEX_UNLOCK(MgMUTEXP(mg));
+       SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
+    }
+#endif
+  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,