From: Nicholas Clark Date: Wed, 12 Apr 2006 22:45:12 +0000 (+0000) Subject: Change cop_warnings from an SV holding the warnings bitmask to a X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=72dc9ed5af65c946f73050becea29207a1af86c1;p=p5sagit%2Fp5-mst-13.2.git 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 --- diff --git a/cop.h b/cop.h index fc69b91..a6749a0 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 4d038e4..9544007 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 cfb43fe..1f8d310 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 c0ebd1b..1921902 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 da99916..3bb789b 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 bd667ee..83baace 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 0cb3787..19c2ac5 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 6b73242..30f1fb0 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 be926c8..ebea9e1 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 e5160e1..5efb8fc 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 and L. 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 d6135ed..b32121a 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 b4ed7f2..abd0db9 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 7ef3c04..aa830c0 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 1265972..853a04a 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))