/* pad.c
*
- * Copyright (c) 2002, Larry Wall
+ * Copyright (C) 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/*
=head1 Pad Data Structures
+This file contains the functions that create and manipulate scratchpads,
+which are array-of-array data structures attached to a CV (ie a sub)
+and which store lexical variables and opcode temporary and per-thread
+values.
+
=for apidoc m|AV *|CvPADLIST|CV *cv
CV's can have CvPADLIST(cv) set to point to an AV.
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
-executing).
+executing). Require'd files are simply evals without any outer lexical
+scope.
XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
but that is really the callers pad (a slot of which is allocated by
every entersub).
The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
-is managed "manual" (mostly in op.c) rather than normal av.c rules.
+is managed "manual" (mostly in pad.c) rather than normal av.c rules.
The items in the AV are not SVs as for a normal AV, but other AVs:
0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
other entries are storage for variables and op targets.
During compilation:
-C<PL_comppad_name> is set the the the names AV.
-C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
+C<PL_comppad_name> is set to the names AV.
+C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
+C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
+
+During execution, C<PL_comppad> and C<PL_curpad> refer to the live
+frame of the currently executing sub.
-Itterating over the names AV itterates over all possible pad
+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()).
The SVs in the names AV have their PV being the name of the variable.
NV+1..IV inclusive is a range of cop_seq numbers for which the name is
valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
-type. For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
-stash of the associated global (so that duplicate C<our> delarations in the
-same package can be detected). SvCUR is sometimes hijacked to
-store the generation number during compilation.
-
-If SvFAKE is set on the name SV then slot in the frame AVs are
-a REFCNT'ed references to a lexical from "outside".
-
-If the 'name' is '&' the the corresponding entry in frame AV
+type. For C<our> lexicals, the type is also SVt_PVMG, with the OURSTASH slot
+pointing at the stash of the associated global (so that duplicate C<our>
+declarations in the same package can be detected). SvCUR is sometimes
+hijacked to store the generation number during compilation.
+
+If SvFAKE is set on the name SV, then that slot in the frame AV is
+a REFCNT'ed reference to a lexical from "outside". In this case,
+the name SV does not use NVX and IVX to store a cop_seq range, since it is
+in scope throughout. Instead IVX stores some flags containing info about
+the real lexical (is it declared in an anon, and is it capable of being
+instantiated multiple times?), and for fake ANONs, NVX contains the index
+within the parent's pad where the lexical's value is stored, to make
+cloning quicker.
+
+If the 'name' is '&' the corresponding entry in frame AV
is a CV representing a possible closure.
(SvFAKE and name of '&' is not a meaningful combination currently but could
become so if C<my sub foo {}> 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,
+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();
+
=cut
*/
#include "EXTERN.h"
#define PERL_IN_PAD_C
#include "perl.h"
+#include "keywords.h"
#define PAD_MAX 999999999
-
+#ifdef PERL_MAD
+void pad_peg(const char* s) {
+ static int pegcnt;
+ pegcnt++;
+}
+#endif
/*
=for apidoc pad_new
*/
PADLIST *
-Perl_pad_new(pTHX_ padnew_flags flags)
+Perl_pad_new(pTHX_ int flags)
{
- AV *padlist, *padname, *pad, *a0;
+ dVAR;
+ AV *padlist, *padname, *pad;
+
+ ASSERT_CURPAD_LEGAL("pad_new");
/* XXX DAPM really need a new SAVEt_PAD which restores all or most
* vars (based on flags) rather than storing vals + addresses for
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
SAVEI32(PL_max_intro_pending);
+ SAVEI32(PL_cv_has_eval);
if (flags & padnew_SAVESUB) {
SAVEI32(PL_pad_reset_pending);
}
* dispensed with eventually ???
*/
- a0 = newAV(); /* will be @_ */
+ AV * const a0 = newAV(); /* will be @_ */
av_extend(a0, 0);
av_store(pad, 0, (SV*)a0);
- AvFLAGS(a0) = AVf_REIFY;
+ AvREIFY_only(a0);
}
else {
-#ifdef USE_5005THREADS
- av_store(padname, 0, newSVpvn("@_", 2));
- a0 = newAV();
- SvPADMY_on((SV*)a0); /* XXX Needed? */
- av_store(pad, 0, (SV*)a0);
-#else
- av_store(pad, 0, Nullsv);
-#endif /* USE_THREADS */
+ av_store(pad, 0, NULL);
}
AvREAL_off(padlist);
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
+ PL_cv_has_eval = 0;
}
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
+ "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
" name=0x%"UVxf" flags=0x%"UVxf"\n",
- PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
PTR2UV(padname), (UV)flags
)
);
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 outercv.
+inner subs to the outer of this cv.
+
+(This function should really be called pad_free, but the name was already
+taken)
=cut
*/
void
-Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
+Perl_pad_undef(pTHX_ CV* cv)
{
+ dVAR;
I32 ix;
- PADLIST *padlist = CvPADLIST(cv);
+ const PADLIST * const padlist = CvPADLIST(cv);
+ pad_peg("pad_undef");
if (!padlist)
return;
- if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
+ if (SvIS_FREED(padlist)) /* may be during global destruction */
return;
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
+ "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(padlist))
);
- /* pads may be cleared out already during global destruction */
- if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
- && !PL_dirty) || CvSPECIAL(cv))
- {
- /* XXX DAPM the following code is very similar to
- * pad_fixup_inner_anons(). Merge??? */
-
- /* inner references to eval's cv must be fixed up */
- AV *comppad_name = (AV*)AvARRAY(padlist)[0];
- SV **namepad = AvARRAY(comppad_name);
- AV *comppad = (AV*)AvARRAY(padlist)[1];
- SV **curpad = AvARRAY(comppad);
+ /* detach any '&' anon children in the pad; if afterwards they
+ * are still live, fix up their CvOUTSIDEs to point to our outside,
+ * bypassing us. */
+ /* XXX DAPM for efficiency, we should only do this if we know we have
+ * children, or integrate this loop with general cleanup */
+
+ if (!PL_dirty) { /* don't bother during global destruction */
+ CV * const outercv = CvOUTSIDE(cv);
+ const U32 seq = CvOUTSIDE_SEQ(cv);
+ AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
+ SV ** const namepad = AvARRAY(comppad_name);
+ AV * const comppad = (AV*)AvARRAY(padlist)[1];
+ SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV *namesv = namepad[ix];
+ SV * const namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&'
- && ix <= AvFILLp(comppad))
+ && *SvPVX_const(namesv) == '&')
{
- CV *innercv = (CV*)curpad[ix];
- if (innercv && SvTYPE(innercv) == SVt_PVCV
- && CvOUTSIDE(innercv) == cv)
- {
- CvOUTSIDE(innercv) = outercv;
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(outercv);
- if (SvREFCNT(cv))
- SvREFCNT_dec(cv);
+ CV * const innercv = (CV*)curpad[ix];
+ U32 inner_rc = SvREFCNT(innercv);
+ assert(inner_rc);
+ namepad[ix] = NULL;
+ SvREFCNT_dec(namesv);
+
+ if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
+ curpad[ix] = NULL;
+ SvREFCNT_dec(innercv);
+ inner_rc--;
+ }
+
+ /* 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* sv = AvARRAY(padlist)[ix--];
- if (!sv)
- continue;
- if (sv == (SV*)PL_comppad_name)
- PL_comppad_name = Nullav;
- else if (sv == (SV*)PL_comppad) {
- PL_comppad = Nullav;
- PL_curpad = Null(SV**);
+ const SV* const sv = AvARRAY(padlist)[ix--];
+ if (sv) {
+ if (sv == (SV*)PL_comppad_name)
+ PL_comppad_name = NULL;
+ else if (sv == (SV*)PL_comppad) {
+ PL_comppad = NULL;
+ PL_curpad = NULL;
+ }
}
SvREFCNT_dec(sv);
}
SvREFCNT_dec((SV*)CvPADLIST(cv));
- CvPADLIST(cv) = Null(PADLIST*);
+ CvPADLIST(cv) = NULL;
}
/*
=for apidoc pad_add_name
-Create a new name in the current pad at the specified offset.
+Create a new name and associated PADMY SV in the current pad; return the
+offset.
If C<typestash> is valid, the name is for a typed lexical; set the
name's stash to that value.
If C<ourstash> is valid, it's an our lexical, set the name's
-GvSTASH to that value
-
-Also, if the name is @.. or %.., create a new array or hash for that slot
+OURSTASH to that value
If fake, it means we're cloning an existing entry
=cut
*/
-/*
- * XXX DAPM this doesn't seem the right place to create a new array/hash.
- * Whatever we do, we should be consistent - create scalars too, and
- * create even if fake. Really need to integrate better the whole entry
- * creation business - when + where does the name and value get created?
- */
-
PADOFFSET
-Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
+Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
{
- PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
- SV* namesv = NEWSV(1102, 0);
- U32 min, max;
+ dVAR;
+ const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
+ SV* const namesv = newSV(0);
- if (fake) {
- min = PL_curcop->cop_seq;
- max = PAD_MAX;
- }
- else {
- /* not yet introduced */
- min = PAD_MAX;
- max = 0;
- }
+ ASSERT_CURPAD_ACTIVE("pad_add_name");
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
- (long)offset, name, (unsigned long)min, (unsigned long)max,
- (fake ? " FAKE" : "")
- )
- );
- sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
+ sv_upgrade(namesv, (ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
sv_setpv(namesv, name);
if (typestash) {
- SvFLAGS(namesv) |= SVpad_TYPED;
- SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
+ assert(SvTYPE(namesv) == SVt_PVMG);
+ SvPAD_TYPED_on(namesv);
+ SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));
}
if (ourstash) {
- SvFLAGS(namesv) |= SVpad_OUR;
- GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
+ SvPAD_OUR_on(namesv);
+ OURSTASH_set(namesv, ourstash);
+ SvREFCNT_inc_simple_void_NN(ourstash);
+ }
+ else if (state) {
+ SvPAD_STATE_on(namesv);
}
av_store(PL_comppad_name, offset, namesv);
- SvNVX(namesv) = (NV)min;
- SvIVX(namesv) = max;
- if (fake)
+ if (fake) {
SvFAKE_on(namesv);
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
+ }
else {
+ /* not yet introduced */
+ SvNV_set(namesv, (NV)PAD_MAX); /* min */
+ SvIV_set(namesv, 0); /* max */
+
if (!PL_min_intro_pending)
PL_min_intro_pending = offset;
PL_max_intro_pending = offset;
+ /* if it's not a simple scalar, replace with an AV or HV */
+ /* XXX DAPM since slot has been allocated, replace
+ * av_store with PL_curpad[offset] ? */
if (*name == '@')
av_store(PL_comppad, offset, (SV*)newAV());
else if (*name == '%')
av_store(PL_comppad, offset, (SV*)newHV());
SvPADMY_on(PL_curpad[offset]);
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
+ (long)offset, name, PTR2UV(PL_curpad[offset])));
}
return offset;
Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
-for a slot which has no name and and no active value.
+for a slot which has no name and no active value.
=cut
*/
/* XXX DAPM integrate alloc(), add_name() and add_anon(),
* or at least rationalise ??? */
-
+/* And flag whether the incoming name is UTF8 or 8 bit?
+ Could do this either with the +ve/-ve hack of the HV code, or expanding
+ the flag bits. Either way, this makes proper Unicode safe pad support.
+ Also could change the sv structure to make the NV a union with 2 U32s,
+ so that SvCUR() could stop being overloaded in pad SVs.
+ NWC
+*/
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
+ dVAR;
SV *sv;
I32 retval;
+ PERL_UNUSED_ARG(optype);
+ ASSERT_CURPAD_ACTIVE("pad_alloc");
+
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_alloc");
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
- do {
- sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
- } while (SvPADBUSY(sv)); /* need a fresh one */
+ sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
retval = AvFILLp(PL_comppad);
}
else {
- SV **names = AvARRAY(PL_comppad_name);
- SSize_t names_fill = AvFILLp(PL_comppad_name);
+ SV * const * const names = AvARRAY(PL_comppad_name);
+ const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
/*
* "foreach" index vars temporarily become aliases to non-"my"
"Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
PL_op_name[optype]));
+#ifdef DEBUG_LEAKING_SCALARS
+ sv->sv_debug_optype = optype;
+ sv->sv_debug_inpad = 1;
+#endif
return (PADOFFSET)retval;
}
PADOFFSET
Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
{
+ dVAR;
PADOFFSET ix;
- SV* name;
-
- name = NEWSV(1106, 0);
+ SV* const name = newSV(0);
+ pad_peg("add_anon");
sv_upgrade(name, SVt_PVNV);
sv_setpvn(name, "&", 1);
- SvIVX(name) = -1;
- SvNVX(name) = 1;
+ SvIV_set(name, -1);
+ SvNV_set(name, 1);
ix = pad_alloc(op_type, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
+ /* XXX DAPM use PL_curpad[] ? */
av_store(PL_comppad, ix, sv);
SvPADMY_on(sv);
+
+ /* to avoid ref loops, we never have parent + child referencing each
+ * other simultaneously */
+ if (CvOUTSIDE((CV*)sv)) {
+ assert(!CvWEAKOUTSIDE((CV*)sv));
+ CvWEAKOUTSIDE_on((CV*)sv);
+ SvREFCNT_dec(CvOUTSIDE((CV*)sv));
+ }
return ix;
}
/* XXX DAPM integrate this into pad_add_name ??? */
void
-Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
+Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
{
- SV **svp, *sv;
+ dVAR;
+ SV **svp;
PADOFFSET top, off;
- if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
+ ASSERT_CURPAD_ACTIVE("pad_check_dup");
+ if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
return; /* nothing to check */
svp = AvARRAY(PL_comppad_name);
/* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
* type ? */
for (off = top; (I32)off > PL_comppad_name_floor; off--) {
- if ((sv = svp[off])
+ SV * const sv = svp[off];
+ if (sv
&& sv != &PL_sv_undef
+ && !SvFAKE(sv)
&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
- && (!is_our
- || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
- && strEQ(name, SvPVX(sv)))
+ && strEQ(name, SvPVX_const(sv)))
{
+ if (is_our && (SvPAD_OUR(sv)))
+ break; /* "our" masking "our" */
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" variable %s masks earlier declaration in same %s",
- (is_our ? "our" : "my"),
+ (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),
name,
(SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
--off;
/* check the rest of the pad */
if (is_our) {
do {
- if ((sv = svp[off])
+ SV * const sv = svp[off];
+ if (sv
&& sv != &PL_sv_undef
+ && !SvFAKE(sv)
&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
- && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
- && strEQ(name, SvPVX(sv)))
+ && OURSTASH(sv) == ourstash
+ && strEQ(name, SvPVX_const(sv)))
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"our\" variable %s redeclared", name);
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean \"local\" instead of \"our\"?)\n");
+ if ((I32)off <= PL_comppad_name_floor)
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "\t(Did you mean \"local\" instead of \"our\"?)\n");
break;
}
} while ( off-- > 0 );
}
-
/*
=for apidoc pad_findmy
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ char *name)
+Perl_pad_findmy(pTHX_ const char *name)
{
- I32 off;
- I32 pendoff = 0;
- SV *sv;
- SV **svp = AvARRAY(PL_comppad_name);
- U32 seq = PL_cop_seqmax;
- PERL_CONTEXT *cx;
- CV *outside;
-
- DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
-
-#ifdef USE_5005THREADS
- /*
- * Special case to get lexical (and hence per-thread) @_.
- * XXX I need to find out how to tell at parse-time whether use
- * of @_ should refer to a lexical (from a sub) or defgv (global
- * scope and maybe weird sub-ish things like formats). See
- * startsub in perly.y. It's possible that @_ could be lexical
- * (at least from subs) even in non-threaded perl.
- */
- if (strEQ(name, "@_"))
- return 0; /* success. (NOT_IN_PAD indicates failure) */
-#endif /* USE_5005THREADS */
-
- /* The one we're looking for is probably just before comppad_name_fill. */
- for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
- if ((sv = svp[off]) &&
- sv != &PL_sv_undef &&
- (!SvIVX(sv) ||
- (seq <= (U32)SvIVX(sv) &&
- seq > (U32)I_32(SvNVX(sv)))) &&
- strEQ(SvPVX(sv), name))
- {
- if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
- return (PADOFFSET)off;
- pendoff = off; /* this pending def. will override import */
- }
- }
-
- outside = CvOUTSIDE(PL_compcv);
-
- /* Check if if we're compiling an eval'', and adjust seq to be the
- * eval's seq number. This depends on eval'' having a non-null
- * CvOUTSIDE() while it is being compiled. The eval'' itself is
- * identified by CvEVAL being true and CvGV being null. */
- if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
- cx = &cxstack[cxstack_ix];
- if (CxREALEVAL(cx))
- seq = cx->blk_oldcop->cop_seq;
+ dVAR;
+ SV *out_sv;
+ int out_flags;
+ I32 offset;
+ const AV *nameav;
+ SV **name_svp;
+
+ pad_peg("pad_findmy");
+ offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
+ NULL, &out_sv, &out_flags);
+ if ((PADOFFSET)offset != NOT_IN_PAD)
+ return offset;
+
+ /* look for an our that's being introduced; this allows
+ * our $foo = 0 unless defined $foo;
+ * to not give a warning. (Yes, this is a hack) */
+
+ nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+ name_svp = AvARRAY(nameav);
+ for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ const SV * const namesv = name_svp[offset];
+ if (namesv && namesv != &PL_sv_undef
+ && !SvFAKE(namesv)
+ && (SvPAD_OUR(namesv))
+ && strEQ(SvPVX_const(namesv), name)
+ && U_32(SvNVX(namesv)) == PAD_MAX /* min */
+ )
+ return offset;
}
-
- /* See if it's in a nested scope */
- off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
- if (!off) /* pad_findlex returns 0 for failure...*/
- return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
-
- /* If there is a pending local definition, this new alias must die */
- if (pendoff)
- SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
- return off;
+ return NOT_IN_PAD;
}
+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */
+PADOFFSET
+Perl_find_rundefsvoffset(pTHX)
+{
+ dVAR;
+ SV *out_sv;
+ int out_flags;
+ return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ NULL, &out_sv, &out_flags);
+}
/*
=for apidoc pad_findlex
Find a named lexical anywhere in a chain of nested pads. Add fake entries
-in the inner pads if its found in an outer one.
-
-If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
+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_*
+vars return values, and so are pointers to where the returned values
+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
+because fake namesvs in anon protoypes have to store in NVX the index into
+the parent pad.
=cut
*/
-#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
+/* Flags set in the SvIVX field of FAKE namesvs */
+
+#define PAD_FAKELEX_ANON 1 /* the lex is declared in an ANON, or ... */
+#define PAD_FAKELEX_MULTI 2 /* the lex can be instantiated multiple times */
+
+/* the CV has finished being compiled. This is not a sufficient test for
+ * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
+#define CvCOMPILED(cv) CvROOT(cv)
+
+/* the CV does late binding of its lexicals */
+#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+
STATIC PADOFFSET
-S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
- I32 cx_ix, I32 saweval, U32 flags)
+S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
+ SV** out_capture, SV** out_name_sv, int *out_flags)
{
- CV *cv;
- I32 off;
- SV *sv;
- register I32 i;
- register PERL_CONTEXT *cx;
+ dVAR;
+ I32 offset, new_offset;
+ SV *new_capture;
+ SV **new_capturep;
+ const AV * const padlist = CvPADLIST(cv);
+
+ *out_flags = 0;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
- " ix=%ld saweval=%d flags=%lu\n",
- name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
- (long)cx_ix, (int)saweval, (unsigned long)flags
- )
- );
+ "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
+ PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
- for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
- AV *curlist = CvPADLIST(cv);
- SV **svp = av_fetch(curlist, 0, FALSE);
- AV *curname;
+ /* first, search this pad */
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
- );
+ if (padlist) { /* not an undef CV */
+ I32 fake_offset = 0;
+ const AV * const nameav = (AV*)AvARRAY(padlist)[0];
+ SV * const * const name_svp = AvARRAY(nameav);
- if (!svp || *svp == &PL_sv_undef)
- continue;
- curname = (AV*)*svp;
- svp = AvARRAY(curname);
- for (off = AvFILLp(curname); off > 0; off--) {
- I32 depth;
- AV *oldpad;
- SV *oldsv;
-
- if ( ! (
- (sv = svp[off]) &&
- sv != &PL_sv_undef &&
- seq <= (U32)SvIVX(sv) &&
- seq > (U32)I_32(SvNVX(sv)) &&
- strEQ(SvPVX(sv), name))
- )
- continue;
+ 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))
+ {
+ if (SvFAKE(namesv))
+ fake_offset = offset; /* in case we don't find a real one */
+ else if ( seq > U_32(SvNVX(namesv)) /* min */
+ && seq <= (U32)SvIVX(namesv)) /* max */
+ break;
+ }
+ }
- depth = CvDEPTH(cv);
- if (!depth) {
- if (newoff) {
- if (SvFAKE(sv))
- continue;
- return 0; /* don't clone from inactive stack frame */
- }
- depth = 1;
+ if (offset > 0 || fake_offset > 0 ) { /* a match! */
+ if (offset > 0) { /* not fake */
+ fake_offset = 0;
+ *out_name_sv = name_svp[offset]; /* return the namesv */
+
+ /* set PAD_FAKELEX_MULTI if this lex can have multiple
+ * 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
+ * lexes as not multi as viewed from evals. */
+
+ *out_flags = CvANON(cv) ?
+ PAD_FAKELEX_ANON :
+ (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
+ ? PAD_FAKELEX_MULTI : 0;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
+ PTR2UV(cv), (long)offset, (long)U_32(SvNVX(*out_name_sv)),
+ (long)SvIVX(*out_name_sv)));
+ }
+ else { /* fake match */
+ offset = fake_offset;
+ *out_name_sv = name_svp[offset]; /* return the namesv */
+ *out_flags = SvIVX(*out_name_sv);
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
+ PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
+ (unsigned long)SvNVX(*out_name_sv)
+ ));
}
- oldpad = (AV*)AvARRAY(curlist)[depth];
- oldsv = *av_fetch(oldpad, off, TRUE);
+ /* return the lex? */
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- " matched: offset %ld"
- " %s(%lu,%lu), sv=0x%"UVxf"\n",
- (long)off,
- SvFAKE(sv) ? "FAKE " : "",
- (unsigned long)I_32(SvNVX(sv)),
- (unsigned long)SvIVX(sv),
- PTR2UV(oldsv)
- )
- );
+ if (out_capture) {
- if (!newoff) { /* Not a mere clone operation. */
- newoff = pad_add_name(
- SvPVX(sv),
- (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
- (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
- 1 /* fake */
- );
+ /* our ? */
+ if (SvPAD_OUR(*out_name_sv)) {
+ *out_capture = NULL;
+ return offset;
+ }
- if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
- /* "It's closures all the way down." */
- CvCLONE_on(PL_compcv);
- if (cv == startcv) {
- if (CvANON(PL_compcv))
- oldsv = Nullsv; /* no need to keep ref */
- }
- else {
- CV *bcv;
- for (bcv = startcv;
- bcv && bcv != cv && !CvCLONE(bcv);
- bcv = CvOUTSIDE(bcv))
- {
- if (CvANON(bcv)) {
- /* install the missing pad entry in intervening
- * nested subs and mark them cloneable. */
- AV *ocomppad_name = PL_comppad_name;
- AV *ocomppad = PL_comppad;
- SV **ocurpad = PL_curpad;
- AV *padlist = CvPADLIST(bcv);
- PL_comppad_name = (AV*)AvARRAY(padlist)[0];
- PL_comppad = (AV*)AvARRAY(padlist)[1];
- PL_curpad = AvARRAY(PL_comppad);
- pad_add_name(
- SvPVX(sv),
- (SvFLAGS(sv) & SVpad_TYPED)
- ? SvSTASH(sv) : Nullhv,
- (SvFLAGS(sv) & SVpad_OUR)
- ? GvSTASH(sv) : Nullhv,
- 1 /* fake */
- );
-
- PL_comppad_name = ocomppad_name;
- PL_comppad = ocomppad;
- PL_curpad = ocurpad;
- CvCLONE_on(bcv);
- }
- else {
- if (ckWARN(WARN_CLOSURE)
- && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
- {
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" may be unavailable",
- name);
- }
- break;
- }
- }
- }
+ /* trying to capture from an anon prototype? */
+ if (CvCOMPILED(cv)
+ ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
+ : *out_flags & PAD_FAKELEX_ANON)
+ {
+ if (warn && ckWARN(WARN_CLOSURE))
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" is not available", name);
+ *out_capture = NULL;
}
- else if (!CvUNIQUE(PL_compcv)) {
- if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
- && !(SvFLAGS(sv) & SVpad_OUR))
- {
+
+ /* real value */
+ else {
+ int newwarn = warn;
+ if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
+ && warn && ckWARN(WARN_CLOSURE)) {
+ newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" will not stay shared", name);
}
+
+ if (fake_offset && CvANON(cv)
+ && CvCLONE(cv) &&!CvCLONED(cv))
+ {
+ SV *n;
+ /* not yet caught - look further up */
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
+ PTR2UV(cv)));
+ n = *out_name_sv;
+ (void) pad_findlex(name, CvOUTSIDE(cv),
+ CvOUTSIDE_SEQ(cv),
+ newwarn, out_capture, out_name_sv, out_flags);
+ *out_name_sv = n;
+ return offset;
+ }
+
+ *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
+ CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(*out_capture)));
+
+ if (SvPADSTALE(*out_capture)) {
+ if (ckWARN(WARN_CLOSURE))
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" is not available", name);
+ *out_capture = NULL;
+ }
+ }
+ if (!*out_capture) {
+ if (*name == '@')
+ *out_capture = sv_2mortal((SV*)newAV());
+ else if (*name == '%')
+ *out_capture = sv_2mortal((SV*)newHV());
+ else
+ *out_capture = sv_newmortal();
}
}
- av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
- (long)newoff, PTR2UV(oldsv)
- )
- );
- return newoff;
+
+ return offset;
}
}
- if (flags & FINDLEX_NOSEARCH)
- return 0;
+ /* it's not in this pad - try above */
- /* Nothing in current lexical context--try eval's context, if any.
- * This is necessary to let the perldb get at lexically scoped variables.
- * XXX This will also probably interact badly with eval tree caching.
- */
+ if (!CvOUTSIDE(cv))
+ return NOT_IN_PAD;
- for (i = cx_ix; i >= 0; i--) {
- cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- if (i == 0 && saweval) {
- return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
- }
- break;
- case CXt_EVAL:
- switch (cx->blk_eval.old_op_type) {
- case OP_ENTEREVAL:
- if (CxREALEVAL(cx)) {
- PADOFFSET off;
- saweval = i;
- seq = cxstack[i].blk_oldcop->cop_seq;
- startcv = cxstack[i].blk_eval.cv;
- if (startcv && CvOUTSIDE(startcv)) {
- off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
- i - 1, saweval, 0);
- if (off) /* continue looking if not found here */
- return off;
- }
- }
- break;
- case OP_DOFILE:
- case OP_REQUIRE:
- /* require/do must have their own scope */
- return 0;
- }
- break;
- case CXt_FORMAT:
- case CXt_SUB:
- if (!saweval)
- return 0;
- cv = cx->blk_sub.cv;
- if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
- saweval = i; /* so we know where we were called from */
- seq = cxstack[i].blk_oldcop->cop_seq;
- continue;
- }
- return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
+ /* out_capture non-null means caller wants us to capture lex; in
+ * addition we capture ourselves unless it's an ANON/format */
+ new_capturep = out_capture ? out_capture :
+ CvLATE(cv) ? NULL : &new_capture;
+
+ offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+ new_capturep, out_name_sv, out_flags);
+ if ((PADOFFSET)offset == NOT_IN_PAD)
+ return NOT_IN_PAD;
+
+ /* found in an outer CV. Add appropriate fake entry to this pad */
+
+ /* don't add new fake entries (via eval) to CVs that we have already
+ * finished compiling, or to undef CVs */
+ if (CvCOMPILED(cv) || !padlist)
+ return 0; /* this dummy (and invalid) value isnt used by the caller */
+
+ {
+ SV *new_namesv;
+ AV * const ocomppad_name = PL_comppad_name;
+ PAD * const ocomppad = PL_comppad;
+ PL_comppad_name = (AV*)AvARRAY(padlist)[0];
+ PL_comppad = (AV*)AvARRAY(padlist)[1];
+ PL_curpad = AvARRAY(PL_comppad);
+
+ new_offset = pad_add_name(
+ SvPVX_const(*out_name_sv),
+ SvPAD_TYPED(*out_name_sv)
+ ? SvSTASH(*out_name_sv) : NULL,
+ OURSTASH(*out_name_sv),
+ 1, /* fake */
+ 0 /* not a state variable */
+ );
+
+ new_namesv = AvARRAY(PL_comppad_name)[new_offset];
+ SvIV_set(new_namesv, *out_flags);
+
+ SvNV_set(new_namesv, (NV)0);
+ if (SvPAD_OUR(new_namesv)) {
+ NOOP; /* do nothing */
}
- }
+ else if (CvLATE(cv)) {
+ /* delayed creation - just note the offset within parent pad */
+ SvNV_set(new_namesv, (NV)offset);
+ CvCLONE_on(cv);
+ }
+ else {
+ /* immediate creation - capture outer value right now */
+ av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
+ PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
+ }
+ *out_name_sv = new_namesv;
+ *out_flags = SvIVX(new_namesv);
- return 0;
+ PL_comppad_name = ocomppad_name;
+ PL_comppad = ocomppad;
+ PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
+ }
+ return new_offset;
}
+#ifdef DEBUGGING
/*
=for apidoc pad_sv
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
-#ifdef DEBUGGING
- /* for display purposes, try to guess the AV corresponding to
- * Pl_curpad */
- AV *cp = PL_comppad;
- if (cp && AvARRAY(cp) != PL_curpad)
- cp = Nullav;
-#endif
+ dVAR;
+ ASSERT_CURPAD_ACTIVE("pad_sv");
-#ifndef USE_5005THREADS
if (!po)
Perl_croak(aTHX_ "panic: pad_sv po");
-#endif
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
- PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
);
return PL_curpad[po];
}
=cut
*/
-#ifdef DEBUGGING
void
Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
{
- /* for display purposes, try to guess the AV corresponding to
- * Pl_curpad */
- AV *cp = PL_comppad;
- if (cp && AvARRAY(cp) != PL_curpad)
- cp = Nullav;
+ dVAR;
+ ASSERT_CURPAD_ACTIVE("pad_setsv");
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
- PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
);
PL_curpad[po] = sv;
}
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);
if (full)
U32
Perl_intro_my(pTHX)
{
+ dVAR;
SV **svp;
- SV *sv;
I32 i;
+ ASSERT_CURPAD_ACTIVE("intro_my");
if (! PL_min_intro_pending)
return PL_cop_seqmax;
svp = AvARRAY(PL_comppad_name);
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
- if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
- SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
- SvNVX(sv) = (NV)PL_cop_seqmax;
+ SV * const sv = svp[i];
+
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !SvIVX(sv)) {
+ SvIV_set(sv, PAD_MAX); /* Don't know scope end yet. */
+ SvNV_set(sv, (NV)PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
- (long)i, SvPVX(sv),
- (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+ "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
+ (long)i, SvPVX_const(sv),
+ (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
);
}
}
void
Perl_pad_leavemy(pTHX)
{
+ dVAR;
I32 off;
- SV **svp = AvARRAY(PL_comppad_name);
- SV *sv;
+ SV * const * const svp = AvARRAY(PL_comppad_name);
PL_pad_reset_pending = FALSE;
+ ASSERT_CURPAD_ACTIVE("pad_leavemy");
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
- if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
+ const SV * const sv = svp[off];
+ if (sv && sv != &PL_sv_undef
+ && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "%s never introduced", SvPVX(sv));
+ "%"SVf" never introduced",
+ (void*)sv);
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
- if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
- SvIVX(sv) = PL_cop_seqmax;
+ const SV * const sv = svp[off];
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX) {
+ SvIV_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
- (long)off, SvPVX(sv),
- (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+ "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
+ (long)off, SvPVX_const(sv),
+ (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
);
}
}
void
Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
{
+ dVAR;
+ ASSERT_CURPAD_LEGAL("pad_swipe");
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
if (refadjust)
SvREFCNT_dec(PL_curpad[po]);
- PL_curpad[po] = NEWSV(1107,0);
+
+ /* if pad tmps aren't shared between ops, then there's no need to
+ * create a new tmp when an existing op is freed */
+#ifdef USE_BROKEN_PAD_RESET
+ PL_curpad[po] = newSV(0);
SvPADTMP_on(PL_curpad[po]);
+#else
+ PL_curpad[po] = &PL_sv_undef;
+#endif
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
void
Perl_pad_reset(pTHX)
{
+ dVAR;
#ifdef USE_BROKEN_PAD_RESET
- register I32 po;
-
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad");
);
if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
+ register I32 po;
for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
SvPADTMP_off(PL_curpad[po]);
void
Perl_pad_tidy(pTHX_ padtidy_type type)
{
- PADOFFSET ix;
+ dVAR;
+
+ ASSERT_CURPAD_ACTIVE("pad_tidy");
+
+ /* If this CV has had any 'eval-capable' ops planted in it
+ * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
+ * anon prototypes in the chain of CVs should be marked as cloneable,
+ * 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.
+ */
+
+ if (PL_cv_has_eval || PL_perldb) {
+ const CV *cv;
+ for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
+ if (cv != PL_compcv && CvCOMPILED(cv))
+ break; /* no need to mark already-compiled code */
+ if (CvANON(cv)) {
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
+ CvCLONE_on(cv);
+ }
+ }
+ }
/* extend curpad to match namepad */
if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
- av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
+ av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
if (type == padtidy_SUBCLONE) {
- SV **namep = AvARRAY(PL_comppad_name);
+ SV * const * const namep = AvARRAY(PL_comppad_name);
+ PADOFFSET ix;
+
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
SV *namesv;
continue;
/*
* The only things that a clonable function needs in its
- * pad are references to outer lexicals and anonymous subs.
+ * pad are anonymous subs.
* The rest are created anew during cloning.
*/
- if (!((namesv = namep[ix]) != Nullsv &&
+ if (!((namesv = namep[ix]) != NULL &&
namesv != &PL_sv_undef &&
- (SvFAKE(namesv) ||
- *SvPVX(namesv) == '&')))
+ *SvPVX_const(namesv) == '&'))
{
SvREFCNT_dec(PL_curpad[ix]);
- PL_curpad[ix] = Nullsv;
+ PL_curpad[ix] = NULL;
}
}
}
else if (type == padtidy_SUB) {
/* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
- AV *av = newAV(); /* Will be @_ */
+ AV * const av = newAV(); /* Will be @_ */
av_extend(av, 0);
av_store(PL_comppad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
+ AvREIFY_only(av);
}
/* XXX DAPM rationalise these two similar branches */
if (type == padtidy_SUB) {
+ PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
}
}
else if (type == padtidy_FORMAT) {
+ PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
SvPADTMP_on(PL_curpad[ix]);
}
}
+ PL_curpad = AvARRAY(PL_comppad);
}
/*
=for apidoc pad_free
-Free the SV at offet po in the current pad.
+Free the SV at offset po in the current pad.
=cut
*/
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
+ dVAR;
+ ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
SvPADTMP_off(PL_curpad[po]);
#ifdef USE_ITHREADS
-#ifdef PERL_COPY_ON_WRITE
- if (SvIsCOW(PL_curpad[po])) {
- sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
- } else
+ /* SV could be a shared hash key (eg bugid #19022) */
+ if (
+#ifdef PERL_OLD_COPY_ON_WRITE
+ !SvIsCOW(PL_curpad[po])
+#else
+ !SvFAKE(PL_curpad[po])
#endif
+ )
SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
-
#endif
}
if ((I32)po < PL_padix)
void
Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
{
- AV *pad_name;
- AV *pad;
+ dVAR;
+ const AV *pad_name;
+ const AV *pad;
SV **pname;
SV **ppad;
- SV *namesv;
I32 ix;
if (!padlist) {
);
for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
- namesv = pname[ix];
+ const SV *namesv = pname[ix];
if (namesv && namesv == &PL_sv_undef) {
- namesv = Nullsv;
+ namesv = NULL;
}
if (namesv) {
- Perl_dump_indent(aTHX_ level+1, file,
- "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
- (int) ix,
- PTR2UV(ppad[ix]),
- (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
- SvFAKE(namesv) ? "FAKE" : " ",
- (unsigned long)I_32(SvNVX(namesv)),
- (unsigned long)SvIVX(namesv),
- SvPVX(namesv)
- );
+ if (SvFAKE(namesv))
+ Perl_dump_indent(aTHX_ level+1, file,
+ "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
+ (int) ix,
+ PTR2UV(ppad[ix]),
+ (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
+ SvPVX_const(namesv),
+ (unsigned long)SvIVX(namesv),
+ (unsigned long)SvNVX(namesv)
+
+ );
+ else
+ Perl_dump_indent(aTHX_ level+1, file,
+ "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
+ (int) ix,
+ PTR2UV(ppad[ix]),
+ (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
+ (long)U_32(SvNVX(namesv)),
+ (long)SvIVX(namesv),
+ SvPVX_const(namesv)
+ );
}
else if (full) {
Perl_dump_indent(aTHX_ level+1, file,
#ifdef DEBUGGING
STATIC void
-S_cv_dump(pTHX_ CV *cv, char *title)
+S_cv_dump(pTHX_ const CV *cv, const char *title)
{
- CV *outside = CvOUTSIDE(cv);
- AV* padlist = CvPADLIST(cv);
+ dVAR;
+ const CV * const outside = CvOUTSIDE(cv);
+ AV* const padlist = CvPADLIST(cv);
PerlIO_printf(Perl_debug_log,
" %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
title,
PTR2UV(cv),
(CvANON(cv) ? "ANON"
+ : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
: (cv == PL_main_cv) ? "MAIN"
: CvUNIQUE(cv) ? "UNIQUE"
: CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
CV *
Perl_cv_clone(pTHX_ CV *proto)
{
- CV *cv;
-
- LOCK_CRED_MUTEX; /* XXX create separate mutex */
- cv = cv_clone2(proto, CvOUTSIDE(proto));
- UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
- return cv;
-}
-
-
-/* XXX DAPM separate out cv and paddish bits ???
- * ideally the CV-related stuff shouldn't be in pad.c - how about
- * a cv.c? */
-
-STATIC CV *
-S_cv_clone2(pTHX_ CV *proto, CV *outside)
-{
+ dVAR;
I32 ix;
- AV* protopadlist = CvPADLIST(proto);
- AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
- AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
- SV** pname = AvARRAY(protopad_name);
- SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILLp(protopad_name);
- I32 fpad = AvFILLp(protopad);
- AV* comppadlist;
+ AV* const protopadlist = CvPADLIST(proto);
+ const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+ const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ SV** const pname = AvARRAY(protopad_name);
+ SV** const ppad = AvARRAY(protopad);
+ const I32 fname = AvFILLp(protopad_name);
+ const I32 fpad = AvFILLp(protopad);
CV* cv;
+ SV** outpad;
+ CV* outside;
+ long depth;
assert(!CvUNIQUE(proto));
+ /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+ * to a prototype; we instead want the cloned parent who called us.
+ * Note that in general for formats, CvOUTSIDE != find_runcv */
+
+ outside = CvOUTSIDE(proto);
+ if (outside && CvCLONE(outside) && ! CvCLONED(outside))
+ outside = find_runcv(NULL);
+ depth = CvDEPTH(outside);
+ assert(depth || SvTYPE(proto) == SVt_PVFM);
+ if (!depth)
+ depth = 1;
+ assert(CvPADLIST(outside));
+
ENTER;
SAVESPTR(PL_compcv);
- cv = PL_compcv = (CV*)NEWSV(1104, 0);
+ cv = PL_compcv = (CV*)newSV(0);
sv_upgrade((SV *)cv, SvTYPE(proto));
- CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
CvCLONED_on(cv);
-#ifdef USE_5005THREADS
- New(666, CvMUTEXP(cv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(cv));
- CvOWNER(cv) = 0;
-#endif /* USE_5005THREADS */
#ifdef USE_ITHREADS
- CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
- : savepv(CvFILE(proto));
+ CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
+ : savepv(CvFILE(proto));
#else
CvFILE(cv) = CvFILE(proto);
#endif
CvGV(cv) = CvGV(proto);
CvSTASH(cv) = CvSTASH(proto);
+ OP_REFCNT_LOCK;
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
- if (outside)
- CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
+ CvOUTSIDE(cv) = (CV*)SvREFCNT_inc_simple(outside);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
if (SvPOK(proto))
- sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
+ sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
- CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+ av_fill(PL_comppad, fpad);
for (ix = fname; ix >= 0; ix--)
av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
- av_fill(PL_comppad, fpad);
PL_curpad = AvARRAY(PL_comppad);
+ outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+
for (ix = fpad; ix > 0; ix--) {
- SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
- if (namesv && namesv != &PL_sv_undef) {
- char *name = SvPVX(namesv); /* XXX */
- if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
- I32 off = pad_findlex(name, ix, SvIVX(namesv),
- CvOUTSIDE(cv), cxstack_ix, 0, 0);
- if (!off)
- PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
- else if (off != ix)
- Perl_croak(aTHX_ "panic: cv_clone: %s", name);
+ SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+ SV *sv = NULL;
+ if (namesv && namesv != &PL_sv_undef) { /* lexical */
+ if (SvFAKE(namesv)) { /* lexical from outside? */
+ sv = outpad[(I32)SvNVX(namesv)];
+ assert(sv);
+ /* formats may have an inactive parent */
+ if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
+ if (ckWARN(WARN_CLOSURE))
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" is not available", SvPVX_const(namesv));
+ sv = NULL;
+ }
+ else {
+ assert(!SvPADSTALE(sv));
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
}
- else { /* our own lexical */
- SV* sv;
- if (*name == '&') {
- /* anon code -- we'll come back for it */
+ if (!sv) {
+ const char sigil = SvPVX_const(namesv)[0];
+ if (sigil == '&')
sv = SvREFCNT_inc(ppad[ix]);
- }
- else if (*name == '@')
+ else if (sigil == '@')
sv = (SV*)newAV();
- else if (*name == '%')
+ else if (sigil == '%')
sv = (SV*)newHV();
else
- sv = NEWSV(0, 0);
- if (!SvPADBUSY(sv))
- SvPADMY_on(sv);
- PL_curpad[ix] = sv;
+ sv = newSV(0);
+ SvPADMY_on(sv);
}
}
else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
- PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
- SV* sv = NEWSV(0, 0);
+ sv = newSV(0);
SvPADTMP_on(sv);
- PL_curpad[ix] = sv;
- }
- }
-
- /* Now that vars are all in place, clone nested closures. */
-
- for (ix = fpad; ix > 0; ix--) {
- SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
- if (namesv
- && namesv != &PL_sv_undef
- && !(SvFLAGS(namesv) & SVf_FAKE)
- && *SvPVX(namesv) == '&'
- && CvCLONE(ppad[ix]))
- {
- CV *kid = cv_clone2((CV*)ppad[ix], cv);
- SvREFCNT_dec(ppad[ix]);
- CvCLONE_on(kid);
- SvPADMY_on(kid);
- PL_curpad[ix] = (SV*)kid;
}
+ PL_curpad[ix] = sv;
}
DEBUG_Xv(
LEAVE;
if (CvCONST(cv)) {
- SV* const_sv = op_const_sv(CvSTART(cv), cv);
- assert(const_sv);
- /* constant sub () { $x } closing over $x - see lib/constant.pm */
- SvREFCNT_dec(cv);
- cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+ /* 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(cv);
+ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+ }
+ else {
+ CvCONST_off(cv);
+ }
}
return cv;
=for apidoc pad_fixup_inner_anons
For any anon CVs in the pad, change CvOUTSIDE of that CV from
-old_cv to new_cv if necessary.
+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 *comppad_name = (AV*)AvARRAY(padlist)[0];
- AV *comppad = (AV*)AvARRAY(padlist)[1];
- SV **namepad = AvARRAY(comppad_name);
- SV **curpad = AvARRAY(comppad);
+ AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV * const comppad = (AV*)AvARRAY(padlist)[1];
+ SV ** const namepad = AvARRAY(comppad_name);
+ SV ** const curpad = AvARRAY(comppad);
+ PERL_UNUSED_ARG(old_cv);
+
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV *namesv = namepad[ix];
+ const SV * const namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&')
+ && *SvPVX_const(namesv) == '&')
{
- CV *innercv = (CV*)curpad[ix];
- if (CvOUTSIDE(innercv) == old_cv) {
- CvOUTSIDE(innercv) = new_cv;
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(new_cv);
- SvREFCNT_dec(old_cv);
- }
- }
+ CV * const innercv = (CV*)curpad[ix];
+ assert(CvWEAKOUTSIDE(innercv));
+ assert(CvOUTSIDE(innercv) == old_cv);
+ CvOUTSIDE(innercv) = new_cv;
}
}
}
+
/*
=for apidoc pad_push
Push a new pad frame onto the padlist, unless there's already a pad at
-this depth, in which case don't bother creating a new one.
-If has_args is true, give the new pad an @_ in slot zero.
+this depth, in which case don't bother creating a new one. Then give
+the new pad an @_ in slot zero.
=cut
*/
void
-Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
+Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
- if (depth <= AvFILLp(padlist))
- return;
-
- {
- SV** svp = AvARRAY(padlist);
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[depth-1]);
+ dVAR;
+ if (depth > AvFILLp(padlist)) {
+ SV** const svp = AvARRAY(padlist);
+ AV* const newpad = newAV();
+ SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- SV** names = AvARRAY(svp[0]);
- SV* sv;
+ const I32 names_fill = AvFILLp((AV*)svp[0]);
+ SV** const names = AvARRAY(svp[0]);
+ AV *av;
+
for ( ;ix > 0; ix--) {
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
- char *name = SvPVX(names[ix]);
- if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
+ const char sigil = SvPVX_const(names[ix])[0];
+ if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
/* outer lexical or anon code */
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
+ SV *sv;
+ if (sigil == '@')
+ sv = (SV*)newAV();
+ else if (sigil == '%')
+ sv = (SV*)newHV();
else
- av_store(newpad, ix, sv = NEWSV(0, 0));
+ sv = newSV(0);
+ av_store(newpad, ix, sv);
SvPADMY_on(sv);
}
}
else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+ av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
/* save temporaries on recursion? */
- av_store(newpad, ix, sv = NEWSV(0, 0));
+ SV * const sv = newSV(0);
+ av_store(newpad, ix, sv);
SvPADTMP_on(sv);
}
}
- if (has_args) {
- AV* av = newAV();
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- }
+ av = newAV();
+ av_extend(av, 0);
+ av_store(newpad, 0, (SV*)av);
+ AvREIFY_only(av);
+
av_store(padlist, depth, (SV*)newpad);
AvFILLp(padlist) = depth;
}
}
+
+
+HV *
+Perl_pad_compname_type(pTHX_ const PADOFFSET po)
+{
+ dVAR;
+ SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
+ if ( SvPAD_TYPED(*av) ) {
+ return SvSTASH(*av);
+ }
+ return NULL;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */