X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4608196e45589eea5792cff92b551109899ddb06..c111d5f1ab8852c556adefbb6b416fd22274677c:/pad.c diff --git a/pad.c b/pad.c index aa806ea..ff52eb8 100644 --- a/pad.c +++ b/pad.c @@ -1,16 +1,21 @@ /* pad.c * - * Copyright (C) 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + * 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. + */ + +/* + * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you + * might say, among those queer Bucklanders, being brought up anyhow in + * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc + * never had fewer than a couple of hundred relations in the place. + * Mr. Bilbo never did a kinder deed than when he brought the lad back + * to live among decent folk.' --the Gaffer * - * "Anyway: there was this Mr Frodo left an orphan and stranded, as you - * might say, among those queer Bucklanders, being brought up anyhow in - * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc - * never had fewer than a couple of hundred relations in the place. Mr - * Bilbo never did a kinder deed than when he brought the lad back to - * live among decent folk." --the Gaffer + * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* XXX DAPM @@ -72,19 +77,29 @@ 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 declarations 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 (accessed through the macros COP_SEQ_RANGE_LOW and +_HIGH). During compilation, these fields may hold the special value +PERL_PADSEQ_INTRO to indicate various stages: + + COP_SEQ_RANGE_LOW _HIGH + ----------------- ----- + PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x + valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x) + valid-seq# valid-seq# compilation of scope complete: { my ($x) } + +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. @@ -96,12 +111,14 @@ become so if C is implemented.) Note that formats are treated as anon subs, and are cloned each time write is called (if necessary). -The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed, +The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed, and set on scope exit. This allows the 'Variable $x is not available' warning to be generated in evals, such as { my $x = 1; sub f { eval '$x'} } f(); +For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised' + =cut */ @@ -109,11 +126,28 @@ 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 +#ifdef PERL_MAD +void pad_peg(const char* s) { + static int pegcnt; /* XXX not threadsafe */ + PERL_UNUSED_ARG(s); + PERL_ARGS_ASSERT_PAD_PEG; + pegcnt++; +} +#endif /* =for apidoc pad_new @@ -134,6 +168,7 @@ Perl_pad_new(pTHX_ int flags) { dVAR; AV *padlist, *padname, *pad; + SV **ary; ASSERT_CURPAD_LEGAL("pad_new"); @@ -153,9 +188,9 @@ 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); + SAVEBOOL(PL_pad_reset_pending); } } } @@ -175,8 +210,7 @@ Perl_pad_new(pTHX_ int flags) */ AV * const a0 = newAV(); /* will be @_ */ - av_extend(a0, 0); - av_store(pad, 0, (SV*)a0); + av_store(pad, 0, MUTABLE_SV(a0)); AvREIFY_only(a0); } else { @@ -184,14 +218,23 @@ Perl_pad_new(pTHX_ int flags) } AvREAL_off(padlist); - av_store(padlist, 0, (SV*)padname); - av_store(padlist, 1, (SV*)pad); + /* Most subroutines never recurse, hence only need 2 entries in the padlist + array - names, and depth=1. The default for av_store() is to allocate + 0..3, and even an explicit call to av_extend() with <3 will be rounded + up, so we inline the allocation of the array here. */ + Newx(ary, 2, SV*); + AvFILLp(padlist) = 1; + AvMAX(padlist) = 1; + AvALLOC(padlist) = ary; + AvARRAY(padlist) = ary; + ary[0] = MUTABLE_SV(padname); + ary[1] = MUTABLE_SV(pad); /* ... then update state variables */ - PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE)); - PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE)); - PL_curpad = AvARRAY(PL_comppad); + PL_comppad_name = padname; + PL_comppad = pad; + PL_curpad = AvARRAY(pad); if (! (flags & padnew_CLONE)) { PL_comppad_name_fill = 0; @@ -211,107 +254,190 @@ Perl_pad_new(pTHX_ int flags) return (PADLIST*)padlist; } + /* -=for apidoc pad_undef +=head1 Embedding Functions -Free the padlist associated with a CV. -If parts of it happen to be current, we null the relevant -PL_*pad* global vars so that we don't have any dangling references left. -We also repoint the CvOUTSIDE of any about-to-be-orphaned -inner subs to the outer of this cv. +=for apidoc cv_undef -(This function should really be called pad_free, but the name was already -taken) +Clear out all the active components of a CV. This can happen either +by an explicit C, or by the reference count going to zero. +In the former case, we keep the CvOUTSIDE pointer, so that any anonymous +children can still follow the full lexical scope chain. =cut */ void -Perl_pad_undef(pTHX_ CV* cv) +Perl_cv_undef(pTHX_ CV *cv) { dVAR; - I32 ix; - const PADLIST * const padlist = CvPADLIST(cv); + const PADLIST *padlist = CvPADLIST(cv); - if (!padlist) - return; - if (SvIS_FREED(padlist)) /* may be during global destruction */ - return; + PERL_ARGS_ASSERT_CV_UNDEF; DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n", - PTR2UV(cv), PTR2UV(padlist)) + "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n", + PTR2UV(cv), PTR2UV(PL_comppad)) ); - /* detach any '&' anon children in the pad; if afterwards they - * are still live, fix up their CvOUTSIDEs to point to our outside, - * bypassing us. */ - /* XXX DAPM for efficiency, we should only do this if we know we have - * children, or integrate this loop with general cleanup */ - - if (!PL_dirty) { /* don't bother during global destruction */ - 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 * const namesv = namepad[ix]; - if (namesv && namesv != &PL_sv_undef - && *SvPVX_const(namesv) == '&') - { - 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] = NULL; - SvREFCNT_dec(innercv); - inner_rc--; - } - if (inner_rc /* in use, not just a prototype */ - && 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; - (void)SvREFCNT_inc(outercv); - } - else { - CvOUTSIDE(innercv) = NULL; +#ifdef USE_ITHREADS + if (CvFILE(cv) && !CvISXSUB(cv)) { + /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + Safefree(CvFILE(cv)); + } + CvFILE(cv) = NULL; +#endif + + if (!CvISXSUB(cv) && CvROOT(cv)) { + if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) + Perl_croak(aTHX_ "Can't undef active subroutine"); + ENTER; + + PAD_SAVE_SETNULLPAD(); + + op_free(CvROOT(cv)); + CvROOT(cv) = NULL; + CvSTART(cv) = NULL; + LEAVE; + } + SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ + CvGV_set(cv, NULL); + + /* This statement and the subsequence if block was pad_undef(). */ + pad_peg("pad_undef"); + + if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */ + ) { + I32 ix; + + /* Free the padlist associated with a CV. + If parts of it happen to be current, we null the relevant PL_*pad* + global vars so that we don't have any dangling references left. + We also repoint the CvOUTSIDE of any about-to-be-orphaned inner + subs to the outer of this cv. */ + + DEBUG_X(PerlIO_printf(Perl_debug_log, + "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 + * are still live, fix up their CvOUTSIDEs to point to our outside, + * bypassing us. */ + /* XXX DAPM for efficiency, we should only do this if we know we have + * children, or integrate this loop with general cleanup */ + + if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ + CV * const outercv = CvOUTSIDE(cv); + const U32 seq = CvOUTSIDE_SEQ(cv); + AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); + SV ** const namepad = AvARRAY(comppad_name); + AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]); + SV ** const curpad = AvARRAY(comppad); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { + SV * const namesv = namepad[ix]; + if (namesv && namesv != &PL_sv_undef + && *SvPVX_const(namesv) == '&') + { + CV * const innercv = MUTABLE_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] = NULL; + SvREFCNT_dec(innercv); + inner_rc--; + } + + /* 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_simple_void_NN(outercv); + } + else { + CvOUTSIDE(innercv) = NULL; + } + } } + } + } + ix = AvFILLp(padlist); + while (ix > 0) { + SV* const sv = AvARRAY(padlist)[ix--]; + if (sv) { + if (sv == (const SV *)PL_comppad) { + PL_comppad = NULL; + PL_curpad = NULL; } - + SvREFCNT_dec(sv); } } + { + SV *const sv = AvARRAY(padlist)[0]; + if (sv == (const SV *)PL_comppad_name) + PL_comppad_name = NULL; + SvREFCNT_dec(sv); + } + SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv))); + CvPADLIST(cv) = NULL; } - ix = AvFILLp(padlist); - while (ix >= 0) { - SV* const sv = AvARRAY(padlist)[ix--]; - if (!sv) - continue; - if (sv == (SV*)PL_comppad_name) - PL_comppad_name = NULL; - else if (sv == (SV*)PL_comppad) { - PL_comppad = Null(PAD*); - PL_curpad = Null(SV**); - } - SvREFCNT_dec(sv); + + /* remove CvOUTSIDE unless this is an undef rather than a free */ + if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = NULL; + } + if (CvCONST(cv)) { + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); + CvCONST_off(cv); + } + if (CvISXSUB(cv) && CvXSUB(cv)) { + CvXSUB(cv) = NULL; } - SvREFCNT_dec((SV*)CvPADLIST(cv)); - CvPADLIST(cv) = NULL; + /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the + * ref status of CvOUTSIDE and CvGV */ + CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC); } +static PADOFFSET +S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, + HV *ourstash) +{ + dVAR; + const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); + + PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; + + ASSERT_CURPAD_ACTIVE("pad_add_name"); + if (typestash) { + assert(SvTYPE(namesv) == SVt_PVMG); + SvPAD_TYPED_on(namesv); + SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); + } + if (ourstash) { + SvPAD_OUR_on(namesv); + SvOURSTASH_set(namesv, ourstash); + SvREFCNT_inc_simple_void_NN(ourstash); + } + else if (flags & padadd_STATE) { + SvPAD_STATE_on(namesv); + } + av_store(PL_comppad_name, offset, namesv); + return offset; +} /* =for apidoc pad_add_name @@ -321,7 +447,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 @@ -329,54 +455,53 @@ If fake, it means we're cloning an existing entry */ PADOFFSET -Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake) +Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, + HV *typestash, HV *ourstash) { dVAR; - const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); - SV* const namesv = newSV(0); + PADOFFSET offset; + SV *namesv; - ASSERT_CURPAD_ACTIVE("pad_add_name"); + PERL_ARGS_ASSERT_PAD_ADD_NAME; + + if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) + Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, + (UV)flags); + + namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + /* Until we're using the length for real, cross check that we're being told + the truth. */ + PERL_UNUSED_ARG(len); + assert(strlen(name) == len); - sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV); sv_setpv(namesv, name); - if (typestash) { - SvFLAGS(namesv) |= SVpad_TYPED; - SvSTASH_set(namesv, (HV*)SvREFCNT_inc((SV*) typestash)); - } - if (ourstash) { - SvFLAGS(namesv) |= SVpad_OUR; - GvSTASH(namesv) = ourstash; - Perl_sv_add_backref(aTHX_ (SV*)ourstash, namesv); + if ((flags & padadd_NO_DUP_CHECK) == 0) { + /* check for duplicate declaration */ + pad_check_dup(namesv, flags & padadd_OUR, ourstash); } - av_store(PL_comppad_name, offset, namesv); - if (fake) { - SvFAKE_on(namesv); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name)); - } - else { - /* not yet introduced */ - SvNV_set(namesv, (NV)PAD_MAX); /* min */ - SvIV_set(namesv, 0); /* max */ - - if (!PL_min_intro_pending) - PL_min_intro_pending = offset; - PL_max_intro_pending = offset; - /* if it's not a simple scalar, replace with an AV or HV */ - /* XXX DAPM since slot has been allocated, replace - * av_store with PL_curpad[offset] ? */ - if (*name == '@') - av_store(PL_comppad, offset, (SV*)newAV()); - else if (*name == '%') - av_store(PL_comppad, offset, (SV*)newHV()); - SvPADMY_on(PL_curpad[offset]); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", - (long)offset, name, PTR2UV(PL_curpad[offset]))); - } + offset = pad_add_name_sv(namesv, flags, typestash, ourstash); + + /* not yet introduced */ + COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); + COP_SEQ_RANGE_HIGH_set(namesv, 0); + + if (!PL_min_intro_pending) + PL_min_intro_pending = offset; + PL_max_intro_pending = offset; + /* if it's not a simple scalar, replace with an AV or HV */ + assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); + assert(SvREFCNT(PL_curpad[offset]) == 1); + if (*name == '@') + sv_upgrade(PL_curpad[offset], SVt_PVAV); + else if (*name == '%') + sv_upgrade(PL_curpad[offset], SVt_PVHV); + assert(SvPADMY(PL_curpad[offset])); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", + (long)offset, name, PTR2UV(PL_curpad[offset]))); return offset; } @@ -399,8 +524,6 @@ for a slot which has no name and no active value. /* 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. - Also could change the sv structure to make the NV a union with 2 U32s, - so that SvCUR() could stop being overloaded in pad SVs. NWC */ @@ -469,11 +592,16 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) { dVAR; PADOFFSET ix; - SV* const name = newSV(0); - sv_upgrade(name, SVt_PVNV); - sv_setpvn(name, "&", 1); - SvIV_set(name, -1); - SvNV_set(name, 1); + SV* const name = newSV_type(SVt_PVNV); + + PERL_ARGS_ASSERT_PAD_ADD_ANON; + + pad_peg("add_anon"); + sv_setpvs(name, "&"); + /* These two aren't used; just make sure they're not equal to + * PERL_PADSEQ_INTRO */ + COP_SEQ_RANGE_LOW_set(name, 0); + COP_SEQ_RANGE_HIGH_set(name, 0); ix = pad_alloc(op_type, SVs_PADMY); av_store(PL_comppad_name, ix, name); /* XXX DAPM use PL_curpad[] ? */ @@ -482,10 +610,10 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) /* to avoid ref loops, we never have parent + child referencing each * other simultaneously */ - if (CvOUTSIDE((CV*)sv)) { - assert(!CvWEAKOUTSIDE((CV*)sv)); - CvWEAKOUTSIDE_on((CV*)sv); - SvREFCNT_dec(CvOUTSIDE((CV*)sv)); + if (CvOUTSIDE((const CV *)sv)) { + assert(!CvWEAKOUTSIDE((const CV *)sv)); + CvWEAKOUTSIDE_on(MUTABLE_CV(sv)); + SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv))); } return ix; } @@ -504,16 +632,20 @@ C indicates that the name to check is an 'our' declaration =cut */ -/* XXX DAPM integrate this into pad_add_name ??? */ - -void -Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) +STATIC void +S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash) { dVAR; SV **svp; PADOFFSET top, off; + const U32 is_our = flags & padadd_OUR; + + PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); + + assert((flags & ~padadd_OUR) == 0); + if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ @@ -527,39 +659,43 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) if (sv && sv != &PL_sv_undef && !SvFAKE(sv) - && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) - && strEQ(name, SvPVX_const(sv))) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && sv_eq(name, sv)) { - if (is_our && (SvFLAGS(sv) & SVpad_OUR)) + 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"), - name, - (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); + "\"%s\" variable %"SVf" masks earlier declaration in same %s", + (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), + sv, + (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO + ? "scope" : "statement")); --off; break; } } /* check the rest of the pad */ if (is_our) { - do { + while (off > 0) { 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_const(sv))) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && SvOURSTASH(sv) == ourstash + && sv_eq(name, sv)) { Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"our\" variable %s redeclared", name); + "\"our\" variable %"SVf" redeclared", sv); 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 ); + --off; + } } } @@ -577,7 +713,7 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure. */ PADOFFSET -Perl_pad_findmy(pTHX_ const char *name) +Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) { dVAR; SV *out_sv; @@ -586,24 +722,43 @@ Perl_pad_findmy(pTHX_ const char *name) const AV *nameav; SV **name_svp; - offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, + PERL_ARGS_ASSERT_PAD_FINDMY; + + pad_peg("pad_findmy"); + + if (flags) + Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Yes, it is a bug (read work in progress) that we're not really using this + length parameter, and instead relying on strlen() later on. But I'm not + comfortable about changing the pad API piecemeal to use and rely on + lengths. This only exists to avoid an "unused parameter" warning. */ + if (len < 2) + return NOT_IN_PAD; + + /* But until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + + offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); - if (offset != NOT_IN_PAD) + if ((PADOFFSET)offset != NOT_IN_PAD) return offset; /* look for an our that's being introduced; this allows * our $foo = 0 unless defined $foo; * to not give a warning. (Yes, this is a hack) */ - nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0]; + nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]); name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv) - && (SvFLAGS(namesv) & SVpad_OUR) + && (SvPAD_OUR(namesv)) && strEQ(SvPVX_const(namesv), name) - && U_32(SvNVX(namesv)) == PAD_MAX /* min */ + && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO ) return offset; } @@ -626,6 +781,28 @@ Perl_find_rundefsvoffset(pTHX) } /* + * Returns a lexical $_, if there is one, at run time ; or the global one + * otherwise. + */ + +SV * +Perl_find_rundefsv(pTHX) +{ + SV *namesv; + int flags; + PADOFFSET po; + + po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1, + NULL, &namesv, &flags); + + if (po == NOT_IN_PAD + || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR)) + return DEFSV; + + return PAD_SVl(po); +} + +/* =for apidoc pad_findlex Find a named lexical anywhere in a chain of nested pads. Add fake entries @@ -642,17 +819,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) @@ -671,6 +843,8 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, SV **new_capturep; const AV * const padlist = CvPADLIST(cv); + PERL_ARGS_ASSERT_PAD_FINDLEX; + *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, @@ -681,7 +855,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, if (padlist) { /* not an undef CV */ I32 fake_offset = 0; - const AV * const nameav = (AV*)AvARRAY(padlist)[0]; + const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]); SV * const * const name_svp = AvARRAY(nameav); for (offset = AvFILLp(nameav); offset > 0; offset--) { @@ -689,11 +863,35 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, if (namesv && namesv != &PL_sv_undef && strEQ(SvPVX_const(namesv), name)) { - if (SvFAKE(namesv)) + 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 */ - break; + continue; + } + /* is seq within the range _LOW to _HIGH ? + * This is complicated by the fact that PL_cop_seqmax + * may have wrapped around at some point */ + if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO) + continue; /* not yet introduced */ + + if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) { + /* in compiling scope */ + if ( + (seq > COP_SEQ_RANGE_LOW(namesv)) + ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1)) + : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1)) + ) + break; + } + else if ( + (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv)) + ? + ( seq > COP_SEQ_RANGE_LOW(namesv) + || seq <= COP_SEQ_RANGE_HIGH(namesv)) + + : ( seq > COP_SEQ_RANGE_LOW(namesv) + && seq <= COP_SEQ_RANGE_HIGH(namesv)) + ) + break; } } @@ -706,7 +904,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, * instances. For now, we just test !CvUNIQUE(cv), but * ideally, we should detect my's declared within loops * etc - this would allow a wider range of 'not stayed - * shared' warnings. We also treated alreadly-compiled + * shared' warnings. We also treated already-compiled * lexes as not multi as viewed from evals. */ *out_flags = CvANON(cv) ? @@ -715,18 +913,19 @@ S_pad_findlex(pTHX_ const char *name, const 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) )); } @@ -735,7 +934,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, if (out_capture) { /* our ? */ - if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) { + if (SvPAD_OUR(*out_name_sv)) { *out_capture = NULL; return offset; } @@ -745,9 +944,9 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) : *out_flags & PAD_FAKELEX_ANON) { - if (warn && ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + if (warn) + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } @@ -755,6 +954,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, 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), @@ -777,24 +977,25 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, return offset; } - *out_capture = AvARRAY((AV*)AvARRAY(padlist)[ - CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; + *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[ + CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset]; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n", PTR2UV(cv), PTR2UV(*out_capture))); - if (SvPADSTALE(*out_capture)) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + if (SvPADSTALE(*out_capture) + && !SvPAD_STATE(name_svp[offset])) + { + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } } if (!*out_capture) { if (*name == '@') - *out_capture = sv_2mortal((SV*)newAV()); + *out_capture = sv_2mortal(MUTABLE_SV(newAV())); else if (*name == '%') - *out_capture = sv_2mortal((SV*)newHV()); + *out_capture = sv_2mortal(MUTABLE_SV(newHV())); else *out_capture = sv_newmortal(); } @@ -808,7 +1009,7 @@ S_pad_findlex(pTHX_ const char *name, const 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 : @@ -816,9 +1017,9 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, 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 @@ -827,32 +1028,39 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, return 0; /* this dummy (and invalid) value isnt used by the caller */ { - SV *new_namesv; + /* This relies on sv_setsv_flags() upgrading the destination to the same + type as the source, independent of the flags set, and on it being + "good" and only copying flag bits and pointers that it understands. + */ + SV *new_namesv = newSVsv(*out_name_sv); 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_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); + PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]); PL_curpad = AvARRAY(PL_comppad); - new_offset = pad_add_name( - SvPVX_const(*out_name_sv), - (SvFLAGS(*out_name_sv) & SVpad_TYPED) - ? SvSTASH(*out_name_sv) : NULL, - (SvFLAGS(*out_name_sv) & SVpad_OUR) - ? GvSTASH(*out_name_sv) : NULL, - 1 /* fake */ - ); - - new_namesv = AvARRAY(PL_comppad_name)[new_offset]; - SvIV_set(new_namesv, *out_flags); - - SvNV_set(new_namesv, (NV)0); - if (SvFLAGS(new_namesv) & SVpad_OUR) { - /*EMPTY*/; /* do nothing */ + new_offset + = pad_add_name_sv(new_namesv, + (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0), + SvPAD_TYPED(*out_name_sv) + ? SvSTASH(*out_name_sv) : NULL, + SvOURSTASH(*out_name_sv) + ); + + SvFAKE_on(new_namesv); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%.*s\" FAKE\n", + (long)new_offset, + (int) SvCUR(new_namesv), SvPVX(new_namesv))); + PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); + + 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 */ - SvNV_set(new_namesv, (NV)offset); + PARENT_PAD_INDEX_set(new_namesv, offset); CvCLONE_on(cv); } else { @@ -863,7 +1071,7 @@ S_pad_findlex(pTHX_ const char *name, const 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; @@ -913,6 +1121,9 @@ 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, @@ -974,6 +1185,7 @@ Perl_intro_my(pTHX) dVAR; SV **svp; I32 i; + U32 seq; ASSERT_CURPAD_ACTIVE("intro_my"); if (! PL_min_intro_pending) @@ -983,22 +1195,29 @@ 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) && !SvIVX(sv)) { - SvIV_set(sv, PAD_MAX); /* Don't know scope end yet. */ - SvNV_set(sv, (NV)PL_cop_seqmax); + if (sv && sv != &PL_sv_undef && !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. */ + COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: %ld \"%s\", (%ld,%ld)\n", + "Pad intromy: %ld \"%s\", (%lu,%lu)\n", (long)i, SvPVX_const(sv), - (long)U_32(SvNVX(sv)), (long)SvIVX(sv)) + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } + seq = PL_cop_seqmax; + PL_cop_seqmax++; + if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ + PL_cop_seqmax++; PL_min_intro_pending = 0; PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1))); + "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); - return PL_cop_seqmax++; + return seq; } /* @@ -1023,25 +1242,30 @@ 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) && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "%"SVf" never introduced", sv); + if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "%"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--) { const SV * const sv = svp[off]; - if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX) { - SvIV_set(sv, PL_cop_seqmax); + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) + && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: %ld \"%s\", (%ld,%ld)\n", + "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", (long)off, SvPVX_const(sv), - (long)U_32(SvNVX(sv)), (long)SvIVX(sv)) + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } PL_cop_seqmax++; + if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ + PL_cop_seqmax++; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); } @@ -1105,8 +1329,8 @@ Mark all the current temporaries for reuse * to a shared TARG. Such an alias will change randomly and unpredictably. * We avoid doing this until we can think of a Better Way. * GSAR 97-10-29 */ -void -Perl_pad_reset(pTHX) +static void +S_pad_reset(pTHX) { dVAR; #ifdef USE_BROKEN_PAD_RESET @@ -1162,7 +1386,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) * 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 - * excuted within it. + * executed within it. */ if (PL_cv_has_eval || PL_perldb) { @@ -1208,27 +1432,37 @@ Perl_pad_tidy(pTHX_ padtidy_type type) else if (type == padtidy_SUB) { /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */ AV * const av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(PL_comppad, 0, (SV*)av); + av_store(PL_comppad, 0, MUTABLE_SV(av)); AvREIFY_only(av); } - /* XXX DAPM rationalise these two similar branches */ - - if (type == padtidy_SUB) { + if (type == padtidy_SUB || type == padtidy_FORMAT) { + SV * const * 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])) continue; - if (!SvPADMY(PL_curpad[ix])) - SvPADTMP_on(PL_curpad[ix]); - } - } - else if (type == padtidy_FORMAT) { - PADOFFSET ix; - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) + if (!SvPADMY(PL_curpad[ix])) { SvPADTMP_on(PL_curpad[ix]); + } else if (!SvFAKE(namep[ix])) { + /* This is a work around for how the current implementation of + ?{ } blocks in regexps interacts with lexicals. + + One of our lexicals. + Can't do this on all lexicals, otherwise sub baz() won't + compile in + + my $foo; + + sub bar { ++$foo; } + + sub baz { ++$foo; } + + because completion of compiling &bar calling pad_tidy() + would cause (top level) $foo to be marked as stale, and + "no longer available". */ + SvPADSTALE_on(PL_curpad[ix]); + } } } PL_curpad = AvARRAY(PL_comppad); @@ -1263,17 +1497,6 @@ Perl_pad_free(pTHX_ PADOFFSET po) if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); -#ifdef USE_ITHREADS - /* SV could be a shared hash key (eg bugid #19022) */ - if ( -#ifdef PERL_OLD_COPY_ON_WRITE - !SvIsCOW(PL_curpad[po]) -#else - !SvFAKE(PL_curpad[po]) -#endif - ) - SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ -#endif } if ((I32)po < PL_padix) PL_padix = po - 1; @@ -1299,11 +1522,13 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) SV **ppad; I32 ix; + PERL_ARGS_ASSERT_DO_DUMP_PAD; + if (!padlist) { return; } - pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE); - pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE); + pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE)); + pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE)); pname = AvARRAY(pad_name); ppad = AvARRAY(pad); Perl_dump_indent(aTHX_ level, file, @@ -1324,18 +1549,18 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), SvPVX_const(namesv), - (unsigned long)SvIVX(namesv), - (unsigned long)SvNVX(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), + (unsigned long)COP_SEQ_RANGE_LOW(namesv), + (unsigned long)COP_SEQ_RANGE_HIGH(namesv), SvPVX_const(namesv) ); } @@ -1368,6 +1593,8 @@ S_cv_dump(pTHX_ const CV *cv, const char *title) 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", title, @@ -1410,8 +1637,8 @@ Perl_cv_clone(pTHX_ CV *proto) dVAR; I32 ix; 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); + const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE); + const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE); SV** const pname = AvARRAY(protopad_name); SV** const ppad = AvARRAY(protopad); const I32 fname = AvFILLp(protopad_name); @@ -1421,6 +1648,8 @@ Perl_cv_clone(pTHX_ CV *proto) CV* outside; long depth; + PERL_ARGS_ASSERT_CV_CLONE; + assert(!CvUNIQUE(proto)); /* Since cloneable anon subs can be nested, CvOUTSIDE may point @@ -1439,33 +1668,32 @@ Perl_cv_clone(pTHX_ CV *proto) ENTER; SAVESPTR(PL_compcv); - cv = PL_compcv = (CV*)newSV(0); - sv_upgrade((SV *)cv, SvTYPE(proto)); - CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE); + cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto))); + CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC); 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); + CvGV_set(cv,CvGV(proto)); + CvSTASH_set(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) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) - sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto)); + sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); av_fill(PL_comppad, fpad); - for (ix = fname; ix >= 0; ix--) + for (ix = fname; ix > 0; ix--) av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix])); PL_curpad = AvARRAY(PL_comppad); @@ -1477,35 +1705,37 @@ Perl_cv_clone(pTHX_ CV *proto) 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)) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", SvPVX_const(namesv)); + /* 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)) { + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", SvPVX_const(namesv)); sv = NULL; } - else { - assert(!SvPADSTALE(sv)); - sv = SvREFCNT_inc(sv); - } + else + SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { const char sigil = SvPVX_const(namesv)[0]; if (sigil == '&') sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') - sv = (SV*)newAV(); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = (SV*)newHV(); + sv = MUTABLE_SV(newHV()); else 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); @@ -1558,10 +1788,12 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) { dVAR; I32 ix; - AV * const comppad_name = (AV*)AvARRAY(padlist)[0]; - AV * const comppad = (AV*)AvARRAY(padlist)[1]; + AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); + AV * const comppad = MUTABLE_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--) { @@ -1569,7 +1801,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) if (namesv && namesv != &PL_sv_undef && *SvPVX_const(namesv) == '&') { - CV * const innercv = (CV*)curpad[ix]; + CV * const innercv = MUTABLE_CV(curpad[ix]); assert(CvWEAKOUTSIDE(innercv)); assert(CvOUTSIDE(innercv) == old_cv); CvOUTSIDE(innercv) = new_cv; @@ -1592,31 +1824,34 @@ void Perl_pad_push(pTHX_ PADLIST *padlist, int depth) { dVAR; - if (depth <= AvFILLp(padlist)) - return; - { + 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]); - const I32 names_fill = AvFILLp((AV*)svp[0]); + I32 ix = AvFILLp((const AV *)svp[1]); + const I32 names_fill = AvFILLp((const AV *)svp[0]); SV** const names = AvARRAY(svp[0]); AV *av; for ( ;ix > 0; ix--) { if (names_fill >= ix && names[ix] != &PL_sv_undef) { const char sigil = SvPVX_const(names[ix])[0]; - if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') { + 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 */ SV *sv; if (sigil == '@') - sv = (SV*)newAV(); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = (SV*)newHV(); + sv = MUTABLE_SV(newHV()); else sv = newSV(0); av_store(newpad, ix, sv); @@ -1624,7 +1859,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } } else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { - av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); } else { /* save temporaries on recursion? */ @@ -1634,11 +1869,10 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } } av = newAV(); - av_extend(av, 0); - av_store(newpad, 0, (SV*)av); + av_store(newpad, 0, MUTABLE_SV(av)); AvREIFY_only(av); - av_store(padlist, depth, (SV*)newpad); + av_store(padlist, depth, MUTABLE_SV(newpad)); AvFILLp(padlist) = depth; } } @@ -1649,12 +1883,135 @@ Perl_pad_compname_type(pTHX_ const PADOFFSET po) { dVAR; SV* const * const av = av_fetch(PL_comppad_name, po, FALSE); - if ( SvFLAGS(*av) & SVpad_TYPED ) { + if ( SvPAD_TYPED(*av) ) { return SvSTASH(*av); } return NULL; } +#if defined(USE_ITHREADS) + +# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) + +AV * +Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param) +{ + AV *dstpad; + PERL_ARGS_ASSERT_PADLIST_DUP; + + if (!srcpad) + return NULL; + + assert(!AvREAL(srcpad)); + + if (param->flags & CLONEf_COPY_STACKS + || SvREFCNT(AvARRAY(srcpad)[1]) > 1) { + /* XXX padlists are real, but pretend to be not */ + AvREAL_on(srcpad); + dstpad = av_dup_inc(srcpad, param); + AvREAL_off(srcpad); + AvREAL_off(dstpad); + assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1); + } else { + /* CvDEPTH() on our subroutine will be set to 0, so there's no need + to build anything other than the first level of pads. */ + + I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]); + AV *pad1; + const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0])); + const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1]; + SV **oldpad = AvARRAY(srcpad1); + SV **names; + SV **pad1a; + AV *args; + /* look for it in the table first. + I *think* that it shouldn't be possible to find it there. + Well, except for how Perl_sv_compile_2op() "works" :-( */ + dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad); + + if (dstpad) + return dstpad; + + dstpad = newAV(); + ptr_table_store(PL_ptr_table, srcpad, dstpad); + AvREAL_off(dstpad); + av_extend(dstpad, 1); + AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param)); + names = AvARRAY(AvARRAY(dstpad)[0]); + + pad1 = newAV(); + + av_extend(pad1, ix); + AvARRAY(dstpad)[1] = MUTABLE_SV(pad1); + pad1a = AvARRAY(pad1); + AvFILLp(dstpad) = 1; + + if (ix > -1) { + AvFILLp(pad1) = ix; + + for ( ;ix > 0; ix--) { + if (!oldpad[ix]) { + pad1a[ix] = NULL; + } else if (names_fill >= ix && names[ix] != &PL_sv_undef) { + 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 */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { /* our own lexical */ + if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { + /* This is a work around for how the current + implementation of ?{ } blocks in regexps + interacts with lexicals. */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } else { + SV *sv; + + if (sigil == '@') + sv = MUTABLE_SV(newAV()); + else if (sigil == '%') + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + pad1a[ix] = sv; + SvPADMY_on(sv); + } + } + } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { + /* save temporaries on recursion? */ + SV * const sv = newSV(0); + pad1a[ix] = sv; + + /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs + FIXTHAT before merging this branch. + (And I know how to) */ + if (SvPADMY(oldpad[ix])) + SvPADMY_on(sv); + else + SvPADTMP_on(sv); + } + } + + if (oldpad[0]) { + args = newAV(); /* Will be @_ */ + AvREIFY_only(args); + pad1a[0] = (SV *)args; + } + } + } + + return dstpad; +} + +#endif + /* * Local variables: * c-indentation-style: bsd