Change cop_warnings from an SV holding the warnings bitmask to a

directly (shared) malloc()ed buffer holding the warnings bitmask.
This avoids bugs/crashes when the interpreter that created an optree
is freed but the optree remains in use by other interpreters.

p4raw-id: //depot/perl@27779

14 files changed, 107 insertions, 45 deletions

diff --git a/cop.h b/cop.h
index fc69b916fe..a6749a06fa 100644
--- a/cop.h
+++ b/cop.h
@@ -146,7 +146,8 @@ struct cop {
     U32		cop_seq;	/* parse sequence number */
     I32		cop_arybase;	/* array base this line was compiled with */
     line_t      cop_line;       /* line # of this command */
-    SV *	cop_warnings;	/* lexical warnings bitmask */
+    /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
+    STRLEN *	cop_warnings;	/* lexical warnings bitmask */
     SV *	cop_io;		/* lexical IO defaults */
     /* compile time state of %^H.  See the comment in op.c for how this is
        used to recreate a hash to return from caller.  */
diff --git a/embed.fnc b/embed.fnc
index 4d038e400e..954400710b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1666,6 +1666,8 @@ Ap	|GV*	|gv_SVadd	|NN GV* gv
 #endif
 Apo	|bool	|ckwarn		|U32 w
 Apo	|bool	|ckwarn_d	|U32 w
+nopMa	|STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
+				|NN const char *const bits|STRLEN size
 
 p	|void	|offer_nice_chunk	|NN void *chunk|U32 chunk_size
 
diff --git a/embed.h b/embed.h
index cfb43feee0..1f8d310e13 100644
--- a/embed.h
+++ b/embed.h
@@ -3907,6 +3907,8 @@
 #define gv_SVadd(a)		Perl_gv_SVadd(aTHX_ a)
 #endif
 #ifdef PERL_CORE
+#endif
+#ifdef PERL_CORE
 #define offer_nice_chunk(a,b)	Perl_offer_nice_chunk(aTHX_ a,b)
 #endif
 #ifndef SPRINTF_RETURNS_STRLEN
diff --git a/mg.c b/mg.c
index c0ebd1b6a5..19219026f5 100644
--- a/mg.c
+++ b/mg.c
@@ -826,7 +826,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		}
 	    }
             else {
-	        sv_setsv(sv, PL_compiling.cop_warnings);
+	        sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+			  *PL_compiling.cop_warnings);
 	    }
 	    SvPOK_only(sv);
 	}
@@ -2274,15 +2275,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		    }
 		    if (!accumulate)
 	                PL_compiling.cop_warnings = pWARN_NONE;
-		    else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+		    /* Yuck. I can't see how to abstract this:  */
+		    else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
+				       WARN_ALL) && !any_fatals) {
 	                PL_compiling.cop_warnings = pWARN_ALL;
 	                PL_dowarn |= G_WARN_ONCE ;
 	            }
                     else {
-	                if (specialWARN(PL_compiling.cop_warnings))
-		            PL_compiling.cop_warnings = newSVsv(sv) ;
-	                else
-	                    sv_setsv(PL_compiling.cop_warnings, sv);
+			STRLEN len;
+			const char *const p = SvPV_const(sv, len);
+
+			PL_compiling.cop_warnings
+			    = Perl_new_warnings_bitfield(PL_compiling.cop_warnings,
+							 p, len);
+
 	                if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
 	                    PL_dowarn |= G_WARN_ONCE ;
 	            }
diff --git a/op.c b/op.c
index da99916d1f..3bb789b517 100644
--- a/op.c
+++ b/op.c
@@ -506,7 +506,7 @@ S_cop_free(pTHX_ COP* cop)
     CopFILE_free(cop);
     CopSTASH_free(cop);
     if (! specialWARN(cop->cop_warnings))
-	SvREFCNT_dec(cop->cop_warnings);
+	PerlMemShared_free(cop->cop_warnings);
     if (! specialCopIO(cop->cop_io)) {
 #ifdef USE_ITHREADS
 	/*EMPTY*/
@@ -1974,7 +1974,7 @@ Perl_scope(pTHX_ OP *o)
     }
     return o;
 }
-
+	
 int
 Perl_block_start(pTHX_ int full)
 {
@@ -1983,11 +1983,8 @@ Perl_block_start(pTHX_ int full)
     pad_block_start(full);
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
-    SAVESPTR(PL_compiling.cop_warnings);
-    if (! specialWARN(PL_compiling.cop_warnings)) {
-        PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
-        SAVEFREESV(PL_compiling.cop_warnings) ;
-    }
+    SAVECOPWARNINGS(&PL_compiling);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
     SAVESPTR(PL_compiling.cop_io);
     if (! specialCopIO(PL_compiling.cop_io)) {
         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
@@ -3946,10 +3943,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     }
     cop->cop_seq = seq;
     CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
-    if (specialWARN(PL_curcop->cop_warnings))
-        cop->cop_warnings = PL_curcop->cop_warnings ;
-    else
-        cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+    cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     if (specialCopIO(PL_curcop->cop_io))
         cop->cop_io = PL_curcop->cop_io;
     else
diff --git a/perl.c b/perl.c
index bd667eee7b..83baacea04 100644
--- a/perl.c
+++ b/perl.c
@@ -1035,7 +1035,7 @@ perl_destruct(pTHXx)
     PL_utf8_idcont	= NULL;
 
     if (!specialWARN(PL_compiling.cop_warnings))
-	SvREFCNT_dec(PL_compiling.cop_warnings);
+	PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
     if (!specialCopIO(PL_compiling.cop_io))
 	SvREFCNT_dec(PL_compiling.cop_io);
@@ -2037,7 +2037,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
 
     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
-       PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+        PL_compiling.cop_warnings
+	    = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
     }
 
     if (!scriptname)
