X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d699ecb701ac42e5f50b4ec00c162c4dc9532b91..c58b680b06b94939ee921d7062cd14927136ae30:/op.c diff --git a/op.c b/op.c index 87e2e52..fd114b1 100644 --- a/op.c +++ b/op.c @@ -303,7 +303,8 @@ Perl_Slab_Free(pTHX_ void *op) PERL_ARGS_ASSERT_SLAB_FREE; if (!o->op_slabbed) { - PerlMemShared_free(op); + if (!o->op_static) + PerlMemShared_free(op); return; } @@ -379,9 +380,8 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab) ) ) { assert(slot->opslot_op.op_slabbed); - slab->opslab_refcnt++; /* op_free may free slab */ op_free(&slot->opslot_op); - if (!--slab->opslab_refcnt) goto free; + if (slab->opslab_refcnt == 1) goto free; } } } while ((slab2 = slab2->opslab_next)); @@ -390,6 +390,8 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab) #ifdef DEBUGGING assert(savestack_count == slab->opslab_refcnt-1); #endif + /* Remove the CV’s reference count. */ + slab->opslab_refcnt--; return; } free: @@ -576,6 +578,13 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } + else if (len == 2 && name[1] == '_' && !is_our) + /* diag_listed_as: Use of my $_ is deprecated */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Use of %s $_ is deprecated", + PL_parser->in_my == KEY_state + ? "state" + : "my"); /* allocate a spare slot and store the name in that slot */ @@ -645,12 +654,6 @@ S_op_destroy(pTHX_ OP *o) FreeOp(o); } -#ifdef USE_ITHREADS -# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) -#else -# define forget_pmop(a,b) S_forget_pmop(aTHX_ a) -#endif - /* Destructor */ void @@ -797,7 +800,7 @@ Perl_op_clear(pTHX_ OP *o) #endif if (still_valid) { int try_downgrade = SvREFCNT(gv) == 2; - SvREFCNT_dec(gv); + SvREFCNT_dec_NN(gv); if (try_downgrade) gv_try_downgrade(gv); } @@ -868,7 +871,7 @@ clear_pmop: if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) op_free(cPMOPo->op_code_list); cPMOPo->op_code_list = NULL; - forget_pmop(cPMOPo, 1); + forget_pmop(cPMOPo); cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the same protection as the "SAFE" version of the PM_ macros * here since sv_clean_all might release some PMOPs @@ -911,9 +914,6 @@ S_cop_free(pTHX_ COP* cop) STATIC void S_forget_pmop(pTHX_ PMOP *const o -#ifdef USE_ITHREADS - , U32 flags -#endif ) { HV * const pmstash = PmopSTASH(o); @@ -946,10 +946,6 @@ S_forget_pmop(pTHX_ PMOP *const o } if (PL_curpm == o) PL_curpm = NULL; -#ifdef USE_ITHREADS - if (flags) - PmopSTASH_free(o); -#endif } STATIC void @@ -965,7 +961,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) case OP_PUSHRE: case OP_MATCH: case OP_QR: - forget_pmop((PMOP*)kid, 0); + forget_pmop((PMOP*)kid); } find_and_forget_pmops(kid); kid = kid->op_sibling; @@ -1391,7 +1387,7 @@ Perl_scalarvoid(pTHX_ OP *o) PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT)); - SvREFCNT_dec(dsv); + SvREFCNT_dec_NN(dsv); } } else if (SvOK(sv)) { @@ -1760,7 +1756,7 @@ S_finalize_op(pTHX_ OP* o) /* If op_sv is already a PADTMP/MY then it is being used by * some pad, so make a copy. */ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); - SvREADONLY_on(PAD_SVl(ix)); + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } else if (o->op_type != OP_METHOD_NAMED @@ -1780,7 +1776,7 @@ S_finalize_op(pTHX_ OP* o) SvPADTMP_on(cSVOPo->op_sv); PAD_SETSV(ix, cSVOPo->op_sv); /* XXX I don't know how this isn't readonly already. */ - SvREADONLY_on(PAD_SVl(ix)); + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); } cSVOPo->op_sv = NULL; o->op_targ = ix; @@ -1801,13 +1797,13 @@ S_finalize_op(pTHX_ OP* o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) + if ((!SvIsCOW(sv = *svp)) && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0); - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); *svp = lexname; } @@ -1890,6 +1886,7 @@ S_finalize_op(pTHX_ OP* o) } break; } + case OP_SUBST: { if (cPMOPo->op_pmreplrootu.op_pmreplroot) finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); @@ -2829,7 +2826,7 @@ Perl_op_scope(pTHX_ OP *o) { dVAR; if (o) { - if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; @@ -3206,7 +3203,7 @@ S_op_integerize(pTHX_ OP *o) } static OP * -S_fold_constants(pTHX_ register OP *o) +S_fold_constants(pTHX_ OP *o) { dVAR; OP * VOL curop; @@ -3356,7 +3353,7 @@ S_fold_constants(pTHX_ register OP *o) } static OP * -S_gen_constant_list(pTHX_ register OP *o) +S_gen_constant_list(pTHX_ OP *o) { dVAR; OP *curop; @@ -3795,7 +3792,7 @@ Perl_mad_free(pTHX_ MADPROP* mp) case MAD_NULL: break; case MAD_PV: - Safefree((char*)mp->mad_val); + Safefree(mp->mad_val); break; case MAD_OP: if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ @@ -4643,7 +4640,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ SvREFCNT_inc_simple_void(PL_compcv); cv = newATTRSUB(floor, 0, NULL, NULL, qr); - ((struct regexp *)SvANY(re))->qr_anoncv = cv; + ReANY(re)->qr_anoncv = cv; /* attach the anon CV to the pad so that * pad_fixup_inner_anons() can find it */ @@ -4675,8 +4672,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) * preceding stacking ops; * OP_REGCRESET is there to reset taint before executing the * stacking ops */ - if (pm->op_pmflags & PMf_KEEP || PL_tainting) - expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr); + if (pm->op_pmflags & PMf_KEEP || TAINTING_get) + expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); if (pm->op_pmflags & PMf_HAS_CV) { /* we have a runtime qr with literal code. This means @@ -4752,62 +4749,48 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) } if (repl) { - OP *curop; + OP *curop = repl; + bool konst; if (pm->op_pmflags & PMf_EVAL) { - curop = NULL; if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); } - else if (repl->op_type == OP_CONST) - curop = repl; - else { - OP *lastop = NULL; - for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { - if (curop->op_type == OP_SCOPE - || curop->op_type == OP_LEAVE - || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { - if (curop->op_type == OP_GV) { - GV * const gv = cGVOPx_gv(curop); - repl_has_vars = 1; - if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) - break; - } - else if (curop->op_type == OP_RV2CV) - break; - else if (curop->op_type == OP_RV2SV || - curop->op_type == OP_RV2AV || - curop->op_type == OP_RV2HV || - curop->op_type == OP_RV2GV) { - if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ - break; - } - else if (curop->op_type == OP_PADSV || - curop->op_type == OP_PADAV || - curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) - { - repl_has_vars = 1; - } - else if (curop->op_type == OP_PUSHRE) - NOOP; /* Okay here, dangerous in newASSIGNOP */ - else - break; - } - lastop = curop; - } - } - if (curop == repl + /* If we are looking at s//.../e with a single statement, get past + the implicit do{}. */ + if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS + && cUNOPx(curop)->op_first->op_type == OP_SCOPE + && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { + OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; + if (kid->op_type == OP_NULL && kid->op_sibling + && !kid->op_sibling->op_sibling) + curop = kid->op_sibling; + } + if (curop->op_type == OP_CONST) + konst = TRUE; + else if (( (curop->op_type == OP_RV2SV || + curop->op_type == OP_RV2AV || + curop->op_type == OP_RV2HV || + curop->op_type == OP_RV2GV) + && cUNOPx(curop)->op_first + && cUNOPx(curop)->op_first->op_type == OP_GV ) + || curop->op_type == OP_PADSV + || curop->op_type == OP_PADAV + || curop->op_type == OP_PADHV + || curop->op_type == OP_PADANY) { + repl_has_vars = 1; + konst = TRUE; + } + else konst = FALSE; + if (konst && !(repl_has_vars && (!PM_GETRE(pm) + || !RX_PRELEN(PM_GETRE(pm)) || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ op_prepend_elem(o->op_type, scalar(repl), o); } else { - if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ - pm->op_pmflags |= PMf_MAYBE_CONST; - } NewOp(1101, rcop, 1, LOGOP); rcop->op_type = OP_SUBSTCONT; rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; @@ -5329,7 +5312,7 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) } STATIC I32 -S_is_list_assignment(pTHX_ register const OP *o) +S_is_list_assignment(pTHX_ const OP *o) { unsigned type; U8 flags; @@ -5600,7 +5583,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) = MUTABLE_GV(cSVOPx(tmpop)->op_sv); cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif - pm->op_pmflags |= PMf_ONCE; tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ tmpop->op_sibling = NULL; /* don't free split */ @@ -6423,7 +6405,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) { /* Basically turn for($x..$y) into the same as for($x,$y), but we * set the STACKED flag to indicate that these values are to be - * treated as min/max values by 'pp_iterinit'. + * treated as min/max values by 'pp_enteriter'. */ const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; @@ -6923,6 +6905,64 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return sv; } +static bool +S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, + PADNAME * const name, SV ** const const_svp) +{ + assert (cv); + assert (o || name); + assert (const_svp); + if ((!block +#ifdef PERL_MAD + || block->op_type == OP_NULL +#endif + )) { + if (CvFLAGS(PL_compcv)) { + /* might have had built-in attrs applied */ + const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); + if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl + && ckWARN(WARN_MISC)) + { + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); + SvREFCNT_inc_simple_void_NN(PL_compcv); + } + CvFLAGS(cv) |= + (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS + & ~(CVf_LVALUE * pureperl)); + } + return FALSE; + } + + /* redundant check for speed: */ + if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + SV *namesv = o + ? cSVOPo->op_sv + : sv_2mortal(newSVpvn_utf8( + PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) + )); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + report_redefined_cv(namesv, cv, const_svp); + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + } +#ifdef PERL_MAD + if (!PL_minus_c) /* keep old one around for madskills */ +#endif + { + /* (PL_madskills unset in used file.) */ + SvREFCNT_dec(cv); + } + return TRUE; +} + CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { @@ -6932,8 +6972,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) const char *ps; STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ U32 ps_utf8 = 0; - register CV *cv = NULL; - register CV *compcv = PL_compcv; + CV *cv = NULL; + CV *compcv = PL_compcv; SV *const_sv; PADNAME *name; PADOFFSET pax = o->op_targ; @@ -6981,6 +7021,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_parser && PL_parser->error_count) { op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = 0; goto done; } @@ -7037,49 +7079,14 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8); /* already defined? */ if (exists) { - if ((!block -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif - )) { - if (CvFLAGS(compcv)) { - /* might have had built-in attrs applied */ - const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); - if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl - && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); - CvFLAGS(cv) |= - (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS - & ~(CVf_LVALUE * pureperl)); - } + if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv)) + cv = NULL; + else { if (attrs) goto attrs; /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(compcv); goto done; } - else { - /* redundant check that avoids creating the extra SV - most of the time: */ - if (const_sv || ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - SV *noamp = sv_2mortal(newSVpvn_utf8( - PadnamePV(name)+1,PadnameLEN(name)-1, - PadnameUTF8(name) - )); - if (PL_parser && PL_parser->copline != NOLINE) - CopLINE_set(PL_curcop, PL_parser->copline); - report_redefined_cv(noamp, cv, &const_sv); - CopLINE_set(PL_curcop, oldline); - } -#ifdef PERL_MAD - if (!PL_minus_c) /* keep old one around for madskills */ -#endif - { - /* (PL_madskills unset in used file.) */ - SvREFCNT_dec(cv); - } - cv = NULL; - } } else if (CvDEPTH(outcv) && CvCLONE(compcv)) { cv = NULL; @@ -7279,7 +7286,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; if (reusable) cv_clone_into(clonee, *spot); else *spot = cv_clone(clonee); - SvREFCNT_dec(clonee); + SvREFCNT_dec_NN(clonee); cv = *spot; SvPADMY_on(cv); } @@ -7381,22 +7388,23 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (ec) { op_free(block); + if (name) SvREFCNT_dec(PL_compcv); + else cv = PL_compcv; + PL_compcv = 0; if (name && block) { const char *s = strrchr(name, ':'); s = s ? s+1 : name; if (strEQ(s, "BEGIN")) { - const char not_safe[] = - "BEGIN not safe after errors--compilation aborted"; if (PL_in_eval & EVAL_KEEPERR) - Perl_croak(aTHX_ not_safe); + Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); else { + SV * const errsv = ERRSV; /* force display of errors found but not reported */ - sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); + sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); + Perl_croak_nocontext("%"SVf, SVfARG(errsv)); } } } - cv = PL_compcv; goto done; } @@ -7442,48 +7450,14 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - if ((!block -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif - )) { - if (CvFLAGS(PL_compcv)) { - /* might have had built-in attrs applied */ - const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); - if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl - && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); - CvFLAGS(cv) |= - (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS - & ~(CVf_LVALUE * pureperl)); - } + if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) + cv = NULL; + else { if (attrs) goto attrs; /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); goto done; } - if (block -#ifdef PERL_MAD - && block->op_type != OP_NULL -#endif - ) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) { - /* This ensures that warnings are reported at the first - line of a redefinition, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - } - report_redefined_cv(cSVOPo->op_sv, cv, &const_sv); - CopLINE_set(PL_curcop, oldline); -#ifdef PERL_MAD - if (!PL_minus_c) /* keep old one around for madskills */ -#endif - { - /* (PL_madskills unset in used file.) */ - SvREFCNT_dec(cv); - } - cv = NULL; - } } } if (const_sv) { @@ -7567,7 +7541,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ - mro_method_changed_in(GvSTASH(gv)); + gv_method_changed(gv); } } if (!CvGV(cv)) { @@ -7633,7 +7607,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (attrs) { /* Need to do a C. */ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); + if (!name) SvREFCNT_inc_simple_void_NN(cv); } if (block && has_name) { @@ -7815,13 +7791,16 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); } + /* Protect sv against leakage caused by fatal warnings. */ + if (sv) SAVEFREESV(sv); + /* file becomes the CvFILE. For an XS, it's usually static storage, and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "", &sv, XS_DYNAMIC_FILENAME | flags); - CvXSUBANY(cv).any_ptr = sv; + CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); CvCONST_on(cv); LEAVE; @@ -7851,13 +7830,11 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; { - GV * const gv = name - ? gv_fetchpvn( - name,len,GV_ADDMULTI|flags,SVt_PVCV - ) - : gv_fetchpv( - (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), - GV_ADDMULTI | flags, SVt_PVCV); + GV * const gv = gv_fetchpvn( + name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + name ? len : PL_curstash ? sizeof("__ANON__") - 1: + sizeof("__ANON__::__ANON__") - 1, + GV_ADDMULTI | flags, SVt_PVCV); if (!subaddr) Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); @@ -7878,7 +7855,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, ), cv, const_svp); } - SvREFCNT_dec(cv); + SvREFCNT_dec_NN(cv); cv = NULL; } } @@ -7891,7 +7868,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, GvCV_set(gv,cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) - mro_method_changed_in(GvSTASH(gv)); /* newXS */ + gv_method_changed(gv); /* newXS */ } } if (!name) @@ -7925,7 +7902,7 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake) GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (!fake && HvENAME_HEK(GvSTASH(gv))) - mro_method_changed_in(GvSTASH(gv)); + gv_method_changed(gv); CvGV_set(cv, gv); CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); @@ -8154,6 +8131,7 @@ OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) { if (o->op_type == OP_PADANY) { + dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; return o; @@ -8499,7 +8477,7 @@ Perl_ck_exists(pTHX_ OP *o) } OP * -Perl_ck_rvconst(pTHX_ register OP *o) +Perl_ck_rvconst(pTHX_ OP *o) { dVAR; SVOP * const kid = (SVOP*)cUNOPo->op_first; @@ -9002,12 +8980,10 @@ Perl_ck_glob(pTHX_ OP *o) * \ mark - glob - rv2cv * | \ gv(CORE::GLOBAL::glob) * | - * \ null - const(wildcard) - const(ix) + * \ null - const(wildcard) */ o->op_flags |= OPf_SPECIAL; o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - op_append_elem(OP_GLOB, o, - newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o = newLISTOP(OP_LIST, 0, o, NULL); o = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, o, @@ -9026,12 +9002,11 @@ Perl_ck_glob(pTHX_ OP *o) LEAVE; } #endif /* !PERL_EXTERNAL_GLOB */ - gv = newGVgen("main"); + gv = (GV *)newSV(0); + gv_init(gv, 0, "", 0, 0); gv_IOadd(gv); -#ifndef PERL_EXTERNAL_GLOB - sv_setiv(GvSVn(gv),PL_glob_index++); -#endif op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + SvREFCNT_dec_NN(gv); /* newGVOP increased it */ scalarkids(o); return o; } @@ -9103,9 +9078,9 @@ Perl_ck_index(pTHX_ OP *o) if (kid) kid = kid->op_sibling; /* get past "big" */ if (kid && kid->op_type == OP_CONST) { - const bool save_taint = PL_tainted; + const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */ fbm_compile(((SVOP*)kid)->op_sv, 0); - PL_tainted = save_taint; + TAINT_set(save_taint); } } return ck_fun(o); @@ -9348,7 +9323,7 @@ Perl_ck_method(pTHX_ OP *o) const char * const method = SvPVX_const(sv); if (!(strchr(method, ':') || strchr(method, '\''))) { OP *cmop; - if (!SvREADONLY(sv) || !SvFAKE(sv)) { + if (!SvIsCOW(sv)) { sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); } else { @@ -9473,14 +9448,9 @@ Perl_ck_require(pTHX_ OP *o) const char *end; if (was_readonly) { - if (SvFAKE(sv)) { - sv_force_normal_flags(sv, 0); - assert(!SvREADONLY(sv)); - was_readonly = 0; - } else { SvREADONLY_off(sv); - } } + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); s = SvPVX(sv); len = SvCUR(sv); @@ -10547,7 +10517,7 @@ Perl_ck_svconst(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_SVCONST; PERL_UNUSED_CONTEXT; - SvREADONLY_on(cSVOPo->op_sv); + if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv); return o; } @@ -10794,10 +10764,11 @@ S_inplace_aassign(pTHX_ OP *o) { * peep() is called */ void -Perl_rpeep(pTHX_ register OP *o) +Perl_rpeep(pTHX_ OP *o) { dVAR; OP* oldop = NULL; + OP* oldoldop = NULL; OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ int defer_base = 0; int defer_ix = -1; @@ -10922,6 +10893,247 @@ Perl_rpeep(pTHX_ register OP *o) } break; + case OP_PUSHMARK: + + /* Convert a series of PAD ops for my vars plus support into a + * single padrange op. Basically + * + * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest + * + * becomes, depending on circumstances, one of + * + * padrange ----------------------------------> (list) -> rest + * padrange --------------------------------------------> rest + * + * where all the pad indexes are sequential and of the same type + * (INTRO or not). + * We convert the pushmark into a padrange op, then skip + * any other pad ops, and possibly some trailing ops. + * Note that we don't null() the skipped ops, to make it + * easier for Deparse to undo this optimisation (and none of + * the skipped ops are holding any resourses). It also makes + * it easier for find_uninit_var(), as it can just ignore + * padrange, and examine the original pad ops. + */ + { + OP *p; + OP *followop = NULL; /* the op that will follow the padrange op */ + U8 count = 0; + U8 intro = 0; + PADOFFSET base = 0; /* init only to stop compiler whining */ + U8 gimme = 0; /* init only to stop compiler whining */ + bool defav = 0; /* seen (...) = @_ */ + bool reuse = 0; /* reuse an existing padrange op */ + + /* look for a pushmark -> gv[_] -> rv2av */ + + { + GV *gv; + OP *rv2av, *q; + p = o->op_next; + if ( p->op_type == OP_GV + && (gv = cGVOPx_gv(p)) + && GvNAMELEN_get(gv) == 1 + && *GvNAME_get(gv) == '_' + && GvSTASH(gv) == PL_defstash + && (rv2av = p->op_next) + && rv2av->op_type == OP_RV2AV + && !(rv2av->op_flags & OPf_REF) + && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) + && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) + && o->op_sibling == rv2av /* these two for Deparse */ + && cUNOPx(rv2av)->op_first == p + ) { + q = rv2av->op_next; + if (q->op_type == OP_NULL) + q = q->op_next; + if (q->op_type == OP_PUSHMARK) { + defav = 1; + p = q; + } + } + } + if (!defav) { + /* To allow Deparse to pessimise this, it needs to be able + * to restore the pushmark's original op_next, which it + * will assume to be the same as op_sibling. */ + if (o->op_next != o->op_sibling) + break; + p = o; + } + + /* scan for PAD ops */ + + for (p = p->op_next; p; p = p->op_next) { + if (p->op_type == OP_NULL) + continue; + + if (( p->op_type != OP_PADSV + && p->op_type != OP_PADAV + && p->op_type != OP_PADHV + ) + /* any private flag other than INTRO? e.g. STATE */ + || (p->op_private & ~OPpLVAL_INTRO) + ) + break; + + /* let $a[N] potentially be optimised into ALEMFAST_LEX + * instead */ + if ( p->op_type == OP_PADAV + && p->op_next + && p->op_next->op_type == OP_CONST + && p->op_next->op_next + && p->op_next->op_next->op_type == OP_AELEM + ) + break; + + /* for 1st padop, note what type it is and the range + * start; for the others, check that it's the same type + * and that the targs are contiguous */ + if (count == 0) { + intro = (p->op_private & OPpLVAL_INTRO); + base = p->op_targ; + gimme = (p->op_flags & OPf_WANT); + } + else { + if ((p->op_private & OPpLVAL_INTRO) != intro) + break; + /* Note that you'd normally expect targs to be + * contiguous in my($a,$b,$c), but that's not the case + * when external modules start doing things, e.g. + i* Function::Parameters */ + if (p->op_targ != base + count) + break; + assert(p->op_targ == base + count); + /* all the padops should be in the same context */ + if (gimme != (p->op_flags & OPf_WANT)) + break; + } + + /* for AV, HV, only when we're not flattening */ + if ( p->op_type != OP_PADSV + && gimme != OPf_WANT_VOID + && !(p->op_flags & OPf_REF) + ) + break; + + if (count >= OPpPADRANGE_COUNTMASK) + break; + + /* there's a biggest base we can fit into a + * SAVEt_CLEARPADRANGE in pp_padrange */ + if (intro && base > + (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) + break; + + /* Success! We've got another valid pad op to optimise away */ + count++; + followop = p->op_next; + } + + if (count < 1) + break; + + /* pp_padrange in specifically compile-time void context + * skips pushing a mark and lexicals; in all other contexts + * (including unknown till runtime) it pushes a mark and the + * lexicals. We must be very careful then, that the ops we + * optimise away would have exactly the same effect as the + * padrange. + * In particular in void context, we can only optimise to + * a padrange if see see the complete sequence + * pushmark, pad*v, ...., list, nextstate + * which has the net effect of of leaving the stack empty + * (for now we leave the nextstate in the execution chain, for + * its other side-effects). + */ + assert(followop); + if (gimme == OPf_WANT_VOID) { + if (followop->op_type == OP_LIST + && gimme == (followop->op_flags & OPf_WANT) + && ( followop->op_next->op_type == OP_NEXTSTATE + || followop->op_next->op_type == OP_DBSTATE)) + { + followop = followop->op_next; /* skip OP_LIST */ + + /* consolidate two successive my(...);'s */ + + if ( oldoldop + && oldoldop->op_type == OP_PADRANGE + && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID + && (oldoldop->op_private & OPpLVAL_INTRO) == intro + && !(oldoldop->op_flags & OPf_SPECIAL) + ) { + U8 old_count; + assert(oldoldop->op_next == oldop); + assert( oldop->op_type == OP_NEXTSTATE + || oldop->op_type == OP_DBSTATE); + assert(oldop->op_next == o); + + old_count + = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); + assert(oldoldop->op_targ + old_count == base); + + if (old_count < OPpPADRANGE_COUNTMASK - count) { + base = oldoldop->op_targ; + count += old_count; + reuse = 1; + } + } + + /* if there's any immediately following singleton + * my var's; then swallow them and the associated + * nextstates; i.e. + * my ($a,$b); my $c; my $d; + * is treated as + * my ($a,$b,$c,$d); + */ + + while ( ((p = followop->op_next)) + && ( p->op_type == OP_PADSV + || p->op_type == OP_PADAV + || p->op_type == OP_PADHV) + && (p->op_flags & OPf_WANT) == OPf_WANT_VOID + && (p->op_private & OPpLVAL_INTRO) == intro + && p->op_next + && ( p->op_next->op_type == OP_NEXTSTATE + || p->op_next->op_type == OP_DBSTATE) + && count < OPpPADRANGE_COUNTMASK + ) { + assert(base + count == p->op_targ); + count++; + followop = p->op_next; + } + } + else + break; + } + + if (reuse) { + assert(oldoldop->op_type == OP_PADRANGE); + oldoldop->op_next = followop; + oldoldop->op_private = (intro | count); + o = oldoldop; + oldop = NULL; + oldoldop = NULL; + } + else { + /* Convert the pushmark into a padrange. + * To make Deparse easier, we guarantee that a padrange was + * *always* formerly a pushmark */ + assert(o->op_type == OP_PUSHMARK); + o->op_next = followop; + o->op_type = OP_PADRANGE; + o->op_ppaddr = PL_ppaddr[OP_PADRANGE]; + o->op_targ = base; + /* bit 7: INTRO; bit 6..0: count */ + o->op_private = (intro | count); + o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL)) + | gimme | (defav ? OPf_SPECIAL : 0)); + } + break; + } + case OP_PADAV: case OP_GV: if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { @@ -11278,13 +11490,14 @@ Perl_rpeep(pTHX_ register OP *o) } } + oldoldop = oldop; oldop = o; } LEAVE; } void -Perl_peep(pTHX_ register OP *o) +Perl_peep(pTHX_ OP *o) { CALL_RPEEP(o); }