X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5aaab254c02795622bdf42e348ad8473aa1fc643..f244b085582eaec9f2cf7bfabeb686bf74167bf6:/pad.c diff --git a/pad.c b/pad.c index 0818625..a034d09 100644 --- a/pad.c +++ b/pad.c @@ -56,8 +56,10 @@ at that depth of recursion into the CV. The 0th slot of a frame AV is an AV which is @_. Other entries are storage for variables and op targets. Iterating over the PADNAMELIST iterates over all possible pad -items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having -&PL_sv_undef "names" (see pad_alloc()). +items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no +"names", while slots for constants have &PL_sv_no "names" (see +pad_alloc()). That &PL_sv_no is used is an implementation detail subject +to change. To test for it, use C. Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names. The rest are op targets/GVs/constants which are statically allocated @@ -196,7 +198,7 @@ sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U3 sv_recode_to_utf8(svrecode, PL_encoding); pv1 = SvPV_const(svrecode, cur1); } - SvREFCNT_dec(svrecode); + SvREFCNT_dec_NN(svrecode); } if (flags & SVf_UTF8) return (bytes_cmp_utf8( @@ -282,6 +284,8 @@ Perl_pad_new(pTHX_ int flags) else { av_store(pad, 0, NULL); padname = newAV(); + AvPAD_NAMELIST_on(padname); + av_store(padname, 0, &PL_sv_undef); } /* Most subroutines never recurse, hence only need 2 entries in the padlist @@ -427,7 +431,7 @@ Perl_cv_undef(pTHX_ CV *cv) if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ curpad[ix] = NULL; - SvREFCNT_dec(innercv); + SvREFCNT_dec_NN(innercv); inner_rc--; } @@ -457,7 +461,7 @@ Perl_cv_undef(pTHX_ CV *cv) PL_comppad = NULL; PL_curpad = NULL; } - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } } { @@ -572,6 +576,7 @@ S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) } av_store(PL_comppad_name, offset, namesv); + PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -627,8 +632,12 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, flags &= ~padadd_UTF8_NAME; if ((flags & padadd_NO_DUP_CHECK) == 0) { + ENTER; + SAVEFREESV(namesv); /* in case of fatal warnings */ /* check for duplicate declaration */ pad_check_dup(namesv, flags & padadd_OUR, ourstash); + SvREFCNT_inc_simple_void_NN(namesv); + LEAVE; } offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash); @@ -707,6 +716,13 @@ which will be set in the value SV for the allocated pad entry: SVs_PADMY named lexical variable ("my", "our", "state") SVs_PADTMP unnamed temporary store + SVf_READONLY constant shared between recursion levels + +C has been supported here only since perl 5.20. To work with +earlier versions as well, use C. C +does not cause the SV in the pad slot to be marked read-only, but simply +tells C that it I be made read-only (by the caller), or at +least should be treated as such. I should be an opcode indicating the type of operation that the pad entry is to support. This doesn't affect operational semantics, @@ -746,19 +762,24 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) const SSize_t names_fill = AvFILLp(PL_comppad_name); for (;;) { /* - * "foreach" index vars temporarily become aliases to non-"my" - * values. Thus we must skip, not just pad values that are + * Entries that close over unavailable variables + * in outer subs contain values not marked PADMY. + * Thus we must skip, not just pad values that are * marked as current pad values, but also those with names. */ - /* HVDS why copy to sv here? we don't seem to use it */ if (++PL_padix <= names_fill && (sv = names[PL_padix]) && sv != &PL_sv_undef) continue; sv = *av_fetch(PL_comppad, PL_padix, TRUE); if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && - !IS_PADGV(sv) && !IS_PADCONST(sv)) + !IS_PADGV(sv)) break; } + if (tmptype & SVf_READONLY) { + av_store(PL_comppad_name, PL_padix, &PL_sv_no); + tmptype &= ~SVf_READONLY; + tmptype |= SVs_PADTMP; + } retval = PL_padix; } SvFLAGS(sv) |= tmptype; @@ -826,7 +847,7 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype) if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) { assert(!CvWEAKOUTSIDE(func)); CvWEAKOUTSIDE_on(func); - SvREFCNT_dec(CvOUTSIDE(func)); + SvREFCNT_dec_NN(CvOUTSIDE(func)); } return ix; } @@ -870,7 +891,7 @@ S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash) for (off = top; (I32)off > PL_comppad_name_floor; off--) { SV * const sv = svp[off]; if (sv - && sv != &PL_sv_undef + && PadnameLEN(sv) && !SvFAKE(sv) && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) @@ -895,7 +916,7 @@ S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash) while (off > 0) { SV * const sv = svp[off]; if (sv - && sv != &PL_sv_undef + && PadnameLEN(sv) && !SvFAKE(sv) && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) @@ -971,10 +992,9 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; - if (namesv && namesv != &PL_sv_undef + if (namesv && PadnameLEN(namesv) == namelen && !SvFAKE(namesv) && (SvPAD_OUR(namesv)) - && SvCUR(namesv) == namelen && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen, flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 ) && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO @@ -1161,10 +1181,9 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, const AV * const nameav = PadlistARRAY(padlist)[0]; SV * const * const name_svp = AvARRAY(nameav); - for (offset = AvFILLp(nameav); offset > 0; offset--) { + for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; - if (namesv && namesv != &PL_sv_undef - && SvCUR(namesv) == namelen + if (namesv && PadnameLEN(namesv) == namelen && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen, flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)) { @@ -1513,7 +1532,7 @@ Perl_intro_my(pTHX) for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { SV * const sv = svp[i]; - if (sv && sv != &PL_sv_undef && !SvFAKE(sv) + if (sv && PadnameLEN(sv) && !SvFAKE(sv) && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) { COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ @@ -1561,7 +1580,7 @@ Perl_pad_leavemy(pTHX) if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { const SV * const sv = svp[off]; - if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) + if (sv && PadnameLEN(sv) && !SvFAKE(sv)) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "%"SVf" never introduced", SVfARG(sv)); @@ -1570,7 +1589,7 @@ Perl_pad_leavemy(pTHX) /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { SV * const sv = svp[off]; - if (sv && sv != &PL_sv_undef && !SvFAKE(sv) + if (sv && PadnameLEN(sv) && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) { COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); @@ -1623,8 +1642,6 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); - if (PL_curpad[po]) - SvPADTMP_off(PL_curpad[po]); if (refadjust) SvREFCNT_dec(PL_curpad[po]); @@ -1635,8 +1652,15 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) PL_curpad[po] = newSV(0); SvPADTMP_on(PL_curpad[po]); #else - PL_curpad[po] = &PL_sv_undef; + PL_curpad[po] = NULL; #endif + if (PadnamelistMAX(PL_comppad_name) != -1 + && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) { + if (PadnamelistARRAY(PL_comppad_name)[po]) { + assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); + } + PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef; + } if ((I32)po < PL_padix) PL_padix = po - 1; } @@ -1710,13 +1734,21 @@ Perl_pad_tidy(pTHX_ padtidy_type type) ASSERT_CURPAD_ACTIVE("pad_tidy"); - /* If this CV has had any 'eval-capable' ops planted in it - * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any - * anon prototypes in the chain of CVs should be marked as cloneable, - * so that for example the eval's CV in C<< sub { eval '$x' } >> gets - * the right CvOUTSIDE. - * If running with -d, *any* sub may potentially have an eval - * executed within it. + /* If this CV has had any 'eval-capable' ops planted in it: + * i.e. it contains any of: + * + * * eval '...', + * * //ee, + * * use re 'eval'; /$var/ + * * /(?{..})/), + * + * Then any anon prototypes in the chain of CVs should be marked as + * cloneable, so that for example the eval's CV in + * + * sub { eval '$x' } + * + * gets the right CvOUTSIDE. If running with -d, *any* sub may + * potentially have an eval executed within it. */ if (PL_cv_has_eval || PL_perldb) { @@ -1733,27 +1765,29 @@ Perl_pad_tidy(pTHX_ padtidy_type type) } } - /* extend curpad to match namepad */ + /* extend namepad to match curpad */ if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); if (type == padtidy_SUBCLONE) { - SV * const * const namep = AvARRAY(PL_comppad_name); + SV ** const namep = AvARRAY(PL_comppad_name); PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { SV *namesv; + if (!namep[ix]) namep[ix] = &PL_sv_undef; - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) - continue; /* * The only things that a clonable function needs in its - * pad are anonymous subs. + * pad are anonymous subs, constants and GVs. * The rest are created anew during cloning. */ - if (!((namesv = namep[ix]) != NULL && - namesv != &PL_sv_undef && - *SvPVX_const(namesv) == '&')) + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]) + || IS_PADGV(PL_curpad[ix])) + continue; + namesv = namep[ix]; + if (!(PadnamePV(namesv) && + (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&'))) { SvREFCNT_dec(PL_curpad[ix]); PL_curpad[ix] = NULL; @@ -1768,10 +1802,12 @@ Perl_pad_tidy(pTHX_ padtidy_type type) } if (type == padtidy_SUB || type == padtidy_FORMAT) { - SV * const * const namep = AvARRAY(PL_comppad_name); + SV ** const namep = AvARRAY(PL_comppad_name); PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) + if (!namep[ix]) namep[ix] = &PL_sv_undef; + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]) + || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; if (!SvPADMY(PL_curpad[ix])) { SvPADTMP_on(PL_curpad[ix]); @@ -1870,7 +1906,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) for (ix = 1; ix <= AvFILLp(pad_name); ix++) { const SV *namesv = pname[ix]; - if (namesv && namesv == &PL_sv_undef) { + if (namesv && !PadnameLEN(namesv)) { namesv = NULL; } if (namesv) { @@ -1964,7 +2000,7 @@ the immediately surrounding code. static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); static void -S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) +S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) { dVAR; I32 ix; @@ -2014,6 +2050,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) ENTER; SAVESPTR(PL_compcv); PL_compcv = cv; + if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */ if (CvHASEVAL(cv)) CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); @@ -2035,7 +2072,11 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) for (ix = fpad; ix > 0; ix--) { SV* const namesv = (ix <= fname) ? pname[ix] : NULL; SV *sv = NULL; - if (namesv && namesv != &PL_sv_undef) { /* lexical */ + if (namesv && PadnameLEN(namesv)) { /* lexical */ + if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */ + NOOP; + } + else { if (SvFAKE(namesv)) { /* lexical from outside? */ /* formats may have an inactive, or even undefined, parent; but state vars are always available. */ @@ -2089,8 +2130,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) if (sigil != '&' && SvPAD_STATE(namesv)) SvPADSTALE_on(sv); } + } } - else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { + else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) { sv = SvREFCNT_inc_NN(ppad[ix]); } else { @@ -2108,6 +2150,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv); } + if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; } @@ -2115,6 +2158,7 @@ static CV * S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) { dVAR; + const bool newcv = !cv; assert(!CvUNIQUE(proto)); @@ -2135,12 +2179,15 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) CvSTART(cv) = CvSTART(proto); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); - if (SvPOK(proto)) + if (SvPOK(proto)) { sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); + if (SvUTF8(proto)) + SvUTF8_on(MUTABLE_SV(cv)); + } if (SvMAGIC(proto)) mg_copy((SV *)proto, (SV *)cv, 0, 0); - if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside); + if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv); DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); @@ -2149,25 +2196,6 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) cv_dump(cv, "To"); ); - if (CvCONST(cv)) { - /* Constant sub () { $x } closing over $x - see lib/constant.pm: - * The prototype was marked as a candiate for const-ization, - * so try to grab the current const value, and if successful, - * turn into a const sub: - */ - SV* const const_sv = op_const_sv(CvSTART(cv), cv); - if (const_sv) { - SvREFCNT_dec(cv); - /* For this calling case, op_const_sv returns a *copy*, which we - donate to newCONSTSUB. Yes, this is ugly, and should be killed. - Need to fix how lib/constant.pm works to eliminate this. */ - cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); - } - else { - CvCONST_off(cv); - } - } - return cv; } @@ -2273,7 +2301,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) AV *av; for ( ;ix > 0; ix--) { - if (names_fill >= ix && names[ix] != &PL_sv_undef) { + if (names_fill >= ix && PadnameLEN(names[ix])) { const char sigil = SvPVX_const(names[ix])[0]; if ((SvFLAGS(names[ix]) & SVf_FAKE) || (SvFLAGS(names[ix]) & SVpad_STATE) @@ -2294,7 +2322,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) SvPADMY_on(sv); } } - else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) { av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); } else { @@ -2401,7 +2429,8 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) for ( ;ix > 0; ix--) { if (!oldpad[ix]) { pad1a[ix] = NULL; - } else if (names_fill >= ix && names[ix] != &PL_sv_undef) { + } else if (names_fill >= ix && names[ix] && + PadnameLEN(names[ix])) { const char sigil = SvPVX_const(names[ix])[0]; if ((SvFLAGS(names[ix]) & SVf_FAKE) || (SvFLAGS(names[ix]) & SVpad_STATE) @@ -2430,7 +2459,9 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) } } } - else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + else if (IS_PADGV(oldpad[ix]) + || ( names_fill >= ix && names[ix] + && PadnamePV(names[ix]) )) { pad1a[ix] = sv_dup_inc(oldpad[ix], param); } else {