@@ -3369,14 +3370,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
     case 'W':
 	PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
 	PL_compiling.cop_warnings = pWARN_ALL ;
 	s++;
 	return s;
     case 'X':
 	PL_dowarn = G_WARN_ALL_OFF;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
 	PL_compiling.cop_warnings = pWARN_NONE ;
 	s++;
 	return s;
diff --git a/pp_ctl.c b/pp_ctl.c
index 0cb37874c2..19c2ac5fa7 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1698,7 +1698,7 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
     {
 	SV * mask ;
-	SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
+	STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
 
 	if  (old_warnings == pWARN_NONE ||
 		(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
@@ -1717,7 +1717,7 @@ PP(pp_caller)
 	    }
 	}
         else
-            mask = newSVsv(old_warnings);
+            mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
         PUSHs(sv_2mortal(mask));
     }
 
@@ -3363,13 +3363,15 @@ PP(pp_require)
     PL_rsfp = tryrsfp;
     SAVEHINTS();
     PL_hints = 0;
-    SAVESPTR(PL_compiling.cop_warnings);
+    SAVECOPWARNINGS(&PL_compiling);
     if (PL_dowarn & G_WARN_ALL_ON)
         PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
         PL_compiling.cop_warnings = pWARN_NONE ;
-    else if (PL_taint_warn)
-        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+    else if (PL_taint_warn) {
+        PL_compiling.cop_warnings
+	    = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
+    }
     else
         PL_compiling.cop_warnings = pWARN_STD ;
     SAVESPTR(PL_compiling.cop_io);
@@ -3461,13 +3463,8 @@ PP(pp_entereval)
     PL_hints = PL_op->op_targ;
     if (saved_hh)
 	GvHV(PL_hintgv) = saved_hh;
-    SAVESPTR(PL_compiling.cop_warnings);
-    if (specialWARN(PL_curcop->cop_warnings))
-        PL_compiling.cop_warnings = PL_curcop->cop_warnings;
-    else {
-        PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
-        SAVEFREESV(PL_compiling.cop_warnings);
-    }
+    SAVECOPWARNINGS(&PL_compiling);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     SAVESPTR(PL_compiling.cop_io);
     if (specialCopIO(PL_curcop->cop_io))
         PL_compiling.cop_io = PL_curcop->cop_io;
diff --git a/proto.h b/proto.h
index 6b7324216b..30f1fb04c7 100644
--- a/proto.h
+++ b/proto.h
@@ -4293,6 +4293,11 @@ PERL_CALLCONV GV*	Perl_gv_SVadd(pTHX_ GV* gv)
 #endif
 PERL_CALLCONV bool	Perl_ckwarn(pTHX_ U32 w);
 PERL_CALLCONV bool	Perl_ckwarn_d(pTHX_ U32 w);
+PERL_CALLCONV STRLEN *	Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits, STRLEN size)
+			__attribute__malloc__
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(2);
+
 
 PERL_CALLCONV void	Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
 			__attribute__nonnull__(pTHX_1);
diff --git a/scope.c b/scope.c
index be926c8f11..ebea9e13e9 100644
--- a/scope.c
+++ b/scope.c
@@ -764,6 +764,10 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    Safefree(ptr);
 	    break;
+	case SAVEt_FREESHAREDPV:
+	    ptr = SSPOPPTR;
+	    PerlMemShared_free(ptr);
+	    break;
 	case SAVEt_CLEARSV:
 	    ptr = (void*)&PL_curpad[SSPOPLONG];
 	    sv = *(SV**)ptr;
@@ -984,6 +988,17 @@ Perl_leave_scope(pTHX_ I32 base)
 	    i = SSPOPINT;
 	    CopARYBASE_set((COP *)ptr, i);
 	    break;
+	case SAVEt_COP_WARNINGS:
+	    {
+		COP *const cop = SSPOPPTR;
+		ptr = SSPOPPTR;
+
+		if (!specialWARN(cop->cop_warnings))
+		    PerlMemShared_free(cop->cop_warnings);
+
+		cop->cop_warnings = ptr;
+	    }
+	    break;
 	case SAVEt_RE_STATE:
 	    {
 		const struct re_save_state *const state
diff --git a/scope.h b/scope.h
index e5160e1b36..5efb8fca53 100644
--- a/scope.h
+++ b/scope.h
@@ -51,6 +51,8 @@
 #define SAVEt_SAVESWITCHSTACK	40
 #define SAVEt_COP_ARYBASE	41
 #define SAVEt_RE_STATE		42
+#define SAVEt_FREESHAREDPV	43
+#define SAVEt_COP_WARNINGS	44
 
 #ifndef SCOPE_SAVES_SIGNAL_MASK
 #define SCOPE_SAVES_SIGNAL_MASK 0
@@ -192,6 +194,25 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 	SSPUSHINT(SAVEt_COP_ARYBASE);			\
     } STMT_END
 
