=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 the REFCNT of its component items managed "manually"
-(mostly in pad.c) rather than by normal av.c rules. So we turn off AvREAL
-just before freeing it, to let av.c know not to touch the entries.
-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</PadlistNAMES>.
-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.
duplicate C<our> declarations in the same package can be detected). SvUVX 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
+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,
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
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
+(PADNAME_OUTER 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 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");
if (flags & padnew_SAVE) {
SAVECOMPPAD();
- SAVESPTR(PL_comppad_name);
if (! (flags & padnew_CLONE)) {
+ SAVESPTR(PL_comppad_name);
SAVEI32(PL_padix);
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
/* ... create new pad ... */
- padlist = newAV();
- padname = newAV();
+ Newxz(padlist, 1, PADLIST);
pad = newAV();
if (flags & padnew_CLONE) {
AV * const a0 = newAV(); /* will be @_ */
av_store(pad, 0, MUTABLE_SV(a0));
AvREIFY_only(a0);
+
+ padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
}
else {
+ padlist->xpadl_id = PL_padlist_generation++;
av_store(pad, 0, NULL);
+ padname = newAV();
}
/* 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 *);
+ PadlistMAX(padlist) = 1;
+ PadlistARRAY(padlist) = ary;
+ ary[0] = padname;
+ ary[1] = pad;
/* ... then update state variables */
- PL_comppad_name = padname;
PL_comppad = pad;
PL_curpad = AvARRAY(pad);
if (! (flags & padnew_CLONE)) {
+ PL_comppad_name = padname;
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
- CvGV_set(cv, NULL);
+ if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv));
+ else 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 = PadlistARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ PAD * const comppad = PadlistARRAY(padlist)[1];
SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV * const namesv = namepad[ix];
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
assert(SvTYPE(innercv) != SVt_PVFM);
- namepad[ix] = NULL;
- SvREFCNT_dec(namesv);
if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
curpad[ix] = NULL;
}
}
- ix = AvFILLp(padlist);
+ ix = PadlistMAX(padlist);
while (ix > 0) {
- SV* const sv = AvARRAY(padlist)[ix--];
+ PAD * const sv = PadlistARRAY(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 = PadlistARRAY(padlist)[0];
+ if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
PL_comppad_name = NULL;
SvREFCNT_dec(sv);
}
- AvREAL_off(CvPADLIST(cv));
- SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+ if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
+ Safefree(padlist);
CvPADLIST(cv) = NULL;
}
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;
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;
+#ifdef PERL_DEBUG_READONLY_OPS
+ const size_t refcnt = slab->opslab_refcnt;
+#endif
OpslabREFCNT_dec(slab);
+#ifdef PERL_DEBUG_READONLY_OPS
if (refcnt > 1) Slab_to_ro(slab);
- }
#endif
+ }
}
/*
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.
if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
av_store(PL_comppad, ix, (SV*)func);
else {
- SV *rv = newRV_inc((SV *)func);
+ SV *rv = newRV_noinc((SV *)func);
sv_rvweaken(rv);
assert (SvTYPE(func) == SVt_PVFM);
av_store(PL_comppad, ix, rv);
{
if (is_our && (SvPAD_OUR(sv)))
break; /* "our" masking "our" */
+ /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" variable %"SVf" masks earlier declaration in same %s",
+ "\"%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,
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
? "scope" : "statement"));
* 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 = PadlistARRAY(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(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
}
/*
#define CvCOMPILED(cv) CvROOT(cv)
/* the CV does late binding of its lexicals */
-#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+#define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
STATIC PADOFFSET
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 = PadlistARRAY(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(PadlistARRAY(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 = PadlistARRAY(padlist)[0];
+ PL_comppad = PadlistARRAY(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
*/
);
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]);
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 = *PadlistARRAY(padlist);
+ pad = PadlistARRAY(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;
=cut
*/
-CV *
-Perl_cv_clone(pTHX_ CV *proto)
+static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
+
+static void
+S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
{
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);
+ PAD *const protopad_name = *PadlistARRAY(protopadlist);
+ const PAD *const protopad = PadlistARRAY(protopadlist)[1];
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;
-
- PERL_ARGS_ASSERT_CV_CLONE;
+ bool subclones = FALSE;
+#ifdef DEBUGGING
+ CV * const outside_arg = outside;
+#endif
assert(!CvUNIQUE(proto));
* to a prototype; we instead want the cloned parent who called us.
*/
- if (SvTYPE(proto) == SVt_PVCV)
+ if (!outside) {
+ if (SvTYPE(proto) == SVt_PVCV)
outside = find_runcv(NULL);
- else {
+ else {
outside = CvOUTSIDE(proto);
- if (CvCLONE(outside) && ! CvCLONED(outside)) {
- CV * const runcv = find_runcv_where(
- FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+ 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
);
- if (runcv) outside = runcv;
+ /* outside could be null */
}
+ }
}
- depth = CvDEPTH(outside);
- assert(depth || SvTYPE(proto) == SVt_PVFM);
+ depth = outside ? CvDEPTH(outside) : 0;
+#ifdef DEBUGGING
+ assert(depth || outside_arg || SvTYPE(proto) == SVt_PVFM);
+#endif
if (!depth)
depth = 1;
- assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
+ assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
ENTER;
SAVESPTR(PL_compcv);
+ PL_compcv = cv;
- cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
- |CVf_SLABBED);
- CvCLONED_on(cv);
-
- CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
- : CvFILE(proto);
- CvGV_set(cv,CvGV(proto));
- CvSTASH_set(cv, CvSTASH(proto));
- OP_REFCNT_LOCK;
- CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
- OP_REFCNT_UNLOCK;
- CvSTART(cv) = CvSTART(proto);
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);
+ SAVESPTR(PL_comppad_name);
+ PL_comppad_name = protopad_name;
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--)
- av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
PL_curpad = AvARRAY(PL_comppad);
- outpad = CvPADLIST(outside)
- ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+ outpad = outside && CvPADLIST(outside)
+ ? AvARRAY(PadlistARRAY(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;
but state vars are always available. */
if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
|| ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
- && !CvDEPTH(outside)) ) {
+ && (!outside || !CvDEPTH(outside))) ) {
assert(SvTYPE(cv) == SVt_PVFM);
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" is not available", namesv);
if (!sv) {
const char sigil = SvPVX_const(namesv)[0];
if (sigil == '&')
- sv = SvREFCNT_inc(ppad[ix]);
+ /* If there are state subs, we need to clone them, too.
+ But they may need to close over variables we have
+ not cloned yet. So we will have to do a second
+ pass. Furthermore, there may be state subs clos-
+ ing over other state subs’ entries, so we have
+ to put a stub here and then clone into it on the
+ second pass. */
+ sv = SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])
+ ? (subclones = 1, newSV_type(SVt_PVCV))
+ : SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
sv = MUTABLE_SV(newAV());
else if (sigil == '%')
sv = newSV(0);
SvPADMY_on(sv);
/* reset the 'assign only once' flag on each state var */
- if (SvPAD_STATE(namesv))
+ if (sigil != '&' && SvPAD_STATE(namesv))
SvPADSTALE_on(sv);
}
}
PL_curpad[ix] = sv;
}
+ if (subclones)
+ for (ix = fpad; ix > 0; ix--) {
+ SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+ if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
+ && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
+ S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
+ }
+
+ LEAVE;
+}
+
+static CV *
+S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
+{
+ assert(!CvUNIQUE(proto));
+
+ if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+ |CVf_SLABBED);
+ CvCLONED_on(cv);
+
+ CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
+ : CvFILE(proto);
+ if (CvNAMED(proto))
+ SvANY(cv)->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(proto));
+ else CvGV_set(cv,CvGV(proto));
+ CvSTASH_set(cv, CvSTASH(proto));
+ OP_REFCNT_LOCK;
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
+ CvSTART(cv) = CvSTART(proto);
+ 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);
+
+ if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside);
+
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
- cv_dump(outside, "Outside");
+ if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
cv_dump(proto, "Proto");
cv_dump(cv, "To");
);
- LEAVE;
-
if (CvCONST(cv)) {
/* Constant sub () { $x } closing over $x - see lib/constant.pm:
* The prototype was marked as a candiate for const-ization,
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 {
return cv;
}
+CV *
+Perl_cv_clone(pTHX_ CV *proto)
+{
+ PERL_ARGS_ASSERT_CV_CLONE;
+
+ if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
+ return S_cv_clone(aTHX_ proto, NULL, NULL);
+}
+
/*
=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
{
dVAR;
I32 ix;
- AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
- AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ AV * const comppad_name = PadlistARRAY(padlist)[0];
+ AV * const comppad = PadlistARRAY(padlist)[1];
SV ** const namepad = AvARRAY(comppad_name);
SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
const SV * const namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
+ if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
&& *SvPVX_const(namesv) == '&')
{
if (SvTYPE(curpad[ix]) == SVt_PVCV) {
PERL_ARGS_ASSERT_PAD_PUSH;
- if (depth > AvFILLp(padlist)) {
- SV** const svp = AvARRAY(padlist);
+ if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
+ PAD** const svp = PadlistARRAY(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;
- if (param->flags & CLONEf_COPY_STACKS
- || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
- dstpad = av_dup_inc(srcpad, param);
- assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
+ cloneall = param->flags & CLONEf_COPY_STACKS
+ || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
+ assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
+
+ max = cloneall ? PadlistMAX(srcpad) : 1;
+
+ Newx(dstpad, 1, PADLIST);
+ ptr_table_store(PL_ptr_table, srcpad, dstpad);
+ PadlistMAX(dstpad) = max;
+ Newx(PadlistARRAY(dstpad), max + 1, PAD *);
+
+ if (cloneall) {
+ PADOFFSET depth;
+ for (depth = 0; depth <= max; ++depth)
+ PadlistARRAY(dstpad)[depth] =
+ av_dup_inc(PadlistARRAY(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(PadlistARRAY(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(PadlistARRAY(srcpad)[0]);
+ const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
SV **oldpad = AvARRAY(srcpad1);
SV **names;
SV **pad1a;
AV *args;
- /* Look for it in the table first, as the padlist may have ended up
- as an element of @DB::args (or theoretically even @_), so it may
- may have been cloned already. */
- dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
-
- if (dstpad)
- return (AV *)SvREFCNT_inc_simple_NN(dstpad);
- dstpad = newAV();
- ptr_table_store(PL_ptr_table, srcpad, dstpad);
- av_extend(dstpad, 1);
- AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
- names = AvARRAY(AvARRAY(dstpad)[0]);
+ PadlistARRAY(dstpad)[0] =
+ av_dup_inc(PadlistARRAY(srcpad)[0], param);
+ names = AvARRAY(PadlistARRAY(dstpad)[0]);
pad1 = newAV();
av_extend(pad1, ix);
- AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+ PadlistARRAY(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 = PadlistMAX(padlist);
+
+ PERL_ARGS_ASSERT_PADLIST_STORE;
+
+ assert(key >= 0);
+
+ if (key > PadlistMAX(padlist)) {
+ av_extend_guts(NULL,key,&PadlistMAX(padlist),
+ (SV ***)&PadlistARRAY(padlist),
+ (SV ***)&PadlistARRAY(padlist));
+ Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
+ PAD *);
+ }
+ ary = PadlistARRAY(padlist);
+ SvREFCNT_dec(ary[key]);
+ ary[key] = val;
+ return &ary[key];
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff