executing). Require'd files are simply evals without any outer lexical
scope.
-XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
+XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
but that is really the callers pad (a slot of which is allocated by
-every entersub).
+every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
+determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
+internal purpose in XSUBs.
The PADLIST has a C array where pads are stored.
AV which is @_. Other entries are storage for variables and op targets.
Iterating over the PADNAMELIST iterates over all possible pad
-items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
+items. Pad slots for targets (SVs_PADTMP)
+and GVs end up having &PL_sv_undef
"names", while slots for constants have &PL_sv_no "names" (see
-pad_alloc()).
+pad_alloc()). That &PL_sv_no is used is an implementation detail subject
+to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
If PADNAME_OUTER (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,
+a REFCNT'ed reference to a lexical from "outside". In this case,
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
+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, xlow contains the index
within the parent's pad where the lexical's value is stored, to make
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
/*
-=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; /* XXX not threadsafe */
- PERL_UNUSED_ARG(s);
-
- PERL_ARGS_ASSERT_PAD_PEG;
-
- pegcnt++;
-}
-#endif
-
-/*
This is basically sv_eq_flags() in sv.c, but we avoid the magic
and bytes checking.
*/
|| memEQ(SvPVX_const(sv), pv, pvlen));
}
+#ifdef DEBUGGING
+void
+Perl_set_padlist(pTHX_ CV * cv, PADLIST *padlist){
+ PERL_ARGS_ASSERT_SET_PADLIST;
+# if PTRSIZE == 8
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEFEFEFEFEF)){
+ assert(0);
+ }
+# elif PTRSIZE == 4
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEF)){
+ assert(0);
+ }
+# else
+# error unknown pointer size
+# endif
+ if(CvISXSUB(cv)){
+ assert(0);
+ }
+ ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
+}
+#endif
/*
=for apidoc Am|PADLIST *|pad_new|int flags
PADLIST *
Perl_pad_new(pTHX_ int flags)
{
- dVAR;
PADLIST *padlist;
PAD *padname, *pad;
PAD **ary;
if (! (flags & padnew_CLONE)) {
SAVESPTR(PL_comppad_name);
SAVEI32(PL_padix);
+ SAVEI32(PL_constpadix);
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
SAVEI32(PL_max_intro_pending);
else {
av_store(pad, 0, NULL);
padname = newAV();
+ AvPAD_NAMELIST_on(padname);
+ av_store(padname, 0, &PL_sv_undef);
}
/* Most subroutines never recurse, hence only need 2 entries in the padlist
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
+ PL_constpadix = 0;
PL_cv_has_eval = 0;
}
=for apidoc cv_undef
-Clear out all the active components of a CV. This can happen either
+Clear out all the active components of a CV. This can happen either
by an explicit C<undef &foo>, 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.
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dVAR;
- const PADLIST *padlist = CvPADLIST(cv);
- bool const slabbed = !!CvSLABBED(cv);
-
PERL_ARGS_ASSERT_CV_UNDEF;
+ cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
+ CV cvbody;/*CV body will never be realloced inside this func,
+ so dont read it more than once, use fake CV so existing macros
+ will work, the indirection and CV head struct optimized away*/
+ SvANY(&cvbody) = SvANY(cv);
+
+ PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
DEBUG_X(PerlIO_printf(Perl_debug_log,
"CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(PL_comppad))
);
- if (CvFILE(cv) && CvDYNFILE(cv)) {
- Safefree(CvFILE(cv));
- }
- CvFILE(cv) = NULL;
-
- CvSLABBED_off(cv);
- if (!CvISXSUB(cv) && CvROOT(cv)) {
- if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
- Perl_croak(aTHX_ "Can't undef active subroutine");
- ENTER;
-
- PAD_SAVE_SETNULLPAD();
-
- if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
- op_free(CvROOT(cv));
- CvROOT(cv) = NULL;
- CvSTART(cv) = NULL;
- LEAVE;
+ if (CvFILE(&cvbody)) {
+ char * file = CvFILE(&cvbody);
+ CvFILE(&cvbody) = NULL;
+ if(CvDYNFILE(&cvbody))
+ Safefree(file);
}
- else if (slabbed && CvSTART(cv)) {
- ENTER;
- PAD_SAVE_SETNULLPAD();
-
- /* discard any leaked ops */
- if (PL_parser)
- parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
- opslab_force_free((OPSLAB *)CvSTART(cv));
- CvSTART(cv) = NULL;
- LEAVE;
- }
+ /* CvSLABBED_off(&cvbody); *//* turned off below */
+ /* release the sub's body */
+ if (!CvISXSUB(&cvbody)) {
+ if(CvROOT(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
+ if (CvDEPTHunsafe(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV);
+ Perl_croak_nocontext("Can't undef active subroutine");
+ }
+ ENTER;
+
+ PAD_SAVE_SETNULLPAD();
+
+ if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
+ op_free(CvROOT(&cvbody));
+ CvROOT(&cvbody) = NULL;
+ CvSTART(&cvbody) = NULL;
+ LEAVE;
+ }
+ else if (CvSLABBED(&cvbody)) {
+ if( CvSTART(&cvbody)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ /* discard any leaked ops */
+ if (PL_parser)
+ parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
+ opslab_force_free((OPSLAB *)CvSTART(&cvbody));
+ CvSTART(&cvbody) = NULL;
+
+ LEAVE;
+ }
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+ else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
+ }
+ }
+ else { /* dont bother checking if CvXSUB(cv) is true, less branching */
+ CvXSUB(&cvbody) = NULL;
+ }
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
- if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
- else CvGV_set(cv, NULL);
+ if (!(flags & CV_UNDEF_KEEP_NAME)) {
+ if (CvNAMED(&cvbody)) {
+ CvNAME_HEK_set(&cvbody, NULL);
+ CvNAMED_off(&cvbody);
+ }
+ else CvGV_set(cv, NULL);
+ }
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
- if (padlist) {
+ if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
I32 ix;
+ const PADLIST *padlist = CvPADLIST(&cvbody);
/* Free the padlist associated with a CV.
If parts of it happen to be current, we null the relevant PL_*pad*
* 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);
+ CV * const outercv = CvOUTSIDE(&cvbody);
+ const U32 seq = CvOUTSIDE_SEQ(&cvbody);
PAD * const comppad_name = PadlistARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
PAD * const comppad = PadlistARRAY(padlist)[1];
}
if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
Safefree(padlist);
- CvPADLIST(cv) = NULL;
+ CvPADLIST_set(&cvbody, NULL);
}
+ else if (CvISXSUB(&cvbody))
+ CvHSCXT(&cvbody) = NULL;
+ /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
/* 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 (!SvREFCNT(cv)) {
+ CV * outside = CvOUTSIDE(&cvbody);
+ if(outside) {
+ CvOUTSIDE(&cvbody) = NULL;
+ if (!CvWEAKOUTSIDE(&cvbody))
+ SvREFCNT_dec_NN(outside);
+ }
}
- if (CvISXSUB(cv) && CvXSUB(cv)) {
- CvXSUB(cv) = NULL;
+ if (CvCONST(&cvbody)) {
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
+ /* CvCONST_off(cv); *//* turned off below */
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
- * to choose an error message */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
+ * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+ * LEXICAL, which are used to determine the sub's name. */
+ CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+ |CVf_NAMED);
}
/*
if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
if (slab) {
static PADOFFSET
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_ALLOC_NAME;
}
av_store(PL_comppad_name, offset, namesv);
+ PadnamelistMAXNAMED(PL_comppad_name) = offset;
return offset;
}
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;
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dVAR;
SV *sv;
I32 retval;
AvARRAY(PL_comppad), PL_curpad);
if (PL_pad_reset_pending)
pad_reset();
- if (tmptype & SVs_PADMY) {
+ if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
/* 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.
+ * For a constant, likewise, but use PL_constpadix.
*/
SV * const * const names = AvARRAY(PL_comppad_name);
const SSize_t names_fill = AvFILLp(PL_comppad_name);
+ const bool konst = cBOOL(tmptype & SVf_READONLY);
+ retval = konst ? PL_constpadix : PL_padix;
for (;;) {
/*
* Entries that close over unavailable variables
* in outer subs contain values not marked PADMY.
* Thus we must skip, not just pad values that are
* marked as current pad values, but also those with names.
+ * If pad_reset is enabled, ‘current’ means different
+ * things depending on whether we are allocating a con-
+ * stant or a target. For a target, things marked PADTMP
+ * can be reused; not so for constants.
*/
- if (++PL_padix <= names_fill &&
- (sv = names[PL_padix]) && sv != &PL_sv_undef)
+ if (++retval <= names_fill &&
+ (sv = names[retval]) && sv != &PL_sv_undef)
continue;
- sv = *av_fetch(PL_comppad, PL_padix, TRUE);
- if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
- !IS_PADGV(sv) && !IS_PADCONST(sv))
+ sv = *av_fetch(PL_comppad, retval, TRUE);
+ if (!(SvFLAGS(sv) &
+#ifdef USE_PAD_RESET
+ (konst ? SVs_PADTMP : 0))
+#else
+ SVs_PADTMP
+#endif
+ ))
break;
}
- if (tmptype & SVf_READONLY) {
- av_store(PL_comppad_name, PL_padix, &PL_sv_no);
+ if (konst) {
+ av_store(PL_comppad_name, retval, &PL_sv_no);
tmptype &= ~SVf_READONLY;
tmptype |= SVs_PADTMP;
}
- retval = PL_padix;
+ *(konst ? &PL_constpadix : &PL_padix) = retval;
}
SvFLAGS(sv) |= tmptype;
PL_curpad = AvARRAY(PL_comppad);
PADOFFSET
Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
- dVAR;
PADOFFSET ix;
SV* const name = newSV_type(SVt_PVNV);
assert (SvTYPE(func) == SVt_PVFM);
av_store(PL_comppad, ix, rv);
}
- SvPADMY_on((SV*)func);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
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 & padadd_OUR;
"\"%s\" %s %"SVf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
*SvPVX(sv) == '&' ? "subroutine" : "variable",
- sv,
+ SVfARG(sv),
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
? "scope" : "statement"));
--off;
&& sv_eq(name, sv))
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"our\" variable %"SVf" redeclared", sv);
+ "\"our\" variable %"SVf" redeclared", SVfARG(sv));
if ((I32)off <= PL_comppad_name_floor)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
PADOFFSET
Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
- dVAR;
SV *out_sv;
int out_flags;
I32 offset;
if ((PADOFFSET)offset != NOT_IN_PAD)
return offset;
+ /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
+ */
+ if (*namepv == '&') return NOT_IN_PAD;
+
/* 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 = PadlistARRAY(CvPADLIST(PL_compcv))[0];
name_svp = AvARRAY(nameav);
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (namesv && PadnameLEN(namesv) == namelen
&& !SvFAKE(namesv)
PADOFFSET
Perl_find_rundefsvoffset(pTHX)
{
- dVAR;
SV *out_sv;
int out_flags;
return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
/*
=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
+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.
Returns the offset in the bottom pad of the lex or the fake lex.
cv is the CV in which to start the search, and seq is the current cop_seq
-to match against. If warn is true, print appropriate warnings. The out_*
+to match against. If warn is true, print appropriate warnings. The out_*
vars return values, and so are pointers to where the returned values
-should be stored. out_capture, if non-null, requests that the innermost
+should be stored. out_capture, if non-null, requests that the innermost
instance of the lexical is captured; out_name_sv is set to the innermost
matched namesv or fake namesv; out_flags returns the flags normally
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
+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 xlow the index into
the parent pad.
*SvPVX_const(namesv) == '&'
? "Subroutin"
: "Variabl",
- namesv);
+ SVfARG(namesv));
}
STATIC PADOFFSET
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;
SV *new_capture;
SV **new_capturep;
const AV * const nameav = PadlistARRAY(padlist)[0];
SV * const * const name_svp = AvARRAY(nameav);
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (namesv && PadnameLEN(namesv) == namelen
&& sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
fake_offset = offset; /* in case we don't find a real one */
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;
+ if (PadnameIN_SCOPE(namesv, seq))
+ break;
}
}
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" will not stay shared",
- newSVpvn_flags(namepv, namelen,
+ SVfARG(newSVpvn_flags(namepv, namelen,
SVs_TEMP |
- (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
}
if (fake_offset && CvANON(cv)
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
- dVAR;
ASSERT_CURPAD_ACTIVE("pad_sv");
if (!po)
void
Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_PAD_SETSV;
ASSERT_CURPAD_ACTIVE("pad_setsv");
void
Perl_pad_block_start(pTHX_ int full)
{
- dVAR;
ASSERT_CURPAD_ACTIVE("pad_block_start");
SAVEI32(PL_comppad_name_floor);
PL_comppad_name_floor = AvFILLp(PL_comppad_name);
PL_min_intro_pending = 0;
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_padix_floor);
+ /* PL_padix_floor is what PL_padix is reset to at the start of each
+ statement, by pad_reset(). We set it when entering a new scope
+ to keep things like this working:
+ print "$foo$bar", do { this(); that() . "foo" };
+ We must not let "$foo$bar" and the later concatenation share the
+ same target. */
PL_padix_floor = PL_padix;
PL_pad_reset_pending = FALSE;
}
/*
-=for apidoc m|U32|intro_my
+=for apidoc Am|U32|intro_my
-"Introduce" my variables to visible status. This is called during parsing
-at the end of each statement to make lexical variables visible to
-subsequent statements.
+"Introduce" C<my> variables to visible status. This is called during parsing
+at the end of each statement to make lexical variables visible to subsequent
+statements.
=cut
*/
U32
Perl_intro_my(pTHX)
{
- dVAR;
SV **svp;
I32 i;
U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
+ if (PL_compiling.cop_seq) {
+ seq = PL_compiling.cop_seq;
+ PL_compiling.cop_seq = 0;
+ }
+ else
+ seq = PL_cop_seqmax;
if (! PL_min_intro_pending)
- return PL_cop_seqmax;
+ return seq;
svp = AvARRAY(PL_comppad_name);
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
);
}
}
- seq = PL_cop_seqmax;
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
PL_min_intro_pending = 0;
PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
OP *
Perl_pad_leavemy(pTHX)
{
- dVAR;
I32 off;
OP *o = NULL;
SV * const * const svp = AvARRAY(PL_comppad_name);
}
}
}
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
return o;
void
Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
{
- dVAR;
ASSERT_CURPAD_LEGAL("pad_swipe");
if (!PL_curpad)
return;
"Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
- if (PL_curpad[po])
- SvPADTMP_off(PL_curpad[po]);
if (refadjust)
SvREFCNT_dec(PL_curpad[po]);
/* if pad tmps aren't shared between ops, then there's no need to
* create a new tmp when an existing op is freed */
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
PL_curpad[po] = newSV(0);
SvPADTMP_on(PL_curpad[po]);
#else
- PL_curpad[po] = &PL_sv_undef;
+ PL_curpad[po] = NULL;
#endif
if (PadnamelistMAX(PL_comppad_name) != -1
- && PadnamelistMAX(PL_comppad_name) >= po) {
- assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
+ && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
+ if (PadnamelistARRAY(PL_comppad_name)[po]) {
+ assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
+ }
PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
}
- if ((I32)po < PL_padix)
- PL_padix = po - 1;
+ /* Use PL_constpadix here, not PL_padix. The latter may have been
+ reset by pad_reset. We don’t want pad_alloc to have to scan the
+ whole pad when allocating a constant. */
+ if ((I32)po < PL_constpadix)
+ PL_constpadix = po - 1;
}
/*
=cut
*/
-/* XXX pad_reset() is currently disabled because it results in serious bugs.
- * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
- * on the stack by OPs that use them, there are several ways to get an alias
- * 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 */
+/* pad_reset() causes pad temp TARGs (operator targets) to be shared
+ * between OPs from different statements. During compilation, at the start
+ * of each statement pad_reset resets PL_padix back to its previous value.
+ * When allocating a target, pad_alloc begins its scan through the pad at
+ * PL_padix+1. */
static void
S_pad_reset(pTHX)
{
- dVAR;
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
AvARRAY(PL_comppad), PL_curpad);
);
if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
- I32 po;
- for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
- if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
- SvPADTMP_off(PL_curpad[po]);
- }
PL_padix = PL_padix_floor;
}
#endif
av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
if (type == padtidy_SUBCLONE) {
- SV * const * const namep = AvARRAY(PL_comppad_name);
+ SV ** const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
SV *namesv;
+ if (!namep[ix]) namep[ix] = &PL_sv_undef;
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
- continue;
/*
* The only things that a clonable function needs in its
- * pad are anonymous subs.
+ * pad are anonymous subs, constants and GVs.
* The rest are created anew during cloning.
*/
- if (!((namesv = namep[ix]) != NULL &&
- namesv != &PL_sv_undef &&
- *SvPVX_const(namesv) == '&'))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
+ continue;
+ namesv = namep[ix];
+ if (!(PadnamePV(namesv) &&
+ (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
{
SvREFCNT_dec(PL_curpad[ix]);
PL_curpad[ix] = NULL;
}
if (type == padtidy_SUB || type == padtidy_FORMAT) {
- SV * const * const namep = AvARRAY(PL_comppad_name);
+ SV ** const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+ if (!namep[ix]) namep[ix] = &PL_sv_undef;
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
continue;
- if (!SvPADMY(PL_curpad[ix])) {
- SvPADTMP_on(PL_curpad[ix]);
- } else if (!SvFAKE(namep[ix])) {
+ if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
/* This is a work around for how the current implementation of
?{ } blocks in regexps interacts with lexicals.
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
- dVAR;
+#ifndef USE_PAD_RESET
SV *sv;
+#endif
ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
return;
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
);
-
+#ifndef USE_PAD_RESET
sv = PL_curpad[po];
if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
SvFLAGS(sv) &= ~SVs_PADTMP;
if ((I32)po < PL_padix)
PL_padix = po - 1;
+#endif
}
/*
void
Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
{
- dVAR;
const AV *pad_name;
const AV *pad;
SV **pname;
STATIC void
S_cv_dump(pTHX_ const CV *cv, const char *title)
{
- dVAR;
const CV * const outside = CvOUTSIDE(cv);
PADLIST* const padlist = CvPADLIST(cv);
static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
-static void
+static CV *
S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
{
- dVAR;
I32 ix;
PADLIST* const protopadlist = CvPADLIST(proto);
PAD *const protopad_name = *PadlistARRAY(protopadlist);
SAVESPTR(PL_comppad_name);
PL_comppad_name = protopad_name;
- CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
av_fill(PL_comppad, fpad);
SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
SV *sv = NULL;
if (namesv && PadnameLEN(namesv)) { /* lexical */
+ if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
+ NOOP;
+ }
+ else {
if (SvFAKE(namesv)) { /* lexical from outside? */
/* formats may have an inactive, or even undefined, parent;
but state vars are always available. */
assert(SvTYPE(ppad[ix]) == SVt_PVCV);
subclones = 1;
sv = newSV_type(SVt_PVCV);
+ CvLEXICAL_on(sv);
}
else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
{
/* my sub */
/* Just provide a stub, but name it. It will be
upgrade to the real thing on scope entry. */
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, SvPVX_const(namesv)+1,
+ SvCUR(namesv) - 1);
sv = newSV_type(SVt_PVCV);
CvNAME_HEK_set(
sv,
share_hek(SvPVX_const(namesv)+1,
SvCUR(namesv) - 1
* (SvUTF8(namesv) ? -1 : 1),
- 0)
+ hash)
);
+ CvLEXICAL_on(sv);
}
else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
sv = MUTABLE_SV(newHV());
else
sv = newSV(0);
- SvPADMY_on(sv);
/* reset the 'assign only once' flag on each state var */
if (sigil != '&' && SvPAD_STATE(namesv))
SvPADSTALE_on(sv);
}
+ }
}
- else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
+ else if (namesv && PadnamePV(namesv)) {
sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
if (newcv) SvREFCNT_inc_simple_void_NN(cv);
LEAVE;
+
+ if (CvCONST(cv)) {
+ /* Constant sub () { $x } closing over $x:
+ * The prototype was marked as a candiate for const-ization,
+ * so try to grab the current const value, and if successful,
+ * turn into a const sub:
+ */
+ SV* const_sv;
+ OP *o = CvSTART(cv);
+ assert(newcv);
+ for (; o; o = o->op_next)
+ if (o->op_type == OP_PADSV)
+ break;
+ ASSUME(o->op_type == OP_PADSV);
+ const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+ /* the candidate should have 1 ref from this pad and 1 ref
+ * from the parent */
+ if (const_sv && SvREFCNT(const_sv) == 2) {
+ const bool was_method = cBOOL(CvMETHOD(cv));
+ bool copied = FALSE;
+ if (outside) {
+ PADNAME * const pn =
+ PadlistNAMESARRAY(CvPADLIST(outside))
+ [PARENT_PAD_INDEX(PadlistNAMESARRAY(
+ CvPADLIST(cv))[o->op_targ])];
+ assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
+ [o->op_targ]));
+ if (PadnameLVALUE(pn)) {
+ /* We have a lexical that is potentially modifiable
+ elsewhere, so making a constant will break clo-
+ sure behaviour. If this is a ‘simple lexical
+ op tree’, i.e., sub(){$x}, emit a deprecation
+ warning, but continue to exhibit the old behav-
+ iour of making it a constant based on the ref-
+ count of the candidate variable.
+
+ A simple lexical op tree looks like this:
+
+ leavesub
+ lineseq
+ nextstate
+ padsv
+ */
+ if (OP_SIBLING(
+ cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
+ ) == o
+ && !OP_SIBLING(o))
+ {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_DEPRECATED),
+ "Constants from lexical "
+ "variables potentially "
+ "modified elsewhere are "
+ "deprecated");
+ /* We *copy* the lexical variable, and donate the
+ copy to newCONSTSUB. Yes, this is ugly, and
+ should be killed. We need to do this for the
+ time being, however, because turning on SvPADTMP
+ on a lexical will have observable effects
+ elsewhere. */
+ const_sv = newSVsv(const_sv);
+ copied = TRUE;
+ }
+ else
+ goto constoff;
+ }
+ }
+ if (!copied)
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ /* If the lexical is not used elsewhere, it is safe to turn on
+ SvPADTMP, since it is only when it is used in lvalue con-
+ text that the difference is observable. */
+ SvPADTMP_on(const_sv);
+ SvREFCNT_dec_NN(cv);
+ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+ if (was_method)
+ CvMETHOD_on(cv);
+ }
+ else {
+ constoff:
+ CvCONST_off(cv);
+ }
+ }
+
+ return cv;
}
static CV *
S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
const bool newcv = !cv;
assert(!CvUNIQUE(proto));
if (SvMAGIC(proto))
mg_copy((SV *)proto, (SV *)cv, 0, 0);
- if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+ if (CvPADLIST(proto))
+ cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
cv_dump(cv, "To");
);
- if (CvCONST(cv)) {
- /* Constant sub () { $x } closing over $x - see lib/constant.pm:
- * The prototype was marked as a candiate for const-ization,
- * so try to grab the current const value, and if successful,
- * turn into a const sub:
- */
- SV* const const_sv = op_const_sv(CvSTART(cv), cv);
- if (const_sv) {
- SvREFCNT_dec_NN(cv);
- /* For this calling case, op_const_sv returns a *copy*, which we
- donate to newCONSTSUB. Yes, this is ugly, and should be killed.
- Need to fix how lib/constant.pm works to eliminate this. */
- cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
- }
- else {
- CvCONST_off(cv);
- }
- }
-
return cv;
}
}
/*
+=for apidoc cv_name
+
+Returns an SV containing the name of the CV, mainly for use in error
+reporting. The CV may actually be a GV instead, in which case the returned
+SV holds the GV's name. Anything other than a GV or CV is treated as a
+string already holding the sub name, but this could change in the future.
+
+An SV may be passed as a second argument. If so, the name will be assigned
+to it and it will be returned. Otherwise the returned SV will be a new
+mortal.
+
+If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
+included. If the first argument is neither a CV nor a GV, this flag is
+ignored (subject to change).
+
+=cut
+*/
+
+SV *
+Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
+{
+ PERL_ARGS_ASSERT_CV_NAME;
+ if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
+ if (sv) sv_setsv(sv,(SV *)cv);
+ return sv ? (sv) : (SV *)cv;
+ }
+ {
+ SV * const retsv = sv ? (sv) : sv_newmortal();
+ if (SvTYPE(cv) == SVt_PVCV) {
+ if (CvNAMED(cv)) {
+ if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
+ sv_sethek(retsv, CvNAME_HEK(cv));
+ else {
+ sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+ sv_catpvs(retsv, "::");
+ sv_cathek(retsv, CvNAME_HEK(cv));
+ }
+ }
+ else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
+ sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
+ else gv_efullname3(retsv, CvGV(cv), NULL);
+ }
+ else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
+ else gv_efullname3(retsv,(GV *)cv,NULL);
+ return retsv;
+ }
+}
+
+/*
=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
+old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
moved to a pre-existing CV struct.
=cut
void
Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
{
- dVAR;
I32 ix;
AV * const comppad_name = PadlistARRAY(padlist)[0];
AV * const comppad = PadlistARRAY(padlist)[1];
void
Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
- dVAR;
-
PERL_ARGS_ASSERT_PAD_PUSH;
if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
else
sv = newSV(0);
av_store(newpad, ix, sv);
- SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (PadnamePV(names[ix])) {
av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
HV *
Perl_pad_compname_type(pTHX_ const PADOFFSET po)
{
- dVAR;
- SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
- if ( SvPAD_TYPED(*av) ) {
- return SvSTASH(*av);
+ SV* const av = PAD_COMPNAME_SV(po);
+ if ( SvPAD_TYPED(av) ) {
+ return SvSTASH(av);
}
return NULL;
}
PERL_ARGS_ASSERT_PADLIST_DUP;
- if (!srcpad)
- return NULL;
-
cloneall = param->flags & CLONEf_COPY_STACKS
|| SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
for ( ;ix > 0; ix--) {
if (!oldpad[ix]) {
pad1a[ix] = NULL;
- } else if (names_fill >= ix && PadnameLEN(names[ix])) {
+ } else if (names_fill >= ix && names[ix] &&
+ PadnameLEN(names[ix])) {
const char sigil = SvPVX_const(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE)
|| (SvFLAGS(names[ix]) & SVpad_STATE)
else
sv = newSV(0);
pad1a[ix] = sv;
- SvPADMY_on(sv);
}
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (( names_fill >= ix && names[ix]
+ && PadnamePV(names[ix]) )) {
pad1a[ix] = sv_dup_inc(oldpad[ix], param);
}
else {
/* 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
+ if (SvPADTMP(oldpad[ix]))
SvPADTMP_on(sv);
}
}
PAD **
Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
{
- dVAR;
PAD **ary;
SSize_t const oldmax = PadlistMAX(padlist);
https://perl5.git.perl.org / perl5.git / blobdiff