=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
-CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's
+CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
scratchpad, which stores lexical variables and opcode temporary and
per-thread values.
-For these purposes "forms" are a kind-of CV, eval""s are too (except they're
+For these purposes "formats" 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). Require'd files are simply evals without any outer lexical
+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 pad.c) rather than normal av.c rules.
-The items in the AV are not SVs as for a normal AV, but other AVs:
+The PADLIST has a C array where pads are stored.
-0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
-the "static type information" for lexicals.
+The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
+AV, but that may change) which represents the "names" or rather
+the "static type information" for lexicals. The individual elements of a
+PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
+refactorings might stop the PADNAMELIST from being stored in the PADLIST's
+array, so don't rely on it. See L</PADLIST_NAMES>.
-The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
-depth of recursion into the CV.
-The 0'th slot of a frame AV is an AV which is @_.
-other entries are storage for variables and op targets.
+The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
+at that depth of recursion into the CV. The 0th slot of a frame AV is an
+AV which is @_. Other entries are storage for variables and op targets.
-Iterating over the names AV iterates over all possible pad
-items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
+Iterating over the PADNAMELIST 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()).
-Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
+Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
or resolved at compile time. These don't have names by which they
-can be looked up from Perl code at run time through eval"" like
+can be looked up from Perl code at run time through eval"" the way
my/our variables can be. Since they can't be looked up by "name"
but only by their index allocated at compile time (which is usually
in PL_op->op_targ), wasting a name SV for them doesn't make sense.
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
+If the 'name' is '&' the corresponding entry in the PAD
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.)
write is called (if necessary).
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
+and set on scope exit. This allows the
+'Variable $x is not available' warning
to be generated in evals, such as
{ my $x = 1; sub f { eval '$x'} } f();
-For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
+For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
-=for apidoc AmxU|AV *|PL_comppad_name
+=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
During compilation, this points to the array containing the names part
of the pad for the currently-compiling code.
-=for apidoc AmxU|AV *|PL_comppad
+=for apidoc AmxU|PAD *|PL_comppad
During compilation, this points to the array containing the values
part of the pad for the currently-compiling code. (At runtime a CV may
=for apidoc AmxU|SV **|PL_curpad
Points directly to the body of the L</PL_comppad> array.
-(I.e., this is C<AvARRAY(PL_comppad)>.)
+(I.e., this is C<PAD_ARRAY(PL_comppad)>.)
=cut
*/
Perl_pad_new(pTHX_ int flags)
{
dVAR;
- AV *padlist, *padname, *pad;
- SV **ary;
+ PADLIST *padlist;
+ PAD *padname, *pad;
+ PAD **ary;
ASSERT_CURPAD_LEGAL("pad_new");
/* ... create new pad ... */
- padlist = newAV();
+ Newxz(padlist, 1, PADLIST);
padname = newAV();
pad = newAV();
AvREIFY_only(a0);
}
else {
+ padlist->xpadl_id = PL_padlist_generation++;
av_store(pad, 0, NULL);
}
- AvREAL_off(padlist);
/* Most subroutines never recurse, hence only need 2 entries in the padlist
array - names, and depth=1. The default for av_store() is to allocate
0..3, and even an explicit call to av_extend() with <3 will be rounded
up, so we inline the allocation of the array here. */
- Newx(ary, 2, SV*);
- AvFILLp(padlist) = 1;
- AvMAX(padlist) = 1;
- AvALLOC(padlist) = ary;
- AvARRAY(padlist) = ary;
- ary[0] = MUTABLE_SV(padname);
- ary[1] = MUTABLE_SV(pad);
+ Newx(ary, 2, PAD *);
+ PADLIST_MAX(padlist) = 1;
+ PADLIST_ARRAY(padlist) = ary;
+ ary[0] = padname;
+ ary[1] = pad;
/* ... then update state variables */
{
dVAR;
const PADLIST *padlist = CvPADLIST(cv);
+ bool const slabbed = !!CvSLABBED(cv);
PERL_ARGS_ASSERT_CV_UNDEF;
}
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");
PAD_SAVE_SETNULLPAD();
+ if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
op_free(CvROOT(cv));
CvROOT(cv) = NULL;
CvSTART(cv) = NULL;
LEAVE;
}
+ else if (slabbed && CvSTART(cv)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ /* discard any leaked ops */
+ opslab_force_free((OPSLAB *)CvSTART(cv));
+ CvSTART(cv) = NULL;
+
+ LEAVE;
+ }
+#ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
+ sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
CvGV_set(cv, NULL);
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
- if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
- ) {
+ if (padlist) {
I32 ix;
/* Free the padlist associated with a CV.
if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
CV * const outercv = CvOUTSIDE(cv);
const U32 seq = CvOUTSIDE_SEQ(cv);
- AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ PAD * const comppad_name = PADLIST_ARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ PAD * const comppad = PADLIST_ARRAY(padlist)[1];
SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV * const namesv = namepad[ix];
CV * const innercv = MUTABLE_CV(curpad[ix]);
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
+ assert(SvTYPE(innercv) != SVt_PVFM);
namepad[ix] = NULL;
SvREFCNT_dec(namesv);
}
}
- ix = AvFILLp(padlist);
+ ix = PADLIST_MAX(padlist);
while (ix > 0) {
- SV* const sv = AvARRAY(padlist)[ix--];
+ PAD * const sv = PADLIST_ARRAY(padlist)[ix--];
if (sv) {
- if (sv == (const SV *)PL_comppad) {
+ if (sv == PL_comppad) {
PL_comppad = NULL;
PL_curpad = NULL;
}
}
}
{
- SV *const sv = AvARRAY(padlist)[0];
- if (sv == (const SV *)PL_comppad_name)
+ PAD * const sv = PADLIST_ARRAY(padlist)[0];
+ if (sv == PL_comppad_name)
PL_comppad_name = NULL;
SvREFCNT_dec(sv);
}
- SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+ if (PADLIST_ARRAY(padlist)) Safefree(PADLIST_ARRAY(padlist));
+ Safefree(padlist);
CvPADLIST(cv) = NULL;
}
}
/*
+=for apidoc cv_forget_slab
+
+When a CV has a reference count on its slab (CvSLABBED), it is responsible
+for making sure it is freed. (Hence, no two CVs should ever have a
+reference count on the same slab.) The CV only needs to reference the slab
+during compilation. Once it is compiled and CvROOT attached, it has
+finished its job, so it can forget the slab.
+
+=cut
+*/
+
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+ const bool slabbed = !!CvSLABBED(cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
+
+ PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+ if (!slabbed) return;
+
+ CvSLABBED_off(cv);
+
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
+ else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
+#else
+ if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+ else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+#endif
+#ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif
+
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (slab) {
+ size_t refcnt;
+ refcnt = slab->opslab_refcnt;
+ OpslabREFCNT_dec(slab);
+ if (refcnt > 1) Slab_to_ro(slab);
+ }
+#endif
+}
+
+/*
=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
Allocates a place in the currently-compiling
/* 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.
- NWC
-*/
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
ASSERT_CURPAD_ACTIVE("pad_alloc");
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_alloc");
+ Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
to the outer scope is weakened to avoid a reference loop.
+One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
+
I<optype> should be an opcode indicating the type of operation that the
pad entry is to support. This doesn't affect operational semantics,
but is used for debugging.
ix = pad_alloc(optype, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
- av_store(PL_comppad, ix, (SV*)func);
+ if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
+ av_store(PL_comppad, ix, (SV*)func);
+ else {
+ SV *rv = newRV_noinc((SV *)func);
+ sv_rvweaken(rv);
+ 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 */
- if (CvOUTSIDE(func)) {
+ if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
assert(!CvWEAKOUTSIDE(func));
CvWEAKOUTSIDE_on(func);
SvREFCNT_dec(CvOUTSIDE(func));
}
/*
-=for apidoc m|pad_check_dup|SV *name|U32 flags|const HV *ourstash
+=for apidoc pad_check_dup
Check for duplicate declarations: report any of:
+
* a my in the current scope with the same name;
- * an our (anywhere in the pad) with the same name and the same stash
- as C<ourstash>
-C<is_our> indicates that the name to check is an 'our' declaration
+ * an our (anywhere in the pad) with the same name and the
+ same stash as C<ourstash>
+
+C<is_our> indicates that the name to check is an 'our' declaration.
=cut
*/
* our $foo = 0 unless defined $foo;
* to not give a warning. (Yes, this is a hack) */
- nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
+ nameav = PADLIST_ARRAY(CvPADLIST(PL_compcv))[0];
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
return DEFSV;
- return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
+ return AvARRAY(PADLIST_ARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
}
/*
I32 offset, new_offset;
SV *new_capture;
SV **new_capturep;
- const AV * const padlist = CvPADLIST(cv);
+ const PADLIST * const padlist = CvPADLIST(cv);
+ const bool staleok = !!(flags & padadd_STALEOK);
PERL_ARGS_ASSERT_PAD_FINDLEX;
- if (flags & ~padadd_UTF8_NAME)
+ if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
(UV)flags);
+ flags &= ~ padadd_STALEOK; /* one-shot flag */
*out_flags = 0;
if (padlist) { /* not an undef CV */
I32 fake_offset = 0;
- const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
+ const AV * const nameav = PADLIST_ARRAY(padlist)[0];
SV * const * const name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
return offset;
}
- *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
- CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
+ *out_capture = AvARRAY(PADLIST_ARRAY(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)
+ && (!CvDEPTH(cv) || !staleok)
&& !SvPAD_STATE(name_svp[offset]))
{
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
new_capturep = out_capture ? out_capture :
CvLATE(cv) ? NULL : &new_capture;
- offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+ offset = pad_findlex(namepv, namelen,
+ flags | padadd_STALEOK*(new_capturep == &new_capture),
+ CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name_sv, out_flags);
if ((PADOFFSET)offset == NOT_IN_PAD)
return NOT_IN_PAD;
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_comppad_name = PADLIST_ARRAY(padlist)[0];
+ PL_comppad = PADLIST_ARRAY(padlist)[1];
PL_curpad = AvARRAY(PL_comppad);
new_offset
/*
=for apidoc m|void|pad_block_start|int full
-Update the pad compilation state variables on entry to a new block
+Update the pad compilation state variables on entry to a new block.
=cut
*/
/*
=for apidoc m|U32|intro_my
-"Introduce" my variables to visible status.
+"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.
=cut
*/
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_swipe curpad");
- if (!po)
- Perl_croak(aTHX_ "panic: pad_swipe po");
+ Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
+ if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
+ Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
+ (long)po, (long)AvFILLp(PL_comppad));
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
dVAR;
#ifdef USE_BROKEN_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_reset curpad");
+ Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
);
if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
- register I32 po;
+ 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]);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
CvCLONE_on(cv);
+ CvHASEVAL_on(cv);
}
}
}
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_free curpad");
+ Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (!po)
Perl_croak(aTHX_ "panic: pad_free po");
);
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
- SvPADTMP_off(PL_curpad[po]);
+ SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
}
if ((I32)po < PL_padix)
PL_padix = po - 1;
if (!padlist) {
return;
}
- pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
- pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
+ pad_name = *PADLIST_ARRAY(padlist);
+ pad = PADLIST_ARRAY(padlist)[1];
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
Perl_dump_indent(aTHX_ level, file,
{
dVAR;
const CV * const outside = CvOUTSIDE(cv);
- AV* const padlist = CvPADLIST(cv);
+ PADLIST* const padlist = CvPADLIST(cv);
PERL_ARGS_ASSERT_CV_DUMP;
{
dVAR;
I32 ix;
- AV* const protopadlist = CvPADLIST(proto);
- const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
- const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
+ PADLIST* const protopadlist = CvPADLIST(proto);
+ const PAD *const protopad_name = *PADLIST_ARRAY(protopadlist);
+ const PAD *const protopad = PADLIST_ARRAY(protopadlist)[1];
SV** const pname = AvARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = AvFILLp(protopad_name);
assert(!CvUNIQUE(proto));
- /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+ /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
+ * reliable. The currently-running sub is always the one we need to
+ * close over.
+ * Note that in general for formats, CvOUTSIDE != find_runcv.
+ * Since formats may be nested inside closures, 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))
+ if (SvTYPE(proto) == SVt_PVCV)
outside = find_runcv(NULL);
- depth = CvDEPTH(outside);
+ else {
+ outside = CvOUTSIDE(proto);
+ if ((CvCLONE(outside) && ! CvCLONED(outside))
+ || !CvPADLIST(outside)
+ || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
+ outside = find_runcv_where(
+ FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
+ );
+ /* outside could be null */
+ }
+ }
+ depth = outside ? CvDEPTH(outside) : 0;
assert(depth || SvTYPE(proto) == SVt_PVFM);
if (!depth)
depth = 1;
- assert(CvPADLIST(outside));
+ assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
ENTER;
SAVESPTR(PL_compcv);
cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+ |CVf_SLABBED);
CvCLONED_on(cv);
CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
- CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
+ if (CvHASEVAL(cv))
+ CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
if (SvPOK(proto))
sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
+ if (SvMAGIC(proto))
+ mg_copy((SV *)proto, (SV *)cv, 0, 0);
CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
av_fill(PL_comppad, fpad);
for (ix = fname; ix > 0; ix--)
PL_curpad = AvARRAY(PL_comppad);
- outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+ outpad = outside && CvPADLIST(outside)
+ ? AvARRAY(PADLIST_ARRAY(CvPADLIST(outside))[depth])
+ : NULL;
+ assert(outpad || SvTYPE(cv) == SVt_PVFM);
+ if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
for (ix = fpad; ix > 0; ix--) {
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[PARENT_PAD_INDEX(namesv)];
- assert(sv);
- /* formats may have an inactive parent,
- while my $x if $false can leave an active var marked as
- stale. And state vars are always available */
- if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
+ /* formats may have an inactive, or even undefined, parent;
+ but state vars are always available. */
+ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+ || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
+ && (!outside || !CvDEPTH(outside))) ) {
+ assert(SvTYPE(cv) == SVt_PVFM);
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" is not available", namesv);
sv = NULL;
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
- cv_dump(outside, "Outside");
+ if (outside) cv_dump(outside, "Outside");
cv_dump(proto, "Proto");
cv_dump(cv, "To");
);
SV* const const_sv = op_const_sv(CvSTART(cv), cv);
if (const_sv) {
SvREFCNT_dec(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 {
{
dVAR;
I32 ix;
- AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ AV * const comppad_name = PADLIST_ARRAY(padlist)[0];
+ AV * const comppad = PADLIST_ARRAY(padlist)[1];
SV ** const namepad = AvARRAY(comppad_name);
SV ** const curpad = AvARRAY(comppad);
if (namesv && namesv != &PL_sv_undef
&& *SvPVX_const(namesv) == '&')
{
+ if (SvTYPE(curpad[ix]) == SVt_PVCV) {
CV * const innercv = MUTABLE_CV(curpad[ix]);
assert(CvWEAKOUTSIDE(innercv));
assert(CvOUTSIDE(innercv) == old_cv);
CvOUTSIDE(innercv) = new_cv;
+ }
+ else { /* format reference */
+ SV * const rv = curpad[ix];
+ CV *innercv;
+ if (!SvOK(rv)) continue;
+ assert(SvROK(rv));
+ assert(SvWEAKREF(rv));
+ innercv = (CV *)SvRV(rv);
+ assert(!CvWEAKOUTSIDE(innercv));
+ SvREFCNT_dec(CvOUTSIDE(innercv));
+ CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
+ }
}
}
}
PERL_ARGS_ASSERT_PAD_PUSH;
- if (depth > AvFILLp(padlist)) {
- SV** const svp = AvARRAY(padlist);
+ if (depth > PADLIST_MAX(padlist) || !PADLIST_ARRAY(padlist)[depth]) {
+ PAD** const svp = PADLIST_ARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((const AV *)svp[1]);
av_store(newpad, 0, MUTABLE_SV(av));
AvREIFY_only(av);
- av_store(padlist, depth, MUTABLE_SV(newpad));
- AvFILLp(padlist) = depth;
+ padlist_store(padlist, depth, newpad);
}
}
# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
/*
-=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
+=for apidoc padlist_dup
Duplicates a pad.
=cut
*/
-AV *
-Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
+PADLIST *
+Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
{
- AV *dstpad;
+ PADLIST *dstpad;
+ bool cloneall;
+ PADOFFSET max;
+
PERL_ARGS_ASSERT_PADLIST_DUP;
if (!srcpad)
return NULL;
- assert(!AvREAL(srcpad));
+ cloneall = param->flags & CLONEf_COPY_STACKS
+ || SvREFCNT(PADLIST_ARRAY(srcpad)[1]) > 1;
+ assert (SvREFCNT(PADLIST_ARRAY(srcpad)[1]) == 1);
+
+ max = cloneall ? PADLIST_MAX(srcpad) : 1;
+
+ Newx(dstpad, 1, PADLIST);
+ ptr_table_store(PL_ptr_table, srcpad, dstpad);
+ PADLIST_MAX(dstpad) = max;
+ Newx(PADLIST_ARRAY(dstpad), max + 1, PAD *);
- 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);
+ if (cloneall) {
+ PADOFFSET depth;
+ for (depth = 0; depth <= max; ++depth)
+ PADLIST_ARRAY(dstpad)[depth] =
+ av_dup_inc(PADLIST_ARRAY(srcpad)[depth], param);
} 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]);
+ I32 ix = AvFILLp(PADLIST_ARRAY(srcpad)[1]);
AV *pad1;
- const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
- const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
+ const I32 names_fill = AvFILLp(PADLIST_ARRAY(srcpad)[0]);
+ const PAD *const srcpad1 = PADLIST_ARRAY(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]);
+ PADLIST_ARRAY(dstpad)[0] =
+ av_dup_inc(PADLIST_ARRAY(srcpad)[0], param);
+ names = AvARRAY(PADLIST_ARRAY(dstpad)[0]);
pad1 = newAV();
av_extend(pad1, ix);
- AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+ PADLIST_ARRAY(dstpad)[1] = pad1;
pad1a = AvARRAY(pad1);
- AvFILLp(dstpad) = 1;
if (ix > -1) {
AvFILLp(pad1) = ix;
#endif /* USE_ITHREADS */
+PAD **
+Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
+{
+ dVAR;
+ PAD **ary;
+ SSize_t const oldmax = PADLIST_MAX(padlist);
+
+ PERL_ARGS_ASSERT_PADLIST_STORE;
+
+ assert(key >= 0);
+
+ if (key > PADLIST_MAX(padlist)) {
+ av_extend_guts(NULL,key,&PADLIST_MAX(padlist),
+ (SV ***)&PADLIST_ARRAY(padlist),
+ (SV ***)&PADLIST_ARRAY(padlist));
+ Zero(PADLIST_ARRAY(padlist)+oldmax+1, PADLIST_MAX(padlist)-oldmax,
+ PAD *);
+ }
+ ary = PADLIST_ARRAY(padlist);
+ SvREFCNT_dec(ary[key]);
+ ary[key] = val;
+ return &ary[key];
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff