[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.

14 files changed, 79 insertions, 84 deletions

diff --git a/cop.h b/cop.h
index dc52807841..f5afb61014 100644
--- 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 8738f692f5..54e59fca55 100644
--- 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 7c5575e1f3..72aba7a8b2 100644
--- 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 c4a0fa9042..52452617ac 100644
--- 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 632c87451d..69fc6bb374 100644
--- 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 d7660f7899..020e2a219c 100644
--- 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 56435d6e12..0124f513cd 100644
--- 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 a52241ff8c..f309efb5f1 100644
--- 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 a9516ea2aa..2d1bebccc3 100644
--- 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 44987d3211..fea53c0596 100644
--- 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 19d825a69e..5e9892fd3b 100644
--- 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 09a91f52ea..591cf75ae1 100644
--- 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 56f4407e4e..b4716dbf25 100644
--- 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 65121606e1..8dcbef4ba9 100644
--- 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