+#define SAVEFREESHAREDPV(pv)				\
+    STMT_START {					\
+	SSCHECK(2);					\
+	SSPUSHPTR(pv);					\
+	SSPUSHINT(SAVEt_FREESHAREDPV);			\
+    } STMT_END
+
+/* Need to do the cop warnings like this, rather than SAVEFREESHAREDPV,
+   because realloc() means that the value can actually change. Possibly
+   could have done savefreesharedpvREF, but this way actually seems cleaner,
+   as it simplifies the code that does the saves, and reduces the load on the
+   save stack.  */
+#define SAVECOPWARNINGS(c) \
+    STMT_START {					\
+	SSCHECK(3);					\
+	SSPUSHPTR((c)->cop_warnings);			\
+	SSPUSHPTR(c);					\
+	SSPUSHINT(SAVEt_COP_WARNINGS);			\
+    } STMT_END
 
 #ifdef USE_ITHREADS
 #  define SAVECOPSTASH(c)	SAVEPPTR(CopSTASHPV(c))
diff --git a/sv.c b/sv.c
index d6135eddac..b32121addc 100644
--- a/sv.c
+++ b/sv.c
@@ -10936,8 +10936,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
 
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
-    if (!specialWARN(PL_compiling.cop_warnings))
-	PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
     if (!specialCopIO(PL_compiling.cop_io))
 	PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
     if (PL_compiling.cop_hints) {
diff --git a/util.c b/util.c
index b4ed7f27ad..abd0db9c80 100644
--- a/util.c
+++ b/util.c
@@ -1531,7 +1531,18 @@ Perl_ckwarn_d(pTHX_ U32 w)
 	;
 }
 
-
+/* Set buffer=NULL to get a new one.  */
+STRLEN *
+Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits,
+			   STRLEN size) {
+    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+
+    buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
+	: PerlMemShared_realloc(buffer, len_wanted);
+    buffer[0] = size;
+    Copy(bits, (buffer + 1), size, char);
+    return buffer;
+}
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
diff --git a/warnings.h b/warnings.h
index 7ef3c0495c..aa830c05fe 100644
--- a/warnings.h
+++ b/warnings.h
@@ -18,8 +18,8 @@
 #define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define pWARN_STD		NULL
-#define pWARN_ALL		(((SV*)0)+1)	/* use warnings 'all' */
-#define pWARN_NONE		(((SV*)0)+2)	/* no  warnings 'all' */
+#define pWARN_ALL		(((STRLEN*)0)+1)    /* use warnings 'all' */
+#define pWARN_NONE		(((STRLEN*)0)+2)    /* no  warnings 'all' */
 
 #define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
 				 (x) == pWARN_NONE)
@@ -85,8 +85,12 @@
 #define isLEXWARN_on 	(PL_curcop->cop_warnings != pWARN_STD)
 #define isLEXWARN_off	(PL_curcop->cop_warnings == pWARN_STD)
 #define isWARN_ONCE	(PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x)	(IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x)	(IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p)		\
+    specialWARN(p) ? (p)	\
+    : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
 
 #define ckWARN(w)		Perl_ckwarn(aTHX_ packWARN(w))
 #define ckWARN2(w1,w2)		Perl_ckwarn(aTHX_ packWARN2(w1,w2))
diff --git a/warnings.pl b/warnings.pl
index 126597291a..853a04a1a7 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -277,8 +277,8 @@ print WARN <<'EOM' ;
 #define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define pWARN_STD		NULL
-#define pWARN_ALL		(((SV*)0)+1)	/* use warnings 'all' */
-#define pWARN_NONE		(((SV*)0)+2)	/* no  warnings 'all' */
+#define pWARN_ALL		(((STRLEN*)0)+1)    /* use warnings 'all' */
+#define pWARN_NONE		(((STRLEN*)0)+2)    /* no  warnings 'all' */
 
 #define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
 				 (x) == pWARN_NONE)
@@ -325,8 +325,12 @@ print WARN <<'EOM';
 #define isLEXWARN_on 	(PL_curcop->cop_warnings != pWARN_STD)
 #define isLEXWARN_off	(PL_curcop->cop_warnings == pWARN_STD)
 #define isWARN_ONCE	(PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x)	(IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x)	(IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p)		\
+    specialWARN(p) ? (p)	\
+    : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
 
 #define ckWARN(w)		Perl_ckwarn(aTHX_ packWARN(w))
 #define ckWARN2(w1,w2)		Perl_ckwarn(aTHX_ packWARN2(w1,w2))