[perl #78742] Store CopSTASH in a pad under threads

Before this commit, a pointer to the cop’s stash was stored in
cop->cop_stash under non-threaded perls, and the name and name length
were stored in cop->cop_stashpv and cop->cop_stashlen under ithreads.

Consequently, eval "__PACKAGE__" would end up returning the
wrong package name under threads if the current package had been
assigned over.

This commit changes the way cops store their stash under threads.  Now
it is an offset (cop->cop_stashoff) into the new PL_stashpad array
(just a mallocked block), which holds pointers to all stashes that
have code compiled in them.

I didn’t use the lexical pads, because CopSTASH(cop) won’t work unless
PL_curpad is holding the right pad.  And things start to get very
hairy in pp_caller, since the correct pad isn’t anywhere easily
accessible on the context stack (oldcomppad actually referring to the
current comppad).  The approach I’ve followed uses far less code, too.

In addition to fixing the bug, this also saves memory.  Instead of
allocating a separate PV for every single statement (to hold the stash
name), now all lines of code in a package can share the same stashpad
slot.  So, on a 32-bit OS X, that’s 16 bytes less memory per COP for
short package names.  Since stashoff is the same size as stashpv,
there is no difference there.  Each package now needs just 4 bytes in
the stashpad for storing a pointer.

For speed’s sake PL_stashpadix stores the index of the last-used
stashpad offset.  So only when switching packages is there a linear
search through the stashpad.

diff --git a/cop.h b/cop.h
index dc52807..f5afb61 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -387,9 +387,8 @@ struct cop {
     line_t      cop_line;       /* line # of this command */
     /* label for this construct is now stored in cop_hints_hash */
 #ifdef USE_ITHREADS
-    char *     cop_stashpv;    /* package line was compiled in */
+    PADOFFSET  cop_stashoff;   /* package line was compiled in */
     char *     cop_file;       /* file name the following line # is from */
-    I32         cop_stashlen;  /* negative for UTF8 */
 #else
     HV *       cop_stash;      /* package line was compiled in */
     GV *       cop_filegv;     /* file the following line # is from */
@@ -426,41 +425,14 @@ struct cop {
 #  else
 #    define CopFILEAVx(c)      (GvAV(gv_fetchfile(CopFILE(c))))
 #  endif
-#  define CopSTASHPV(c)                ((c)->cop_stashpv)
 
+#  define CopSTASH(c)           PL_stashpad[(c)->cop_stashoff]
+#  define CopSTASH_set(c,hv)   ((c)->cop_stashoff = (hv)               \
+                                   ? alloccopstash(hv)                 \
+                                   : 0)
 #  ifdef NETWARE
-#    define CopSTASHPV_set(c,pv,n)     ((c)->cop_stashpv = \
-                                          ((pv) ? savepvn(pv,n) : NULL))
-#  else
-#    define CopSTASHPV_set(c,pv,n)     ((c)->cop_stashpv = (pv) \
-                                           ? savesharedpvn(pv,n) : NULL)
-#  endif
-
-#  define CopSTASH_len_set(c,n)        ((c)->cop_stashlen = (n))
-#  define CopSTASH_len(c)      ((c)->cop_stashlen)
-
-#  define CopSTASH(c)          (CopSTASHPV(c)                                 \
-                                ? gv_stashpvn(CopSTASHPV(c),             \
-                                   CopSTASH_len(c) < 0                   \
-                                       ? -CopSTASH_len(c)                \
-                                       :  CopSTASH_len(c),               \
-                                    GV_ADD|SVf_UTF8*(CopSTASH_len(c) < 0) \
-                                  )                                      \
-                                 : NULL)
-#  define CopSTASH_set(c,hv)   (CopSTASHPV_set(c,                      \
-                                   (hv) ? HvNAME_get(hv) : NULL,       \
-                                   (hv) ? HvNAMELEN(hv)  : 0),         \
-                               CopSTASH_len_set(c,                     \
-                                   (hv) ? HvNAMEUTF8(hv)               \
-                                           ? -HvNAMELEN(hv)            \
-                                           :  HvNAMELEN(hv)            \
-                                        : 0))
-#  define CopSTASH_eq(c,hv)    ((hv) && stashpv_hvname_match(c,hv))
-#  ifdef NETWARE
-#    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
 #  else
