X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pad.c;h=e8ba1394347897ac549b05625b60d86182619f67;hb=13.2-releng;hp=d80679ad861617f51734de9367766291a297cce0;hpb=cca43f7877df27a183ef8184587126e106940d27;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pad.c b/pad.c index d80679a..e8ba139 100644 --- a/pad.c +++ b/pad.c @@ -101,13 +101,13 @@ 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' =cut */ @@ -200,7 +200,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); } @@ -339,6 +338,35 @@ Perl_pad_undef(pTHX_ CV* cv) +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 @@ -359,14 +387,12 @@ 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); + PADOFFSET offset; SV *namesv; PERL_ARGS_ASSERT_PAD_ADD_NAME; - ASSERT_CURPAD_ACTIVE("pad_add_name"); - - if (flags & ~(pad_add_STATE|pad_add_FAKE)) + if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, (UV)flags); @@ -379,46 +405,31 @@ Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, sv_setpv(namesv, 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 & pad_add_STATE) { - SvPAD_STATE_on(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 (flags & pad_add_FAKE) { - SvFAKE_on(namesv); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name)); - } - else { - /* not yet introduced */ - COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */ - COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */ - - if (!PL_min_intro_pending) - PL_min_intro_pending = offset; - 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]); - 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, PAD_MAX); /* min */ + COP_SEQ_RANGE_HIGH_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 */ + 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; } @@ -548,29 +559,19 @@ 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, const STRLEN len, const U32 flags, - 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 & pad_add_OUR; + const U32 is_our = flags & padadd_OUR; PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); - if (flags & ~pad_add_OUR) - Perl_croak(aTHX_ "panic: pad_check_dup illegal flag bits 0x%" UVxf, - (UV)flags); - - /* 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 */ @@ -586,7 +587,7 @@ Perl_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, && sv != &PL_sv_undef && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) - && strEQ(name, SvPVX_const(sv))) + && sv_eq(name, sv)) { if (is_our && (SvPAD_OUR(sv))) break; /* "our" masking "our" */ @@ -608,7 +609,7 @@ Perl_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, && !SvFAKE(sv) && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0) && SvOURSTASH(sv) == ourstash - && strEQ(name, SvPVX_const(sv))) + && sv_eq(name, sv)) { Perl_warner(aTHX_ packWARN(WARN_MISC), "\"our\" variable %"SVf" redeclared", sv); @@ -703,6 +704,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 @@ -904,24 +927,30 @@ 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, independant 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 = 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), - SvCUR(*out_name_sv), - /* state variable ? */ - pad_add_FAKE | (SvPAD_STATE(*out_name_sv) ? pad_add_STATE : 0), - SvPAD_TYPED(*out_name_sv) - ? SvSTASH(*out_name_sv) : NULL, - SvOURSTASH(*out_name_sv) - ); - - new_namesv = AvARRAY(PL_comppad_name)[new_offset]; + 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); @@ -1291,27 +1320,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, 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); @@ -1723,7 +1762,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); @@ -1744,6 +1782,129 @@ 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)) + +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