X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/73b81b142731b84cfdd5037cbef3bf9cf5ff3094..772f5a1a1edb352c066c952044fe021a848ae23d:/pad.c?ds=sidebyside diff --git a/pad.c b/pad.c index 3868359..da35a09 100644 --- a/pad.c +++ b/pad.c @@ -27,13 +27,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 Amx|PADLIST *|CvPADLIST|CV *cv -=for apidoc m|AV *|CvPADLIST|CV *cv -CV's can have CvPADLIST(cv) set to point to an AV. +CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's +scratchpad, which stores lexical variables and opcode temporary and +per-thread values. For these purposes "forms" are a kind-of CV, eval""s are too (except they're not callable at will and are always thrown away after the eval"" is done @@ -56,14 +54,6 @@ depth of recursion into the CV. The 0'th slot of a frame AV is an AV which is @_. other entries are storage for variables and op targets. -During compilation: -C is set to the names AV. -C is set to the frame AV for the frame CvDEPTH == 1. -C is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)). - -During execution, C and C refer to the live -frame of the currently executing sub. - Iterating over the names AV 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()). @@ -78,7 +68,17 @@ 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. 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 +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 @@ -101,13 +101,31 @@ 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, SVf_PADSTALE is overloaded to mean 'not yet initialised' +For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised' + +=for apidoc AmxU|AV *|PL_comppad_name + +During compilation, this points to the array containing the names part +of the pad for the currently-compiling code. + +=for apidoc AmxU|AV *|PL_comppad + +During compilation, this points to the array containing the values +part of the pad for the currently-compiling code. (At runtime a CV may +have many such value arrays; at compile time just one is constructed.) +At runtime, this points to the array containing the currently-relevant +values for the pad for the currently-executing code. + +=for apidoc AmxU|SV **|PL_curpad + +Points directly to the body of the L array. +(I.e., this is C.) =cut */ @@ -128,11 +146,21 @@ For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised' #define PARENT_FAKELEX_FLAGS_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END -#define PAD_MAX I32_MAX +/* +=for apidoc mx|void|pad_peg|const char *s + +When PERL_MAD is enabled, this is a small no-op function that gets called +at the start of each pad-related function. It can be breakpointed to +track all pad operations. The parameter is a string indicating the type +of pad operation being performed. + +=cut +*/ #ifdef PERL_MAD void pad_peg(const char* s) { - static int pegcnt; + static int pegcnt; /* XXX not threadsafe */ + PERL_UNUSED_ARG(s); PERL_ARGS_ASSERT_PAD_PEG; @@ -141,14 +169,55 @@ void pad_peg(const char* s) { #endif /* -=for apidoc pad_new +This is basically sv_eq_flags() in sv.c, but we avoid the magic +and bytes checking. +*/ + +static bool +sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) { + if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) { + const char *pv1 = SvPVX_const(sv); + STRLEN cur1 = SvCUR(sv); + const char *pv2 = pv; + STRLEN cur2 = pvlen; + if (PL_encoding) { + SV* svrecode = NULL; + if (SvUTF8(sv)) { + svrecode = newSVpvn(pv2, cur2); + sv_recode_to_utf8(svrecode, PL_encoding); + pv2 = SvPV_const(svrecode, cur2); + } + else { + svrecode = newSVpvn(pv1, cur1); + sv_recode_to_utf8(svrecode, PL_encoding); + pv1 = SvPV_const(svrecode, cur1); + } + SvREFCNT_dec(svrecode); + } + if (flags & SVf_UTF8) + return (bytes_cmp_utf8( + (const U8*)pv1, cur1, + (const U8*)pv2, cur2) == 0); + else + return (bytes_cmp_utf8( + (const U8*)pv2, cur2, + (const U8*)pv1, cur1) == 0); + } + else + return ((SvPVX_const(sv) == pv) + || memEQ(SvPVX_const(sv), pv, pvlen)); +} + + +/* +=for apidoc Am|PADLIST *|pad_new|int flags -Create a new compiling padlist, saving and updating the various global -vars at the same time as creating the pad itself. The following flags -can be OR'ed together: +Create a new padlist, updating the global variables for the +currently-compiling padlist to point to the new padlist. The following +flags can be OR'ed together: padnew_CLONE this pad is for a cloned CV - padnew_SAVE save old globals + padnew_SAVE save old globals on the save stack padnew_SAVESUB also save extra stuff for start of sub =cut @@ -159,6 +228,7 @@ Perl_pad_new(pTHX_ int flags) { dVAR; AV *padlist, *padname, *pad; + SV **ary; ASSERT_CURPAD_LEGAL("pad_new"); @@ -200,7 +270,6 @@ Perl_pad_new(pTHX_ int flags) */ AV * const a0 = newAV(); /* will be @_ */ - av_extend(a0, 0); av_store(pad, 0, MUTABLE_SV(a0)); AvREIFY_only(a0); } @@ -209,14 +278,23 @@ Perl_pad_new(pTHX_ int flags) } AvREAL_off(padlist); - av_store(padlist, 0, MUTABLE_SV(padname)); - av_store(padlist, 1, MUTABLE_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 = MUTABLE_AV((*av_fetch(padlist, 0, FALSE))); - PL_comppad = MUTABLE_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; @@ -236,119 +314,186 @@ 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); - - PERL_ARGS_ASSERT_PAD_UNDEF; + const PADLIST *padlist = CvPADLIST(cv); - pad_peg("pad_undef"); - 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" comppad=0x%"UVxf"\n", - PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) + "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 = 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--; - } +#ifdef USE_ITHREADS + if (CvFILE(cv) && !CvISXSUB(cv)) { + /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + Safefree(CvFILE(cv)); + } + CvFILE(cv) = NULL; +#endif - /* 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; + 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) { + 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; - else if (sv == (const SV *)PL_comppad) { - PL_comppad = NULL; - PL_curpad = NULL; - } + SvREFCNT_dec(sv); } - SvREFCNT_dec(sv); + SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv))); + CvPADLIST(cv) = NULL; + } + + + /* 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; } - SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv))); - CvPADLIST(cv) = NULL; + if (CvCONST(cv)) { + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); + CvCONST_off(cv); + } + if (CvISXSUB(cv) && CvXSUB(cv)) { + CvXSUB(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); } +/* +=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash +Allocates a place in the currently-compiling +pad (via L) and +then stores a name for that entry. I is adopted and becomes the +name entry; it must already contain the name string and be sufficiently +upgraded. I and I and the C flag get +added to I. None of the other +processing of L +is done. Returns the offset of the allocated pad slot. +=cut +*/ static PADOFFSET -S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, - HV *ourstash) +S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { dVAR; const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); - PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; + PERL_ARGS_ASSERT_PAD_ALLOC_NAME; - ASSERT_CURPAD_ACTIVE("pad_add_name"); + ASSERT_CURPAD_ACTIVE("pad_alloc_name"); if (typestash) { assert(SvTYPE(namesv) == SVt_PVMG); @@ -360,7 +505,7 @@ S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, SvOURSTASH_set(namesv, ourstash); SvREFCNT_inc_simple_void_NN(ourstash); } - else if (flags & pad_add_STATE) { + else if (flags & padadd_STATE) { SvPAD_STATE_on(namesv); } @@ -369,82 +514,139 @@ S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash, } /* -=for apidoc pad_add_name +=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash -Create a new name and associated PADMY SV in the current pad; return the -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 -SvOURSTASH to that value +Allocates a place in the currently-compiling pad for a named lexical +variable. Stores the name and other metadata in the name part of the +pad, and makes preparations to manage the variable's lexical scoping. +Returns the offset of the allocated pad slot. -If fake, it means we're cloning an existing entry +I/I specify the variable's name, including leading sigil. +If I is non-null, the name is for a typed lexical, and this +identifies the type. If I is non-null, it's a lexical reference +to a package variable, and this identifies the package. The following +flags can be OR'ed together: + + padadd_OUR redundantly specifies if it's a package var + padadd_STATE variable will retain value persistently + padadd_NO_DUP_CHECK skip check for lexical shadowing =cut */ PADOFFSET -Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, - HV *typestash, HV *ourstash) +Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, + U32 flags, HV *typestash, HV *ourstash) { dVAR; PADOFFSET offset; SV *namesv; + bool is_utf8; - PERL_ARGS_ASSERT_PAD_ADD_NAME; + PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; - if (flags & ~(pad_add_OUR|pad_add_STATE|pad_add_NO_DUP_CHECK)) - Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, + if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME)) + Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, (UV)flags); - - if ((flags & pad_add_NO_DUP_CHECK) == 0) { - /* check for duplicate declaration */ - pad_check_dup(name, len, flags & pad_add_OUR, ourstash); + namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + + if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) { + namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8); } - namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + sv_setpvn(namesv, namepv, namelen); - /* 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); + if (is_utf8) { + flags |= padadd_UTF8_NAME; + SvUTF8_on(namesv); + } + else + flags &= ~padadd_UTF8_NAME; - sv_setpv(namesv, name); + if ((flags & padadd_NO_DUP_CHECK) == 0) { + /* check for duplicate declaration */ + pad_check_dup(namesv, flags & padadd_OUR, ourstash); + } - offset = pad_add_name_sv(namesv, flags, typestash, ourstash); + offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash); /* not yet introduced */ - COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ - COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ + 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 */ - /* XXX DAPM since slot has been allocated, replace - * av_store with PL_curpad[offset] ? */ - if (*name == '@') - av_store(PL_comppad, offset, MUTABLE_SV(newAV())); - else if (*name == '%') - av_store(PL_comppad, offset, MUTABLE_SV(newHV())); - SvPADMY_on(PL_curpad[offset]); + assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); + assert(SvREFCNT(PL_curpad[offset]) == 1); + if (namelen != 0 && *namepv == '@') + sv_upgrade(PL_curpad[offset], SVt_PVAV); + else if (namelen != 0 && *namepv == '%') + 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]))); + (long)offset, SvPVX(namesv), + PTR2UV(PL_curpad[offset]))); return offset; } +/* +=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash +Exactly like L, but takes a nul-terminated string +instead of a string/length pair. +=cut +*/ + +PADOFFSET +Perl_pad_add_name_pv(pTHX_ const char *name, + const U32 flags, HV *typestash, HV *ourstash) +{ + PERL_ARGS_ASSERT_PAD_ADD_NAME_PV; + return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash); +} /* -=for apidoc pad_alloc +=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash -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 no active value. +Exactly like L, but takes the name string in the form +of an SV instead of a string/length pair. + +=cut +*/ + +PADOFFSET +Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; + namepv = SvPV(name, namelen); + if (SvUTF8(name)) + flags |= padadd_UTF8_NAME; + return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash); +} + +/* +=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype + +Allocates a place in the currently-compiling pad, +returning the offset of the allocated pad slot. +No name is initially attached to the pad slot. +I is a set of flags indicating the kind of pad entry required, +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 + +I should be an opcode indicating the type of operation that the +pad entry is to support. This doesn't affect operational semantics, +but is used for debugging. =cut */ @@ -472,10 +674,14 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) if (PL_pad_reset_pending) pad_reset(); if (tmptype & SVs_PADMY) { + /* For a my, simply push a null SV onto the end of PL_comppad. */ sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); retval = AvFILLp(PL_comppad); } else { + /* For a tmp, scan the pad from PL_padix upwards + * for a slot which has no name and no active value. + */ SV * const * const names = AvARRAY(PL_comppad_name); const SSize_t names_fill = AvFILLp(PL_comppad_name); for (;;) { @@ -510,15 +716,23 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) } /* -=for apidoc pad_add_anon +=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype + +Allocates a place in the currently-compiling pad (via L) +for an anonymous function that is lexically scoped inside the +currently-compiling function. +The function I is linked into the pad, and its C link +to the outer scope is weakened to avoid a reference loop. -Add an anon code entry to the current compiling pad +I should be an opcode indicating the type of operation that the +pad entry is to support. This doesn't affect operational semantics, +but is used for debugging. =cut */ PADOFFSET -Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) +Perl_pad_add_anon(pTHX_ CV* func, I32 optype) { dVAR; PADOFFSET ix; @@ -528,29 +742,28 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type) pad_peg("add_anon"); sv_setpvs(name, "&"); - /* 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); + /* 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(optype, SVs_PADMY); av_store(PL_comppad_name, ix, name); /* XXX DAPM use PL_curpad[] ? */ - av_store(PL_comppad, ix, sv); - SvPADMY_on(sv); + av_store(PL_comppad, ix, (SV*)func); + SvPADMY_on((SV*)func); /* to avoid ref loops, we never have parent + child referencing each * other simultaneously */ - if (CvOUTSIDE((const CV *)sv)) { - assert(!CvWEAKOUTSIDE((const CV *)sv)); - CvWEAKOUTSIDE_on(MUTABLE_CV(sv)); - SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv))); + if (CvOUTSIDE(func)) { + assert(!CvWEAKOUTSIDE(func)); + CvWEAKOUTSIDE_on(func); + SvREFCNT_dec(CvOUTSIDE(func)); } return ix; } - - /* -=for apidoc pad_check_dup +=for apidoc m|pad_check_dup|SV *name|U32 flags|const HV *ourstash Check for duplicate declarations: report any of: * a my in the current scope with the same name; @@ -561,25 +774,19 @@ C indicates that the name to check is an 'our' declaration =cut */ -void -S_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, - const HV *ourstash) +STATIC void +S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash) { dVAR; SV **svp; PADOFFSET top, off; - const U32 is_our = flags & pad_add_OUR; + const U32 is_our = flags & padadd_OUR; PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); - assert((flags & ~pad_add_OUR) == 0); - - /* 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); + assert((flags & ~padadd_OUR) == 0); if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ @@ -594,8 +801,9 @@ S_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, if (sv && sv != &PL_sv_undef && !SvFAKE(sv) - && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(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 && (SvPAD_OUR(sv))) break; /* "our" masking "our" */ @@ -603,21 +811,23 @@ S_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, "\"%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) == PAD_MAX ? "scope" : "statement")); + (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) - && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) && SvOURSTASH(sv) == ourstash - && strEQ(name, SvPVX_const(sv))) + && sv_eq(name, sv)) { Perl_warner(aTHX_ packWARN(WARN_MISC), "\"our\" variable %"SVf" redeclared", sv); @@ -626,25 +836,29 @@ S_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, "\t(Did you mean \"local\" instead of \"our\"?)\n"); break; } - } while ( off-- > 0 ); + --off; + } } } /* -=for apidoc pad_findmy +=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags -Given a lexical name, try to find its offset, first in the current pad, -or failing that, in the pads of any lexically enclosing subs (including -the complications introduced by eval). If the name is found in an outer pad, -then a fake entry is added to the current pad. -Returns the offset in the current pad, or NOT_IN_PAD on failure. +Given the name of a lexical variable, find its position in the +currently-compiling pad. +I/I specify the variable's name, including leading sigil. +I is reserved and must be zero. +If it is not in the current pad but appears in the pad of any lexically +enclosing scope, then a pseudo-entry for it is added in the current pad. +Returns the offset in the current pad, +or C if no such lexical is in scope. =cut */ PADOFFSET -Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) +Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) { dVAR; SV *out_sv; @@ -653,27 +867,26 @@ Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) const AV *nameav; SV **name_svp; - PERL_ARGS_ASSERT_PAD_FINDMY; + PERL_ARGS_ASSERT_PAD_FINDMY_PVN; - pad_peg("pad_findmy"); + pad_peg("pad_findmy_pvn"); - if (flags) - Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf, + if (flags & ~padadd_UTF8_NAME) + Perl_croak(aTHX_ "panic: pad_findmy_pvn 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; + if (flags & padadd_UTF8_NAME) { + bool is_utf8 = TRUE; + namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8); - /* But until we're using the length for real, cross check that we're being - told the truth. */ - assert(strlen(name) == len); + if (is_utf8) + flags |= padadd_UTF8_NAME; + else + flags &= ~padadd_UTF8_NAME; + } - offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, - NULL, &out_sv, &out_flags); + offset = pad_findlex(namepv, namelen, flags, + PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); if ((PADOFFSET)offset != NOT_IN_PAD) return offset; @@ -688,8 +901,10 @@ Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv) && (SvPAD_OUR(namesv)) - && strEQ(SvPVX_const(namesv), name) - && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */ + && 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 ) return offset; } @@ -697,9 +912,53 @@ Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) } /* - * Returns the offset of a lexical $_, if there is one, at run time. - * Used by the UNDERBAR XS macro. - */ +=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags + +Exactly like L, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +PADOFFSET +Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags) +{ + PERL_ARGS_ASSERT_PAD_FINDMY_PV; + return pad_findmy_pvn(name, strlen(name), flags); +} + +/* +=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags + +Exactly like L, but takes the name string in the form +of an SV instead of a string/length pair. + +=cut +*/ + +PADOFFSET +Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_PAD_FINDMY_SV; + namepv = SvPV(name, namelen); + if (SvUTF8(name)) + flags |= padadd_UTF8_NAME; + return pad_findmy_pvn(namepv, namelen, flags); +} + +/* +=for apidoc Amp|PADOFFSET|find_rundefsvoffset + +Find the position of the lexical C<$_> in the pad of the +currently-executing function. Returns the offset in the current pad, +or C if there is no lexical C<$_> in scope (in which case +the global one should be used instead). +L is likely to be more convenient. + +=cut +*/ PADOFFSET Perl_find_rundefsvoffset(pTHX) @@ -707,12 +966,38 @@ Perl_find_rundefsvoffset(pTHX) dVAR; SV *out_sv; int out_flags; - return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1, + return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, NULL, &out_sv, &out_flags); } /* -=for apidoc pad_findlex +=for apidoc Am|SV *|find_rundefsv + +Find and return the variable that is named C<$_> in the lexical scope +of the currently-executing function. This may be a lexical C<$_>, +or will otherwise be the global one. + +=cut +*/ + +SV * +Perl_find_rundefsv(pTHX) +{ + SV *namesv; + int flags; + PADOFFSET po; + + po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, + NULL, &namesv, &flags); + + if (po == NOT_IN_PAD || SvPAD_OUR(namesv)) + return DEFSV; + + return PAD_SVl(po); +} + +/* +=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags Find a named lexical anywhere in a chain of nested pads. Add fake entries in the inner pads if it's found in an outer one. @@ -743,8 +1028,8 @@ the parent pad. STATIC PADOFFSET -S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, - SV** out_capture, SV** out_name_sv, int *out_flags) +S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, + int warn, SV** out_capture, SV** out_name_sv, int *out_flags) { dVAR; I32 offset, new_offset; @@ -754,11 +1039,16 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, PERL_ARGS_ASSERT_PAD_FINDLEX; + if (flags & ~padadd_UTF8_NAME) + Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, + (UV)flags); + *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n", - PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" )); + "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n", + PTR2UV(cv), (int)namelen, namepv, (int)seq, + out_capture ? " capturing" : "" )); /* first, search this pad */ @@ -770,13 +1060,39 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, for (offset = AvFILLp(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; if (namesv && namesv != &PL_sv_undef - && strEQ(SvPVX_const(namesv), name)) + && SvCUR(namesv) == namelen + && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen, + flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)) { - if (SvFAKE(namesv)) + if (SvFAKE(namesv)) { fake_offset = offset; /* in case we don't find a real one */ - else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */ - && seq <= COP_SEQ_RANGE_HIGH(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; } } @@ -789,7 +1105,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) ? @@ -831,7 +1147,11 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, { if (warn) Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + "Variable \"%"SVf"\" is not available", + newSVpvn_flags(namepv, namelen, + SVs_TEMP | + (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); + *out_capture = NULL; } @@ -843,7 +1163,10 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, && warn && ckWARN(WARN_CLOSURE)) { newwarn = 0; Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" will not stay shared", name); + "Variable \"%"SVf"\" will not stay shared", + newSVpvn_flags(namepv, namelen, + SVs_TEMP | + (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); } if (fake_offset && CvANON(cv) @@ -855,7 +1178,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n", PTR2UV(cv))); n = *out_name_sv; - (void) pad_findlex(name, CvOUTSIDE(cv), + (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), newwarn, out_capture, out_name_sv, out_flags); *out_name_sv = n; @@ -872,14 +1195,17 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, && !SvPAD_STATE(name_svp[offset])) { Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + "Variable \"%"SVf"\" is not available", + newSVpvn_flags(namepv, namelen, + SVs_TEMP | + (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); *out_capture = NULL; } } if (!*out_capture) { - if (*name == '@') + if (namelen != 0 && *namepv == '@') *out_capture = sv_2mortal(MUTABLE_SV(newAV())); - else if (*name == '%') + else if (namelen != 0 && *namepv == '%') *out_capture = sv_2mortal(MUTABLE_SV(newHV())); else *out_capture = sv_newmortal(); @@ -900,7 +1226,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, new_capturep = out_capture ? out_capture : CvLATE(cv) ? NULL : &new_capture; - offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, + offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, new_capturep, out_name_sv, out_flags); if ((PADOFFSET)offset == NOT_IN_PAD) return NOT_IN_PAD; @@ -914,7 +1240,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, { /* This relies on sv_setsv_flags() upgrading the destination to the same - type as the source, independant of the flags set, and on it being + 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); @@ -925,8 +1251,8 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, PL_curpad = AvARRAY(PL_comppad); new_offset - = pad_add_name_sv(new_namesv, - (SvPAD_STATE(*out_name_sv) ? pad_add_STATE : 0), + = pad_alloc_name(new_namesv, + (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0), SvPAD_TYPED(*out_name_sv) ? SvSTASH(*out_name_sv) : NULL, SvOURSTASH(*out_name_sv) @@ -965,18 +1291,17 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, return new_offset; } - #ifdef DEBUGGING + /* -=for apidoc pad_sv +=for apidoc Am|SV *|pad_sv|PADOFFSET po -Get the value at offset po in the current pad. +Get the value at offset I in the current (compiling or executing) pad. Use macro PAD_SV instead of calling this function directly. =cut */ - SV * Perl_pad_sv(pTHX_ PADOFFSET po) { @@ -992,11 +1317,10 @@ Perl_pad_sv(pTHX_ PADOFFSET po) return PL_curpad[po]; } - /* -=for apidoc pad_setsv +=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv -Set the entry at offset po in the current pad to sv. +Set the value at offset I in the current (compiling or executing) pad. Use the macro PAD_SETSV() rather than calling this function directly. =cut @@ -1017,12 +1341,11 @@ Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) ); PL_curpad[po] = sv; } -#endif - +#endif /* DEBUGGING */ /* -=for apidoc pad_block_start +=for apidoc m|void|pad_block_start|int full Update the pad compilation state variables on entry to a new block @@ -1055,9 +1378,8 @@ Perl_pad_block_start(pTHX_ int full) PL_pad_reset_pending = FALSE; } - /* -=for apidoc intro_my +=for apidoc m|U32|intro_my "Introduce" my variables to visible status. @@ -1070,6 +1392,7 @@ Perl_intro_my(pTHX) dVAR; SV **svp; I32 i; + U32 seq; ASSERT_CURPAD_ACTIVE("intro_my"); if (! PL_min_intro_pending) @@ -1079,8 +1402,10 @@ 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) && !COP_SEQ_RANGE_HIGH(sv)) { - COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */ + 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\", (%lu,%lu)\n", @@ -1090,16 +1415,20 @@ Perl_intro_my(pTHX) ); } } + 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; } /* -=for apidoc pad_leavemy +=for apidoc m|void|pad_leavemy Cleanup at end of scope during compilation: set the max seq number for lexicals in this scope and warn of any lexicals that never got introduced. @@ -1129,7 +1458,9 @@ 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--) { const SV * const sv = svp[off]; - if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) { + 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\", (%lu,%lu)\n", @@ -1140,13 +1471,14 @@ Perl_pad_leavemy(pTHX) } } 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)); } - /* -=for apidoc pad_swipe +=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust Abandon the tmp in the current pad at offset po and replace with a new one. @@ -1188,9 +1520,8 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) PL_padix = po - 1; } - /* -=for apidoc pad_reset +=for apidoc m|void|pad_reset Mark all the current temporaries for reuse @@ -1230,14 +1561,17 @@ S_pad_reset(pTHX) PL_pad_reset_pending = FALSE; } - /* -=for apidoc pad_tidy +=for apidoc Amx|void|pad_tidy|padtidy_type type + +Tidy up a pad at the end of compilation of the code to which it belongs. +Jobs performed here are: remove most stuff from the pads of anonsub +prototypes; give it a @_; mark temporaries as such. I indicates +the kind of subroutine: -Tidy up a pad after we've finished compiling it: - * remove most stuff from the pads of anonsub prototypes; - * give it a @_; - * mark tmps as such. + padtidy_SUB ordinary subroutine + padtidy_SUBCLONE prototype for lexical closure + padtidy_FORMAT format =cut */ @@ -1260,7 +1594,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) { @@ -1306,35 +1640,44 @@ 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, 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); } - /* -=for apidoc pad_free +=for apidoc m|void|pad_free|PADOFFSET po Free the SV at offset po in the current pad. @@ -1361,20 +1704,13 @@ 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 (!SvIsCOW(PL_curpad[po])) - SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ -#endif } if ((I32)po < PL_padix) PL_padix = po - 1; } - - /* -=for apidoc do_dump_pad +=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full Dump the contents of a padlist @@ -1444,17 +1780,16 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) } } - +#ifdef DEBUGGING /* -=for apidoc cv_dump +=for apidoc m|void|cv_dump|CV *cv|const char *title dump the contents of a CV =cut */ -#ifdef DEBUGGING STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) { @@ -1484,18 +1819,17 @@ S_cv_dump(pTHX_ const CV *cv, const char *title) " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist)); do_dump_pad(1, Perl_debug_log, padlist, 1); } -#endif /* DEBUGGING */ - - - +#endif /* DEBUGGING */ /* -=for apidoc cv_clone +=for apidoc Am|CV *|cv_clone|CV *proto -Clone a CV: make a new CV which points to the same code etc, but which -has a newly-created pad built by copying the prototype pad and capturing -any outer lexicals. +Clone a CV, making a lexical closure. I supplies the prototype +of the function: its code, pad structure, and other attributes. +The prototype is combined with a capture of outer lexicals to which the +code refers, which are taken from the currently-executing instance of +the immediately surrounding code. =cut */ @@ -1538,7 +1872,7 @@ Perl_cv_clone(pTHX_ CV *proto) SAVESPTR(PL_compcv); cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto))); - CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE); + CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC); CvCLONED_on(cv); #ifdef USE_ITHREADS @@ -1547,8 +1881,8 @@ Perl_cv_clone(pTHX_ CV *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; @@ -1562,7 +1896,7 @@ Perl_cv_clone(pTHX_ CV *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); @@ -1581,7 +1915,7 @@ Perl_cv_clone(pTHX_ CV *proto) 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)); + "Variable \"%"SVf"\" is not available", namesv); sv = NULL; } else @@ -1641,9 +1975,8 @@ Perl_cv_clone(pTHX_ CV *proto) return cv; } - /* -=for apidoc pad_fixup_inner_anons +=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv For any anon CVs in the pad, change CvOUTSIDE of that CV from old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be @@ -1678,9 +2011,8 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) } } - /* -=for apidoc pad_push +=for apidoc m|void|pad_push|PADLIST *padlist|int depth 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. Then give @@ -1738,7 +2070,6 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } } av = newAV(); - av_extend(av, 0); av_store(newpad, 0, MUTABLE_SV(av)); AvREIFY_only(av); @@ -1747,6 +2078,15 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } } +/* +=for apidoc Am|HV *|pad_compname_type|PADOFFSET po + +Looks up the type of the lexical variable at position I in the +currently-compiling pad. If the variable is typed, the stash of the +class to which it is typed is returned. If not, C is returned. + +=cut +*/ HV * Perl_pad_compname_type(pTHX_ const PADOFFSET po) @@ -1759,6 +2099,137 @@ Perl_pad_compname_type(pTHX_ const PADOFFSET po) return NULL; } +#if defined(USE_ITHREADS) + +# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) + +/* +=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param + +Duplicates a pad. + +=cut +*/ + +AV * +Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *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 /* USE_ITHREADS */ + /* * Local variables: * c-indentation-style: bsd