-#    define CopSTASH_free(c)   PerlMemShared_free(CopSTASHPV(c))
 #    define CopFILE_free(c)    (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
 #  endif
 #else
@@ -479,15 +451,16 @@ struct cop {
                                    ? SvPVX(GvSV(CopFILEGV(c))) : NULL)
 #  define CopSTASH(c)          ((c)->cop_stash)
 #  define CopSTASH_set(c,hv)   ((c)->cop_stash = (hv))
-#  define CopSTASHPV(c)                (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
-   /* cop_stash is not refcounted */
-#  define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
-#  define CopSTASH_eq(c,hv)    (CopSTASH(c) == (hv))
-#  define CopSTASH_free(c)     
 #  define CopFILE_free(c)      (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
 
 #endif /* USE_ITHREADS */
 
+#define CopSTASHPV(c)          (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
+   /* cop_stash is not refcounted */
+#define CopSTASHPV_set(c,pv)   CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+#define CopSTASH_eq(c,hv)      (CopSTASH(c) == (hv))
+#define CopSTASH_free(c)       
+
 #define CopHINTHASH_get(c)     ((COPHH*)((c)->cop_hints_hash))
 #define CopHINTHASH_set(c,h)   ((c)->cop_hints_hash = (h))
 

diff --git a/embed.fnc b/embed.fnc
index 8738f69..54e59fc 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -973,6 +973,9 @@ p   |void   |package_version|NN OP* v
 : Used in toke.c and perly.y
 p      |PADOFFSET|allocmy      |NN const char *const name|const STRLEN len\
                                |const U32 flags
+#ifdef USE_ITHREADS
+p      |PADOFFSET|alloccopstash|NN HV *hv
+#endif
 : Used in perly.y
 pR     |OP*    |oopsAV         |NN OP* o
 : Used in perly.y

diff --git a/embed.h b/embed.h
index 7c5575e..72aba7a 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1742,6 +1742,7 @@
 #define pidgone(a,b)           S_pidgone(aTHX_ a,b)
 #  endif
 #  if defined(USE_ITHREADS)
+#define alloccopstash(a)       Perl_alloccopstash(aTHX_ a)
 #define mro_meta_dup(a,b)      Perl_mro_meta_dup(aTHX_ a,b)
 #define padlist_dup(a,b)       Perl_padlist_dup(aTHX_ a,b)
 #  endif

diff --git a/embedvar.h b/embedvar.h
index c4a0fa9..5245261 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -316,6 +316,9 @@
 #define PL_stack_sp            (vTHX->Istack_sp)
 #define PL_start_env           (vTHX->Istart_env)
 #define PL_stashcache          (vTHX->Istashcache)
+#define PL_stashpad            (vTHX->Istashpad)
+#define PL_stashpadix          (vTHX->Istashpadix)
+#define PL_stashpadmax         (vTHX->Istashpadmax)
 #define PL_statbuf             (vTHX->Istatbuf)
 #define PL_statcache           (vTHX->Istatcache)
 #define PL_statgv              (vTHX->Istatgv)

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 632c874..69fc6bb 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1163,10 +1163,12 @@ BOOT:
 #ifdef USE_ITHREADS
         cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
         XSANY.any_i32 = PMOP_pmoffset_ix;
+# if PERL_VERSION >= 17 && defined(CopSTASH_len)
         cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
         XSANY.any_i32 = COP_stashpv_ix;
         cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
         XSANY.any_i32 = COP_file_ix;
+# endif
 #else
         cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
         XSANY.any_i32 = COP_stash_ix;
@@ -1261,7 +1263,9 @@ COP_stashlen(o)
 
 #endif
 
-#else
+#endif
+
+#if !defined(USE_ITHREADS) || (PERL_VERSION > 16 && !defined(CopSTASH_len))
 
 char *
 COP_stashpv(o)

