X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/292890215fdbc36b4a0e17df565919fb3f5b8694..a469502ffde47af0b05b575bdfc51039218392df:/pad.c diff --git a/pad.c b/pad.c index 8b5f86a..b5e39fa 100644 --- a/pad.c +++ b/pad.c @@ -1,6 +1,6 @@ /* pad.c * - * Copyright (C) 2002, 2003, 2004, by Larry Wall and others + * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -22,6 +22,11 @@ /* =head1 Pad Data Structures +This file contains the functions that create and manipulate scratchpads, +which are array-of-array data structures attached to a CV (ie a sub) +and which store lexical variables and opcode temporary and per-thread +values. + =for apidoc m|AV *|CvPADLIST|CV *cv CV's can have CvPADLIST(cv) set to point to an AV. @@ -67,19 +72,19 @@ but only by their index allocated at compile time (which is usually in PL_op->op_targ), wasting a name SV for them doesn't make sense. The SVs in the names AV have their PV being the name of the variable. -NV+1..IV inclusive is a range of cop_seq numbers for which the name is -valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the -type. For C lexicals, the type is SVt_PVGV, and GvSTASH points at the -stash of the associated global (so that duplicate C delarations in the -same package can be detected). SvCUR is sometimes hijacked to -store the generation number during compilation. +xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for +which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH +points at the type. For C lexicals, the type is also SVt_PVMG, with the +SvOURSTASH slot pointing at the stash of the associated global (so that +duplicate C declarations in the same package can be detected). SvUVX is +sometimes hijacked to store the generation number during compilation. If SvFAKE is set on the name SV, then that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside". In this case, -the name SV does not use NVX and IVX to store a cop_seq range, since it is -in scope throughout. Instead IVX stores some flags containing info about +the name SV does not use xlow and xhigh to store a cop_seq range, since it is +in scope throughout. Instead xhigh stores some flags containing info about the real lexical (is it declared in an anon, and is it capable of being -instantiated multiple times?), and for fake ANONs, NVX contains the index +instantiated multiple times?), and for fake ANONs, xlow contains the index within the parent's pad where the lexical's value is stored, to make cloning quicker. @@ -97,6 +102,8 @@ to be generated in evals, such as { my $x = 1; sub f { eval '$x'} } f(); +For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised' + =cut */ @@ -104,11 +111,29 @@ to be generated in evals, such as #include "EXTERN.h" #define PERL_IN_PAD_C #include "perl.h" +#include "keywords.h" + +#define COP_SEQ_RANGE_LOW_set(sv,val) \ + STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END +#define COP_SEQ_RANGE_HIGH_set(sv,val) \ + STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END +#define PARENT_PAD_INDEX_set(sv,val) \ + STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END +#define PARENT_FAKELEX_FLAGS_set(sv,val) \ + STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END -#define PAD_MAX 999999999 +#define PAD_MAX I32_MAX +#ifdef PERL_MAD +void pad_peg(const char* s) { + static int pegcnt; + PERL_ARGS_ASSERT_PAD_PEG; + + pegcnt++; +} +#endif /* =for apidoc pad_new @@ -127,7 +152,8 @@ can be OR'ed together: PADLIST * Perl_pad_new(pTHX_ int flags) { - AV *padlist, *padname, *pad, *a0; + dVAR; + AV *padlist, *padname, *pad; ASSERT_CURPAD_LEGAL("pad_new"); @@ -147,7 +173,7 @@ Perl_pad_new(pTHX_ int flags) SAVEI32(PL_comppad_name_fill); SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); - SAVEI32(PL_cv_has_eval); + SAVEBOOL(PL_cv_has_eval); if (flags & padnew_SAVESUB) { SAVEI32(PL_pad_reset_pending); } @@ -168,13 +194,13 @@ Perl_pad_new(pTHX_ int flags) * dispensed with eventually ??? */ - a0 = newAV(); /* will be @_ */ + AV * const a0 = newAV(); /* will be @_ */ av_extend(a0, 0); av_store(pad, 0, (SV*)a0); - AvFLAGS(a0) = AVf_REIFY; + AvREIFY_only(a0); } else { - av_store(pad, 0, Nullsv); + av_store(pad, 0, NULL); } AvREAL_off(padlist); @@ -223,17 +249,21 @@ taken) void Perl_pad_undef(pTHX_ CV* cv) { + dVAR; I32 ix; - PADLIST *padlist = CvPADLIST(cv); + const PADLIST * const padlist = CvPADLIST(cv); + + PERL_ARGS_ASSERT_PAD_UNDEF; + pad_peg("pad_undef"); if (!padlist) return; - if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */ + if (SvIS_FREED(padlist)) /* may be during global destruction */ return; DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n", - PTR2UV(cv), PTR2UV(padlist)) + "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n", + PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) ); /* detach any '&' anon children in the pad; if afterwards they @@ -243,61 +273,62 @@ Perl_pad_undef(pTHX_ CV* cv) * children, or integrate this loop with general cleanup */ if (!PL_dirty) { /* don't bother during global destruction */ - CV *outercv = CvOUTSIDE(cv); - U32 seq = CvOUTSIDE_SEQ(cv); - AV *comppad_name = (AV*)AvARRAY(padlist)[0]; - SV **namepad = AvARRAY(comppad_name); - AV *comppad = (AV*)AvARRAY(padlist)[1]; - SV **curpad = AvARRAY(comppad); + CV * const outercv = CvOUTSIDE(cv); + const U32 seq = CvOUTSIDE_SEQ(cv); + AV * const comppad_name = (AV*)AvARRAY(padlist)[0]; + SV ** const namepad = AvARRAY(comppad_name); + AV * const comppad = (AV*)AvARRAY(padlist)[1]; + SV ** const curpad = AvARRAY(comppad); for (ix = AvFILLp(comppad_name); ix > 0; ix--) { - SV *namesv = namepad[ix]; + SV * const namesv = namepad[ix]; if (namesv && namesv != &PL_sv_undef - && *SvPVX(namesv) == '&') + && *SvPVX_const(namesv) == '&') { - CV *innercv = (CV*)curpad[ix]; - namepad[ix] = Nullsv; + CV * const innercv = (CV*)curpad[ix]; + U32 inner_rc = SvREFCNT(innercv); + assert(inner_rc); + namepad[ix] = NULL; SvREFCNT_dec(namesv); if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ - curpad[ix] = Nullsv; + curpad[ix] = NULL; SvREFCNT_dec(innercv); + inner_rc--; } - if (SvREFCNT(innercv) /* in use, not just a prototype */ - && CvOUTSIDE(innercv) == cv) - { + + /* in use, not just a prototype */ + if (inner_rc && (CvOUTSIDE(innercv) == cv)) { assert(CvWEAKOUTSIDE(innercv)); /* don't relink to grandfather if he's being freed */ if (outercv && SvREFCNT(outercv)) { CvWEAKOUTSIDE_off(innercv); CvOUTSIDE(innercv) = outercv; CvOUTSIDE_SEQ(innercv) = seq; - SvREFCNT_inc(outercv); + SvREFCNT_inc_simple_void_NN(outercv); } else { - CvOUTSIDE(innercv) = Nullcv; + CvOUTSIDE(innercv) = NULL; } - } - } } } ix = AvFILLp(padlist); while (ix >= 0) { - SV* sv = AvARRAY(padlist)[ix--]; - if (!sv) - continue; - if (sv == (SV*)PL_comppad_name) - PL_comppad_name = Nullav; - else if (sv == (SV*)PL_comppad) { - PL_comppad = Null(PAD*); - PL_curpad = Null(SV**); + const SV* const sv = AvARRAY(padlist)[ix--]; + if (sv) { + if (sv == (SV*)PL_comppad_name) + PL_comppad_name = NULL; + else if (sv == (SV*)PL_comppad) { + PL_comppad = NULL; + PL_curpad = NULL; + } } SvREFCNT_dec(sv); } SvREFCNT_dec((SV*)CvPADLIST(cv)); - CvPADLIST(cv) = Null(PADLIST*); + CvPADLIST(cv) = NULL; } @@ -311,7 +342,7 @@ offset. If C is valid, the name is for a typed lexical; set the name's stash to that value. If C is valid, it's an our lexical, set the name's -GvSTASH to that value +SvOURSTASH to that value If fake, it means we're cloning an existing entry @@ -319,24 +350,31 @@ If fake, it means we're cloning an existing entry */ PADOFFSET -Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake) +Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state) { - PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); - SV* namesv = NEWSV(1102, 0); + dVAR; + const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); + SV* const namesv + = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); - ASSERT_CURPAD_ACTIVE("pad_add_name"); + PERL_ARGS_ASSERT_PAD_ADD_NAME; + ASSERT_CURPAD_ACTIVE("pad_add_name"); - sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV); sv_setpv(namesv, name); if (typestash) { - SvFLAGS(namesv) |= SVpad_TYPED; - SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash); + assert(SvTYPE(namesv) == SVt_PVMG); + SvPAD_TYPED_on(namesv); + SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash)); } if (ourstash) { - SvFLAGS(namesv) |= SVpad_OUR; - GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash); + SvPAD_OUR_on(namesv); + SvOURSTASH_set(namesv, ourstash); + SvREFCNT_inc_simple_void_NN(ourstash); + } + else if (state) { + SvPAD_STATE_on(namesv); } av_store(PL_comppad_name, offset, namesv); @@ -347,8 +385,8 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake) } else { /* not yet introduced */ - SvNVX(namesv) = (NV)PAD_MAX; /* min */ - SvIVX(namesv) = 0; /* max */ + COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ + COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ if (!PL_min_intro_pending) PL_min_intro_pending = offset; @@ -377,21 +415,27 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake) Allocate a new my or tmp pad entry. For a my, simply push a null SV onto the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards -for a slot which has no name and and no active value. +for a slot which has no name and no active value. =cut */ /* XXX DAPM integrate alloc(), add_name() and add_anon(), * or at least rationalise ??? */ - +/* And flag whether the incoming name is UTF8 or 8 bit? + Could do this either with the +ve/-ve hack of the HV code, or expanding + the flag bits. Either way, this makes proper Unicode safe pad support. + NWC +*/ PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { + dVAR; SV *sv; I32 retval; + PERL_UNUSED_ARG(optype); ASSERT_CURPAD_ACTIVE("pad_alloc"); if (AvARRAY(PL_comppad) != PL_curpad) @@ -403,8 +447,8 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) retval = AvFILLp(PL_comppad); } else { - SV **names = AvARRAY(PL_comppad_name); - SSize_t names_fill = AvFILLp(PL_comppad_name); + SV * const * const names = AvARRAY(PL_comppad_name); + const SSize_t names_fill = AvFILLp(PL_comppad_name); for (;;) { /* * "foreach" index vars temporarily become aliases to non-"my" @@ -429,6 +473,10 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, PL_op_name[optype])); +#ifdef DEBUG_LEAKING_SCALARS + sv->sv_debug_optype = optype; + sv->sv_debug_inpad = 1; +#endif return (PADOFFSET)retval; } @@ -443,14 +491,17 @@ Add an anon code entry to the current compiling pad PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) { + dVAR; PADOFFSET ix; - SV* name; + SV* const name = newSV_type(SVt_PVNV); - name = NEWSV(1106, 0); - sv_upgrade(name, SVt_PVNV); + PERL_ARGS_ASSERT_PAD_ADD_ANON; + + pad_peg("add_anon"); sv_setpvn(name, "&", 1); - SvIVX(name) = -1; - SvNVX(name) = 1; + /* Are these two actually ever read? */ + COP_SEQ_RANGE_HIGH_set(name, ~0); + COP_SEQ_RANGE_LOW_set(name, 1); ix = pad_alloc(op_type, SVs_PADMY); av_store(PL_comppad_name, ix, name); /* XXX DAPM use PL_curpad[] ? */ @@ -484,13 +535,16 @@ C indicates that the name to check is an 'our' declaration /* XXX DAPM integrate this into pad_add_name ??? */ void -Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash) +Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) { - SV **svp, *sv; + dVAR; + SV **svp; PADOFFSET top, off; + PERL_ARGS_ASSERT_PAD_CHECK_DUP; + ASSERT_CURPAD_ACTIVE("pad_check_dup"); - if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0) + if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ svp = AvARRAY(PL_comppad_name); @@ -499,19 +553,20 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash) /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same * type ? */ for (off = top; (I32)off > PL_comppad_name_floor; off--) { - if ((sv = svp[off]) + SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) - && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) - && (!is_our - || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)) - && strEQ(name, SvPVX(sv))) + && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) + && strEQ(name, SvPVX_const(sv))) { + if (is_our && (SvPAD_OUR(sv))) + break; /* "our" masking "our" */ Perl_warner(aTHX_ packWARN(WARN_MISC), "\"%s\" variable %s masks earlier declaration in same %s", - (is_our ? "our" : "my"), + (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), name, - (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); + (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement")); --off; break; } @@ -519,17 +574,19 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash) /* check the rest of the pad */ if (is_our) { do { - if ((sv = svp[off]) + SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) - && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) - && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) - && strEQ(name, SvPVX(sv))) + && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) + && SvOURSTASH(sv) == ourstash + && strEQ(name, SvPVX_const(sv))) { Perl_warner(aTHX_ packWARN(WARN_MISC), "\"our\" variable %s redeclared", name); - Perl_warner(aTHX_ packWARN(WARN_MISC), - "\t(Did you mean \"local\" instead of \"our\"?)\n"); + if ((I32)off <= PL_comppad_name_floor) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "\t(Did you mean \"local\" instead of \"our\"?)\n"); break; } } while ( off-- > 0 ); @@ -550,17 +607,21 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure. */ PADOFFSET -Perl_pad_findmy(pTHX_ char *name) +Perl_pad_findmy(pTHX_ const char *name) { + dVAR; SV *out_sv; int out_flags; I32 offset; - AV *nameav; + const AV *nameav; SV **name_svp; - offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, - Null(SV**), &out_sv, &out_flags); - if (offset != NOT_IN_PAD) + PERL_ARGS_ASSERT_PAD_FINDMY; + + pad_peg("pad_findmy"); + offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, + NULL, &out_sv, &out_flags); + if ((PADOFFSET)offset != NOT_IN_PAD) return offset; /* look for an our that's being introduced; this allows @@ -570,12 +631,12 @@ Perl_pad_findmy(pTHX_ char *name) nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0]; name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { - SV *namesv = name_svp[offset]; + const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv) - && (SvFLAGS(namesv) & SVpad_OUR) - && strEQ(SvPVX(namesv), name) - && U_32(SvNVX(namesv)) == PAD_MAX /* min */ + && (SvPAD_OUR(namesv)) + && strEQ(SvPVX_const(namesv), name) + && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */ ) return offset; } @@ -590,10 +651,11 @@ Perl_pad_findmy(pTHX_ char *name) PADOFFSET Perl_find_rundefsvoffset(pTHX) { + dVAR; SV *out_sv; int out_flags; return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1, - Null(SV**), &out_sv, &out_flags); + NULL, &out_sv, &out_flags); } /* @@ -613,17 +675,12 @@ associated with the IVX field of a fake namesv. Note that pad_findlex() is recursive; it recurses up the chain of CVs, then comes back down, adding fake entries as it goes. It has to be this way -because fake namesvs in anon protoypes have to store in NVX the index into +because fake namesvs in anon protoypes have to store in xlow the index into the parent pad. =cut */ -/* Flags set in the SvIVX field of FAKE namesvs */ - -#define PAD_FAKELEX_ANON 1 /* the lex is declared in an ANON, or ... */ -#define PAD_FAKELEX_MULTI 2 /* the lex can be instantiated multiple times */ - /* the CV has finished being compiled. This is not a sufficient test for * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */ #define CvCOMPILED(cv) CvROOT(cv) @@ -633,13 +690,16 @@ the parent pad. STATIC PADOFFSET -S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, +S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags) { + dVAR; I32 offset, new_offset; SV *new_capture; SV **new_capturep; - AV *padlist = CvPADLIST(cv); + const AV * const padlist = CvPADLIST(cv); + + PERL_ARGS_ASSERT_PAD_FINDLEX; *out_flags = 0; @@ -651,18 +711,18 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, if (padlist) { /* not an undef CV */ I32 fake_offset = 0; - AV *nameav = (AV*)AvARRAY(padlist)[0]; - SV **name_svp = AvARRAY(nameav); + const AV * const nameav = (AV*)AvARRAY(padlist)[0]; + SV * const * const name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { - SV *namesv = name_svp[offset]; + const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef - && strEQ(SvPVX(namesv), name)) + && strEQ(SvPVX_const(namesv), name)) { if (SvFAKE(namesv)) fake_offset = offset; /* in case we don't find a real one */ - else if ( seq > U_32(SvNVX(namesv)) /* min */ - && seq <= (U32)SvIVX(namesv)) /* max */ + else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */ + && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */ break; } } @@ -685,18 +745,19 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, ? PAD_FAKELEX_MULTI : 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n", - PTR2UV(cv), (long)offset, (long)U_32(SvNVX(*out_name_sv)), - (long)SvIVX(*out_name_sv))); + "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n", + PTR2UV(cv), (long)offset, + (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv), + (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv))); } else { /* fake match */ offset = fake_offset; *out_name_sv = name_svp[offset]; /* return the namesv */ - *out_flags = SvIVX(*out_name_sv); + *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n", PTR2UV(cv), (long)offset, (unsigned long)*out_flags, - (unsigned long)SvNVX(*out_name_sv) + (unsigned long) PARENT_PAD_INDEX(*out_name_sv) )); } @@ -705,8 +766,8 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, if (out_capture) { /* our ? */ - if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) { - *out_capture = Nullsv; + if (SvPAD_OUR(*out_name_sv)) { + *out_capture = NULL; return offset; } @@ -718,13 +779,14 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, if (warn && ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", name); - *out_capture = Nullsv; + *out_capture = NULL; } /* real value */ else { int newwarn = warn; if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) + && !SvPAD_STATE(name_svp[offset]) && warn && ckWARN(WARN_CLOSURE)) { newwarn = 0; Perl_warner(aTHX_ packWARN(WARN_CLOSURE), @@ -740,7 +802,8 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n", PTR2UV(cv))); n = *out_name_sv; - pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), + (void) pad_findlex(name, CvOUTSIDE(cv), + CvOUTSIDE_SEQ(cv), newwarn, out_capture, out_name_sv, out_flags); *out_name_sv = n; return offset; @@ -752,11 +815,13 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n", PTR2UV(cv), PTR2UV(*out_capture))); - if (SvPADSTALE(*out_capture)) { + if (SvPADSTALE(*out_capture) + && !SvPAD_STATE(name_svp[offset])) + { if (ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%s\" is not available", name); - *out_capture = Nullsv; + *out_capture = NULL; } } if (!*out_capture) { @@ -777,17 +842,17 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, if (!CvOUTSIDE(cv)) return NOT_IN_PAD; - + /* out_capture non-null means caller wants us to capture lex; in * addition we capture ourselves unless it's an ANON/format */ new_capturep = out_capture ? out_capture : - CvLATE(cv) ? Null(SV**) : &new_capture; + CvLATE(cv) ? NULL : &new_capture; offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, new_capturep, out_name_sv, out_flags); - if (offset == NOT_IN_PAD) + if ((PADOFFSET)offset == NOT_IN_PAD) return NOT_IN_PAD; - + /* found in an outer CV. Add appropriate fake entry to this pad */ /* don't add new fake entries (via eval) to CVs that we have already @@ -797,31 +862,31 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, { SV *new_namesv; - AV *ocomppad_name = PL_comppad_name; - PAD *ocomppad = PL_comppad; + AV * const ocomppad_name = PL_comppad_name; + PAD * const ocomppad = PL_comppad; PL_comppad_name = (AV*)AvARRAY(padlist)[0]; PL_comppad = (AV*)AvARRAY(padlist)[1]; PL_curpad = AvARRAY(PL_comppad); new_offset = pad_add_name( - SvPVX(*out_name_sv), - (SvFLAGS(*out_name_sv) & SVpad_TYPED) - ? SvSTASH(*out_name_sv) : Nullhv, - (SvFLAGS(*out_name_sv) & SVpad_OUR) - ? GvSTASH(*out_name_sv) : Nullhv, - 1 /* fake */ + SvPVX_const(*out_name_sv), + SvPAD_TYPED(*out_name_sv) + ? SvSTASH(*out_name_sv) : NULL, + SvOURSTASH(*out_name_sv), + 1, /* fake */ + SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */ ); new_namesv = AvARRAY(PL_comppad_name)[new_offset]; - SvIVX(new_namesv) = *out_flags; + PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); - SvNVX(new_namesv) = (NV)0; - if (SvFLAGS(new_namesv) & SVpad_OUR) { - /* do nothing */ + PARENT_PAD_INDEX_set(new_namesv, 0); + if (SvPAD_OUR(new_namesv)) { + NOOP; /* do nothing */ } else if (CvLATE(cv)) { /* delayed creation - just note the offset within parent pad */ - SvNVX(new_namesv) = (NV)offset; + PARENT_PAD_INDEX_set(new_namesv, offset); CvCLONE_on(cv); } else { @@ -832,16 +897,17 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); } *out_name_sv = new_namesv; - *out_flags = SvIVX(new_namesv); + *out_flags = PARENT_FAKELEX_FLAGS(new_namesv); PL_comppad_name = ocomppad_name; PL_comppad = ocomppad; - PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **); + PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; } return new_offset; } - + +#ifdef DEBUGGING /* =for apidoc pad_sv @@ -855,6 +921,7 @@ Use macro PAD_SV instead of calling this function directly. SV * Perl_pad_sv(pTHX_ PADOFFSET po) { + dVAR; ASSERT_CURPAD_ACTIVE("pad_sv"); if (!po) @@ -876,10 +943,13 @@ Use the macro PAD_SETSV() rather than calling this function directly. =cut */ -#ifdef DEBUGGING void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) { + dVAR; + + PERL_ARGS_ASSERT_PAD_SETSV; + ASSERT_CURPAD_ACTIVE("pad_setsv"); DEBUG_X(PerlIO_printf(Perl_debug_log, @@ -909,6 +979,7 @@ Update the pad compilation state variables on entry to a new block void Perl_pad_block_start(pTHX_ int full) { + dVAR; ASSERT_CURPAD_ACTIVE("pad_block_start"); SAVEI32(PL_comppad_name_floor); PL_comppad_name_floor = AvFILLp(PL_comppad_name); @@ -937,8 +1008,8 @@ Perl_pad_block_start(pTHX_ int full) U32 Perl_intro_my(pTHX) { + dVAR; SV **svp; - SV *sv; I32 i; ASSERT_CURPAD_ACTIVE("intro_my"); @@ -947,15 +1018,16 @@ Perl_intro_my(pTHX) svp = AvARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &PL_sv_undef - && !SvFAKE(sv) && !SvIVX(sv)) - { - SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */ - SvNVX(sv) = (NV)PL_cop_seqmax; + SV * const sv = svp[i]; + + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) { + COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */ + COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: %ld \"%s\", (%ld,%ld)\n", - (long)i, SvPVX(sv), - (long)U_32(SvNVX(sv)), (long)SvIVX(sv)) + "Pad intromy: %ld \"%s\", (%lu,%lu)\n", + (long)i, SvPVX_const(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } @@ -979,31 +1051,33 @@ lexicals in this scope and warn of any lexicals that never got introduced. void Perl_pad_leavemy(pTHX) { + dVAR; I32 off; - SV **svp = AvARRAY(PL_comppad_name); - SV *sv; + SV * const * const svp = AvARRAY(PL_comppad_name); PL_pad_reset_pending = FALSE; ASSERT_CURPAD_ACTIVE("pad_leavemy"); 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--) { - if ((sv = svp[off]) && sv != &PL_sv_undef + const SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "%"SVf" never introduced", sv); + "%"SVf" never introduced", + SVfARG(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef - && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX) - { - SvIVX(sv) = PL_cop_seqmax; + const SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) { + COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: %ld \"%s\", (%ld,%ld)\n", - (long)off, SvPVX(sv), - (long)U_32(SvNVX(sv)), (long)SvIVX(sv)) + "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", + (long)off, SvPVX_const(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } @@ -1025,6 +1099,7 @@ new one. void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) { + dVAR; ASSERT_CURPAD_LEGAL("pad_swipe"); if (!PL_curpad) return; @@ -1042,8 +1117,15 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) if (refadjust) SvREFCNT_dec(PL_curpad[po]); - PL_curpad[po] = NEWSV(1107,0); + + /* if pad tmps aren't shared between ops, then there's no need to + * create a new tmp when an existing op is freed */ +#ifdef USE_BROKEN_PAD_RESET + PL_curpad[po] = newSV(0); SvPADTMP_on(PL_curpad[po]); +#else + PL_curpad[po] = &PL_sv_undef; +#endif if ((I32)po < PL_padix) PL_padix = po - 1; } @@ -1066,9 +1148,8 @@ Mark all the current temporaries for reuse void Perl_pad_reset(pTHX) { + dVAR; #ifdef USE_BROKEN_PAD_RESET - register I32 po; - if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_reset curpad"); @@ -1080,6 +1161,7 @@ Perl_pad_reset(pTHX) ); if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ + register I32 po; for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) SvPADTMP_off(PL_curpad[po]); @@ -1110,8 +1192,7 @@ Tidy up a pad after we've finished compiling it: void Perl_pad_tidy(pTHX_ padtidy_type type) { - PADOFFSET ix; - CV *cv; + dVAR; ASSERT_CURPAD_ACTIVE("pad_tidy"); @@ -1125,6 +1206,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) */ if (PL_cv_has_eval || PL_perldb) { + const CV *cv; for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { if (cv != PL_compcv && CvCOMPILED(cv)) break; /* no need to mark already-compiled code */ @@ -1138,10 +1220,11 @@ Perl_pad_tidy(pTHX_ padtidy_type type) /* extend curpad to match namepad */ if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) - av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); + av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); if (type == padtidy_SUBCLONE) { - SV **namep = AvARRAY(PL_comppad_name); + SV * const * const namep = AvARRAY(PL_comppad_name); + PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { SV *namesv; @@ -1153,26 +1236,27 @@ Perl_pad_tidy(pTHX_ padtidy_type type) * pad are anonymous subs. * The rest are created anew during cloning. */ - if (!((namesv = namep[ix]) != Nullsv && + if (!((namesv = namep[ix]) != NULL && namesv != &PL_sv_undef && - *SvPVX(namesv) == '&')) + *SvPVX_const(namesv) == '&')) { SvREFCNT_dec(PL_curpad[ix]); - PL_curpad[ix] = Nullsv; + PL_curpad[ix] = NULL; } } } else if (type == padtidy_SUB) { /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */ - AV *av = newAV(); /* Will be @_ */ + AV * const av = newAV(); /* Will be @_ */ av_extend(av, 0); av_store(PL_comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; + AvREIFY_only(av); } /* XXX DAPM rationalise these two similar branches */ if (type == padtidy_SUB) { + 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])) continue; @@ -1181,6 +1265,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) } } else if (type == padtidy_FORMAT) { + PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) SvPADTMP_on(PL_curpad[ix]); @@ -1193,7 +1278,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) /* =for apidoc pad_free -Free the SV at offet po in the current pad. +Free the SV at offset po in the current pad. =cut */ @@ -1202,6 +1287,7 @@ Free the SV at offet po in the current pad. void Perl_pad_free(pTHX_ PADOFFSET po) { + dVAR; ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) return; @@ -1220,7 +1306,7 @@ Perl_pad_free(pTHX_ PADOFFSET po) #ifdef USE_ITHREADS /* SV could be a shared hash key (eg bugid #19022) */ if ( -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE !SvIsCOW(PL_curpad[po]) #else !SvFAKE(PL_curpad[po]) @@ -1246,13 +1332,15 @@ Dump the contents of a padlist void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) { - AV *pad_name; - AV *pad; + dVAR; + const AV *pad_name; + const AV *pad; SV **pname; SV **ppad; - SV *namesv; I32 ix; + PERL_ARGS_ASSERT_DO_DUMP_PAD; + if (!padlist) { return; } @@ -1266,9 +1354,9 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) ); for (ix = 1; ix <= AvFILLp(pad_name); ix++) { - namesv = pname[ix]; + const SV *namesv = pname[ix]; if (namesv && namesv == &PL_sv_undef) { - namesv = Nullsv; + namesv = NULL; } if (namesv) { if (SvFAKE(namesv)) @@ -1277,20 +1365,20 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - SvPVX(namesv), - (unsigned long)SvIVX(namesv), - (unsigned long)SvNVX(namesv) + SvPVX_const(namesv), + (unsigned long)PARENT_FAKELEX_FLAGS(namesv), + (unsigned long)PARENT_PAD_INDEX(namesv) ); else Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n", + "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n", (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - (long)U_32(SvNVX(namesv)), - (long)SvIVX(namesv), - SvPVX(namesv) + (unsigned long)COP_SEQ_RANGE_LOW(namesv), + (unsigned long)COP_SEQ_RANGE_HIGH(namesv), + SvPVX_const(namesv) ); } else if (full) { @@ -1316,10 +1404,13 @@ dump the contents of a CV #ifdef DEBUGGING STATIC void -S_cv_dump(pTHX_ CV *cv, char *title) +S_cv_dump(pTHX_ const CV *cv, const char *title) { - CV *outside = CvOUTSIDE(cv); - AV* padlist = CvPADLIST(cv); + dVAR; + const CV * const outside = CvOUTSIDE(cv); + AV* const padlist = CvPADLIST(cv); + + PERL_ARGS_ASSERT_CV_DUMP; PerlIO_printf(Perl_debug_log, " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n", @@ -1360,20 +1451,22 @@ any outer lexicals. CV * Perl_cv_clone(pTHX_ CV *proto) { + dVAR; I32 ix; - AV* protopadlist = CvPADLIST(proto); - AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); - AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); - SV** pname = AvARRAY(protopad_name); - SV** ppad = AvARRAY(protopad); - I32 fname = AvFILLp(protopad_name); - I32 fpad = AvFILLp(protopad); - AV* comppadlist; + AV* const protopadlist = CvPADLIST(proto); + const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); + const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); + SV** const pname = AvARRAY(protopad_name); + SV** const ppad = AvARRAY(protopad); + const I32 fname = AvFILLp(protopad_name); + const I32 fpad = AvFILLp(protopad); CV* cv; SV** outpad; CV* outside; long depth; + PERL_ARGS_ASSERT_CV_CLONE; + assert(!CvUNIQUE(proto)); /* Since cloneable anon subs can be nested, CvOUTSIDE may point @@ -1392,28 +1485,29 @@ Perl_cv_clone(pTHX_ CV *proto) ENTER; SAVESPTR(PL_compcv); - cv = PL_compcv = (CV*)NEWSV(1104, 0); - sv_upgrade((SV *)cv, SvTYPE(proto)); + cv = PL_compcv = (CV*)newSV_type(SvTYPE(proto)); CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE); CvCLONED_on(cv); #ifdef USE_ITHREADS - CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto) - : savepv(CvFILE(proto)); + CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) + : savepv(CvFILE(proto)); #else CvFILE(cv) = CvFILE(proto); #endif CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); + OP_REFCNT_LOCK; CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); + OP_REFCNT_UNLOCK; CvSTART(cv) = CvSTART(proto); - CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); + CvOUTSIDE(cv) = (CV*)SvREFCNT_inc_simple(outside); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) - sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto)); + sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto)); - CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE); + CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); av_fill(PL_comppad, fpad); for (ix = fname; ix >= 0; ix--) @@ -1424,42 +1518,45 @@ Perl_cv_clone(pTHX_ CV *proto) outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]); for (ix = fpad; ix > 0; ix--) { - SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; - SV *sv = Nullsv; + SV* const namesv = (ix <= fname) ? pname[ix] : NULL; + SV *sv = NULL; if (namesv && namesv != &PL_sv_undef) { /* lexical */ if (SvFAKE(namesv)) { /* lexical from outside? */ - sv = outpad[(I32)SvNVX(namesv)]; + sv = outpad[PARENT_PAD_INDEX(namesv)]; assert(sv); - /* formats may have an inactive parent */ - if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) { + /* formats may have an inactive parent, + while my $x if $false can leave an active var marked as + stale. And state vars are always available */ + if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) { if (ckWARN(WARN_CLOSURE)) Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", SvPVX(namesv)); - sv = Nullsv; - } - else { - assert(!SvPADSTALE(sv)); - sv = SvREFCNT_inc(sv); + "Variable \"%s\" is not available", SvPVX_const(namesv)); + sv = NULL; } + else + SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { - char *name = SvPVX(namesv); - if (*name == '&') + const char sigil = SvPVX_const(namesv)[0]; + if (sigil == '&') sv = SvREFCNT_inc(ppad[ix]); - else if (*name == '@') + else if (sigil == '@') sv = (SV*)newAV(); - else if (*name == '%') + else if (sigil == '%') sv = (SV*)newHV(); else - sv = NEWSV(0, 0); + sv = newSV(0); SvPADMY_on(sv); + /* reset the 'assign only once' flag on each state var */ + if (SvPAD_STATE(namesv)) + SvPADSTALE_on(sv); } } else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { - sv = SvREFCNT_inc(ppad[ix]); + sv = SvREFCNT_inc_NN(ppad[ix]); } else { - sv = NEWSV(0, 0); + sv = newSV(0); SvPADTMP_on(sv); } PL_curpad[ix] = sv; @@ -1480,10 +1577,10 @@ Perl_cv_clone(pTHX_ CV *proto) * so try to grab the current const value, and if successful, * turn into a const sub: */ - SV* const_sv = op_const_sv(CvSTART(cv), cv); + SV* const const_sv = op_const_sv(CvSTART(cv), cv); if (const_sv) { SvREFCNT_dec(cv); - cv = newCONSTSUB(CvSTASH(proto), 0, const_sv); + cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); } else { CvCONST_off(cv); @@ -1507,17 +1604,22 @@ moved to a pre-existing CV struct. void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) { + dVAR; I32 ix; - AV *comppad_name = (AV*)AvARRAY(padlist)[0]; - AV *comppad = (AV*)AvARRAY(padlist)[1]; - SV **namepad = AvARRAY(comppad_name); - SV **curpad = AvARRAY(comppad); + AV * const comppad_name = (AV*)AvARRAY(padlist)[0]; + AV * const comppad = (AV*)AvARRAY(padlist)[1]; + SV ** const namepad = AvARRAY(comppad_name); + SV ** const curpad = AvARRAY(comppad); + + PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS; + PERL_UNUSED_ARG(old_cv); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { - SV *namesv = namepad[ix]; + const SV * const namesv = namepad[ix]; if (namesv && namesv != &PL_sv_undef - && *SvPVX(namesv) == '&') + && *SvPVX_const(namesv) == '&') { - CV *innercv = (CV*)curpad[ix]; + CV * const innercv = (CV*)curpad[ix]; assert(CvWEAKOUTSIDE(innercv)); assert(CvOUTSIDE(innercv) == old_cv); CvOUTSIDE(innercv) = new_cv; @@ -1530,62 +1632,88 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) =for apidoc pad_push Push a new pad frame onto the padlist, unless there's already a pad at -this depth, in which case don't bother creating a new one. -If has_args is true, give the new pad an @_ in slot zero. +this depth, in which case don't bother creating a new one. Then give +the new pad an @_ in slot zero. =cut */ -/* XXX pad_push is now always called with has_args == 1. Get rid of - * this arg at some point */ - void -Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args) +Perl_pad_push(pTHX_ PADLIST *padlist, int depth) { - if (depth <= AvFILLp(padlist)) - return; + dVAR; - { - SV** svp = AvARRAY(padlist); - AV *newpad = newAV(); - SV **oldpad = AvARRAY(svp[depth-1]); + PERL_ARGS_ASSERT_PAD_PUSH; + + if (depth > AvFILLp(padlist)) { + SV** const svp = AvARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); I32 ix = AvFILLp((AV*)svp[1]); - I32 names_fill = AvFILLp((AV*)svp[0]); - SV** names = AvARRAY(svp[0]); - SV* sv; + const I32 names_fill = AvFILLp((AV*)svp[0]); + SV** const names = AvARRAY(svp[0]); + AV *av; + for ( ;ix > 0; ix--) { if (names_fill >= ix && names[ix] != &PL_sv_undef) { - char *name = SvPVX(names[ix]); - if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') { + const char sigil = SvPVX_const(names[ix])[0]; + if ((SvFLAGS(names[ix]) & SVf_FAKE) + || (SvFLAGS(names[ix]) & SVpad_STATE) + || sigil == '&') + { /* outer lexical or anon code */ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); } else { /* our own lexical */ - if (*name == '@') - av_store(newpad, ix, sv = (SV*)newAV()); - else if (*name == '%') - av_store(newpad, ix, sv = (SV*)newHV()); + SV *sv; + if (sigil == '@') + sv = (SV*)newAV(); + else if (sigil == '%') + sv = (SV*)newHV(); else - av_store(newpad, ix, sv = NEWSV(0, 0)); + sv = newSV(0); + av_store(newpad, ix, sv); SvPADMY_on(sv); } } else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { - av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); + av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); } else { /* save temporaries on recursion? */ - av_store(newpad, ix, sv = NEWSV(0, 0)); + SV * const sv = newSV(0); + av_store(newpad, ix, sv); SvPADTMP_on(sv); } } - if (has_args) { - AV* av = newAV(); - av_extend(av, 0); - av_store(newpad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - } + av = newAV(); + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvREIFY_only(av); + av_store(padlist, depth, (SV*)newpad); AvFILLp(padlist) = depth; } } + + +HV * +Perl_pad_compname_type(pTHX_ const PADOFFSET po) +{ + dVAR; + SV* const * const av = av_fetch(PL_comppad_name, po, FALSE); + if ( SvPAD_TYPED(*av) ) { + return SvSTASH(*av); + } + return NULL; +} + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */