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 mark it AvREAL
+(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:
{
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();
+#ifndef PL_OP_SLAB_ALLOC
+ if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
+#endif
op_free(CvROOT(cv));
CvROOT(cv) = NULL;
CvSTART(cv) = NULL;
LEAVE;
}
+#ifndef PL_OP_SLAB_ALLOC
+ 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
+#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV_set(cv, NULL);
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);
CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
}
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+ const bool slabbed = !!CvSLABBED(cv);
+
+ PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+ if (!slabbed) return;
+
+ CvSLABBED_off(cv);
+
+ if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+ else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+# ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+}
+#endif
+
/*
=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
/* 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) {
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_inc((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
*/
/*
=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",
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;
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);
+ else {
+ outside = CvOUTSIDE(proto);
+ if (CvCLONE(outside) && ! CvCLONED(outside)) {
+ CV * const runcv = find_runcv_where(
+ FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+ );
+ if (runcv) outside = runcv;
+ }
+ }
depth = CvDEPTH(outside);
assert(depth || SvTYPE(proto) == SVt_PVFM);
if (!depth)
depth = 1;
- assert(CvPADLIST(outside));
+ assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
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);
PL_curpad = AvARRAY(PL_comppad);
- outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+ outpad = CvPADLIST(outside)
+ ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+ : NULL;
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,
+ /* formats may have an inactive, or even undefined, 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)) {
+ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+ || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" is not available", namesv);
sv = NULL;
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);
+ }
}
}
}
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. It may also be there because of
- how Perl_sv_compile_2op() "works". :-( */
+ may have been cloned already. */
dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
if (dstpad)
* 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