diff --git a/gv.c b/gv.c
index d7660f7..020e2a2 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -923,17 +923,8 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
     superisa = GvAVn(gv);
     GvMULTI_on(gv);
     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
-#ifdef USE_ITHREADS
-    av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
-                                     CopSTASH_len(PL_curcop) < 0
-                                       ? -CopSTASH_len(PL_curcop)
-                                       :  CopSTASH_len(PL_curcop),
-                                     SVf_UTF8*(CopSTASH_len(PL_curcop) < 0)
-                                    ));
-#else
     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
                               ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
 
     return stash;
 }

diff --git a/intrpvar.h b/intrpvar.h
index 56435d6..0124f51 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -690,6 +690,9 @@ PERLVAR(I, regex_padav,   AV *)             /* All regex objects, indexed via the
                                           Entry 0 is an SV whose PV is a
                                           "packed" list of IVs listing
                                           the now-free slots in the array */
+PERLVAR(I, stashpad,    HV **)         /* for CopSTASH */
+PERLVARI(I, stashpadmax, PADOFFSET, 64)
+PERLVARI(I, stashpadix, PADOFFSET, 0)
 #endif
 
 #ifdef USE_REENTRANT_API

diff --git a/makedef.pl b/makedef.pl
index a52241f..f309efb 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -355,6 +355,9 @@ unless ($define{'USE_ITHREADS'}) {
                    PL_hints_mutex
                    PL_my_ctx_mutex
                    PL_perlio_mutex
+                   PL_stashpad
+                   PL_stashpadix
+                   PL_stashpadmax
                    Perl_clone_params_del
                    Perl_clone_params_new
                    Perl_parser_dup

diff --git a/op.c b/op.c
index a9516ea..2d1bebc 100644 (file)
--- a/op.c
+++ b/op.c
@@ -465,6 +465,34 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
     return off;
 }
 
+#ifdef USE_ITHREADS
+PADOFFSET
+Perl_alloccopstash(pTHX_ HV *hv)
+{
+    PADOFFSET off = 0, o = 1;
+    bool found_slot = FALSE;
+
+    PERL_ARGS_ASSERT_ALLOCCOPSTASH;
+
+    if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
+
+    for (; o < PL_stashpadmax; ++o) {
+       if (PL_stashpad[o] == hv) return PL_stashpadix = o;
+       if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
+           found_slot = TRUE, off = o;
+    }
+    if (!found_slot) {
+       Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
+       Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
+       off = PL_stashpadmax;
+       PL_stashpadmax += 10;
+    }
+
+    PL_stashpad[PL_stashpadix = off] = hv;
+    return off;
+}
+#endif
+
 /* free the body of an op without examining its contents.
  * Always use this rather than FreeOp directly */
 
@@ -10014,8 +10042,7 @@ Perl_rpeep(pTHX_ register OP *o)
                       data.  */
                    firstcop->cop_line = secondcop->cop_line;
 #ifdef USE_ITHREADS
-                   firstcop->cop_stashpv = secondcop->cop_stashpv;
-                   firstcop->cop_stashlen = secondcop->cop_stashlen;
+                   firstcop->cop_stashoff = secondcop->cop_stashoff;
                    firstcop->cop_file = secondcop->cop_file;
 #else
                    firstcop->cop_stash = secondcop->cop_stash;
@@ -10027,7 +10054,7 @@ Perl_rpeep(pTHX_ register OP *o)
                    firstcop->cop_hints_hash = secondcop->cop_hints_hash;
 
 #ifdef USE_ITHREADS
-                   secondcop->cop_stashpv = NULL;
+                   secondcop->cop_stashoff = NULL;
                    secondcop->cop_file = NULL;
 #else
                    secondcop->cop_stash = NULL;

diff --git a/perl.c b/perl.c
index 44987d3..fea53c0 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -307,6 +307,7 @@ perl_construct(pTHXx)
        else all hell breaks loose in S_find_uninit_var().  */
     Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
     PL_regex_pad = AvARRAY(PL_regex_padav);
+    Newxz(PL_stashpad, PL_stashpadmax, HV *);
 #endif
 #ifdef USE_REENTRANT_API
     Perl_reentrant_init(aTHX);
@@ -843,6 +844,7 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_regex_padav);
     PL_regex_padav = NULL;
     PL_regex_pad = NULL;
+    Safefree(PL_stashpad);
 #endif
 
     SvREFCNT_dec(MUTABLE_SV(PL_stashcache));

diff --git a/proto.h b/proto.h
index 19d825a..5e9892f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7473,6 +7473,11 @@ PERL_CALLCONV I32        Perl_unlnk(pTHX_ const char* f)
 
 #endif
 #if defined(USE_ITHREADS)
+PERL_CALLCONV PADOFFSET        Perl_alloccopstash(pTHX_ HV *hv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_ALLOCCOPSTASH \
+       assert(hv)
+
 PERL_CALLCONV void*    Perl_any_dup(pTHX_ void* v, const PerlInterpreter* proto_perl)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_2);

diff --git a/scope.h b/scope.h
index 09a91f5..591cf75 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -235,10 +235,8 @@ scope has the given name. Name must be a literal string.
 #define SAVEPARSER(p) save_pushptr((p), SAVEt_PARSER)
 
 #ifdef USE_ITHREADS
-#  define SAVECOPSTASH(c)      (SAVEPPTR(CopSTASHPV(c)), \
-                                SAVEI32(CopSTASH_len(c)))
-#  define SAVECOPSTASH_FREE(c) (SAVESHAREDPV(CopSTASHPV(c)), \
-                                SAVEI32(CopSTASH_len(c)))
+#  define SAVECOPSTASH(c)      SAVEIV((c)->cop_stashoff)
+#  define SAVECOPSTASH_FREE(c) SAVEIV((c)->cop_stashoff)
 #  define SAVECOPFILE(c)       SAVEPPTR(CopFILE(c))
 #  define SAVECOPFILE_FREE(c)  SAVESHAREDPV(CopFILE(c))
 #else

diff --git a/sv.c b/sv.c
index 56f4407..b4716db 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -13210,10 +13210,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
 
-    /* These two PVs will be free'd special way so must set them same way op.c does */
-    PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
-    ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
-
+    /* This PV will be free'd special way so must set it same way op.c does */
     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
 
@@ -13271,6 +13268,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
     PL_regex_pad = AvARRAY(PL_regex_padav);
 
+    PL_stashpadmax     = proto_perl->Istashpadmax;
+    PL_stashpadix      = proto_perl->Istashpadix ;
+    Newx(PL_stashpad, PL_stashpadmax, HV *);
+    {
+       PADOFFSET o = 0;
+       for (; o < PL_stashpadmax; ++o)
+           PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
+    }
+
     /* shortcuts to various I/O objects */
     PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
     PL_stdingv         = gv_dup(proto_perl->Istdingv, param);

diff --git a/util.c b/util.c
index 6512160..8dcbef4 100644 (file)
--- a/util.c
+++ b/util.c
@@ -5698,32 +5698,8 @@ Perl_get_hash_seed(pTHX)
 bool
 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
 {
-    const char * stashpv = CopSTASHPV(c);
-    const char * name    = HvNAME_get(hv);
-    const bool utf8 = CopSTASH_len(c) < 0;
-    const I32  len  = utf8 ? -CopSTASH_len(c) : CopSTASH_len(c);
-    PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
-
-    if (!stashpv || !name)
-       return stashpv == name;
-    if ( !HvNAMEUTF8(hv) != !utf8 ) {
-        if (utf8) {
-            return (bytes_cmp_utf8(
-                        (const U8*)stashpv, len,
-                        (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0);
-        } else {
-            return (bytes_cmp_utf8(
-                        (const U8*)name, HEK_LEN(HvNAME_HEK(hv)),
-                        (const U8*)stashpv, len) == 0);
-        }
-    }
-    else
-        return (stashpv == name
-                    || (HEK_LEN(HvNAME_HEK(hv)) == len
-                        && memEQ(stashpv, name, len)));
-    /*NOTREACHED*/
-    return FALSE;
+    return CopSTASH(c) == hv;
 }
 #endif