#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */
#define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */
#define CVf_CONST 0x0200 /* inlinable sub */
+#define CVf_WEAKOUTSIDE 0x0400 /* CvOUTSIDE isn't ref counted */
+
/* This symbol for optimised communication between toke.c and op.c: */
#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)
#define CvCONST_on(cv) (CvFLAGS(cv) |= CVf_CONST)
#define CvCONST_off(cv) (CvFLAGS(cv) &= ~CVf_CONST)
+#define CvWEAKOUTSIDE(cv) (CvFLAGS(cv) & CVf_WEAKOUTSIDE)
+#define CvWEAKOUTSIDE_on(cv) (CvFLAGS(cv) |= CVf_WEAKOUTSIDE)
+#define CvWEAKOUTSIDE_off(cv) (CvFLAGS(cv) &= ~CVf_WEAKOUTSIDE)
+
+
+/*
+=head1 CV reference counts and CvOUTSIDE
+
+=for apidoc m|bool|CvWEAKOUTSIDE|CV *cv
+
+Each CV has a pointer, C<CvOUTSIDE()>, to its lexically enclosing
+CV (if any). Because pointers to anonymous sub prototypes are
+stored in C<&> pad slots, it is a possible to get a circular reference,
+with the parent pointing to the child and vice-versa. To avoid the
+ensuing memory leak, we do not increment the reference count of the CV
+pointed to by C<CvOUTSIDE> in the I<one specific instance> that the parent
+has a C<&> pad slot pointing back to us. In this case, we set the
+C<CvWEAKOUTSIDE> flag in the child. This allows us to determine under what
+circumstances we should decrement the refcount of the parent when freeing
+the child.
+
+There is a further complication with non-closure anonymous subs (ie those
+that do not refer to any lexicals outside that sub). In this case, the
+anonymous prototype is shared rather than being cloned. This has the
+consequence that the parent may be freed while there are still active
+children, eg
+
+ BEGIN { $a = sub { eval '$x' } }
+
+In this case, the BEGIN is freed immediately after execution since there
+are no active references to it: the anon sub prototype has
+C<CvWEAKOUTSIDE> set since it's not a closure, and $a points to the same
+CV, so it doesn't contribute to BEGIN's refcount either. When $a is
+executed, the C<eval '$x'> causes the chain of C<CvOUTSIDE>s to be followed,
+and the freed BEGIN is accessed.
+
+To avoid this, whenever a CV and its associated pad is freed, any
+C<&> entries in the pad are explicitly removed from the pad, and if the
+refcount of the pointed-to anon sub is still positive, then that
+child's C<CvOUTSIDE> is set to point to its grandparent. This will only
+occur in the single specific case of a non-closure anon prototype
+having one or more active references (such as C<$a> above).
+
+One other thing to consider is that a CV may be merely undefined
+rather than freed, eg C<undef &foo>. In this case, its refcount may
+not have reached zero, but we still delete its pad and its C<CvROOT> etc.
+Since various children may still have their C<CvOUTSIDE> pointing at this
+undefined CV, we keep its own C<CvOUTSIDE> for the time being, so that
+the chain of lexical scopes is unbroken. For example, the following
+should print 123:
+
+ my $x = 123;
+ sub tmp { sub { eval '$x' } }
+ my $a = tmp();
+ undef &tmp;
+ print $a->();
+
+=cut
+*/
if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
+ if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
pd |CV* |cv_clone |CV* proto
Apd |SV* |cv_const_sv |CV* cv
p |SV* |op_const_sv |OP* o|CV* cv
-Ap |void |cv_undef |CV* cv
+Apd |void |cv_undef |CV* cv
Ap |void |cx_dump |PERL_CONTEXT* cs
Ap |SV* |filter_add |filter_t funcp|SV* datasv
Ap |void |filter_del |filter_t funcp
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE
- SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
+ SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE
CVf_METHOD CVf_LOCKED CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
sub populate_curcvlex {
my $self = shift;
for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
- my @padlist = $cv->PADLIST->ARRAY;
+ my $padlist = $cv->PADLIST;
+ # an undef CV still in lexical chain
+ next if class($padlist) eq "SPECIAL";
+ my @padlist = $padlist->ARRAY;
my @ns = $padlist[0]->ARRAY;
for (my $i=0; $i<@ns; ++$i) {
next;
}
my $name = $ns[$i]->PVX;
- my $seq_st = $ns[$i]->NVX;
- my $seq_en = int($ns[$i]->IVX);
+ my ($seq_st, $seq_en) =
+ ($ns[$i]->FLAGS & SVf_FAKE)
+ ? (0, 999999)
+ : ($ns[$i]->NVX, $ns[$i]->IVX);
push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
}
GVf_IMPORTED_AV GVf_IMPORTED_HV
GVf_IMPORTED_SV GVf_IMPORTED_CV
CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_CONST
- SVpad_OUR SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
+ SVpad_OUR SVf_FAKE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
SVf_ROK SVp_IOK SVp_POK SVp_NOK
))
{
RV = $ADDR
SV = PVCV\\($ADDR\\) at $ADDR
REFCNT = 2
- FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON\\)
+ FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
IV = 0
NV = 0
PROTOTYPE = ""
DEPTH = 0
(?: MUTEXP = $ADDR
OWNER = $ADDR
-)? FLAGS = 0x4
+)? FLAGS = 0x404
OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
return o;
}
+/*
+=for apidoc cv_undef
+
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
+
+=cut
+*/
+
void
Perl_cv_undef(pTHX_ CV *cv)
{
- CV *freecv = Nullcv;
-
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
pad_undef(cv);
- /* Since closure prototypes have the same lifetime as the containing
- * CV, they don't hold a refcount on the outside CV. This avoids
- * the refcount loop between the outer CV (which keeps a refcount to
- * the closure prototype in the pad entry for pp_anoncode()) and the
- * closure prototype, and the ensuing memory leak. --GSAR */
- if (!CvANON(cv) || CvCLONED(cv))
- freecv = CvOUTSIDE(cv);
- CvOUTSIDE(cv) = Nullcv;
+ /* remove CvOUTSIDE unless this is an undef rather than a free */
+ if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = Nullcv;
+ }
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
}
- if (freecv)
- SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
}
- CvFLAGS(cv) = 0;
+ /* delete all flags except WEAKOUTSIDE */
+ CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
}
void
CvCONST_on(cv);
}
- /* If a potential closure prototype, don't keep a refcount on outer CV.
- * This is okay as the lifetime of the prototype is tied to the
- * lifetime of the outer CV. Avoids memory leak due to reference
- * loop. --GSAR */
- if (!name)
- SvREFCNT_dec(CvOUTSIDE(cv));
-
if (name || aname) {
char *s;
char *tname = (name ? name : aname);
We also repoint the CvOUTSIDE of any about-to-be-orphaned
inner subs to the outer of this cv.
+(This function should really be called pad_free, but the name was already
+taken)
+
=cut
*/
"Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
);
- /* pads may be cleared out already during global destruction */
- if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
- && !PL_dirty) || CvSPECIAL(cv))
- {
- CV *outercv = CvOUTSIDE(cv);
- U32 seq = CvOUTSIDE_SEQ(cv);
- /* XXX DAPM the following code is very similar to
- * pad_fixup_inner_anons(). Merge??? */
+ /* 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 */
- /* inner references to eval's/BEGIN's/etc cv must be fixed up */
+ if (!PL_dirty) { /* don't bother during global destruction */
+ CV *outercv = CvOUTSIDE(cv);
+ U32 seq = CvOUTSIDE_SEQ(cv);
AV *comppad_name = (AV*)AvARRAY(padlist)[0];
SV **namepad = AvARRAY(comppad_name);
AV *comppad = (AV*)AvARRAY(padlist)[1];
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV *namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&'
- && ix <= AvFILLp(comppad))
+ && *SvPVX(namesv) == '&')
{
CV *innercv = (CV*)curpad[ix];
- if (innercv && SvTYPE(innercv) == SVt_PVCV
+ namepad[ix] = Nullsv;
+ SvREFCNT_dec(namesv);
+ curpad[ix] = Nullsv;
+ SvREFCNT_dec(innercv);
+ if (SvREFCNT(innercv) /* in use, not just a prototype */
&& CvOUTSIDE(innercv) == cv)
{
+ assert(CvWEAKOUTSIDE(innercv));
+ CvWEAKOUTSIDE_off(innercv);
CvOUTSIDE(innercv) = outercv;
CvOUTSIDE_SEQ(innercv) = seq;
- /* anon prototypes aren't refcounted */
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(outercv);
- if (SvREFCNT(cv))
- SvREFCNT_dec(cv);
- }
+ SvREFCNT_inc(outercv);
}
}
}
}
+
ix = AvFILLp(padlist);
while (ix >= 0) {
SV* sv = AvARRAY(padlist)[ix--];
/* 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;
}
);
curlist = CvPADLIST(cv);
+ if (!curlist)
+ continue; /* an undef CV */
svp = av_fetch(curlist, 0, FALSE);
if (!svp || *svp == &PL_sv_undef)
continue;
cv = PL_compcv = (CV*)NEWSV(1104, 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_ITHREADS
CvCLONE_on(kid);
SvPADMY_on(kid);
PL_curpad[ix] = (SV*)kid;
+ /* '&' entry points to child, so child mustn't refcnt parent */
+ CvWEAKOUTSIDE_on(kid);
+ SvREFCNT_dec(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
*/
&& *SvPVX(namesv) == '&')
{
CV *innercv = (CV*)curpad[ix];
- if (CvOUTSIDE(innercv) == old_cv) {
- CvOUTSIDE(innercv) = new_cv;
- /* anon prototypes aren't refcounted */
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(new_cv);
- SvREFCNT_dec(old_cv);
- }
- }
+ assert(CvWEAKOUTSIDE(innercv));
+ assert(CvOUTSIDE(innercv) == old_cv);
+ CvOUTSIDE(innercv) = new_cv;
}
}
}
+
/*
=for apidoc pad_push
=over 8
+=item cv_undef
+
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
+
+ void cv_undef(CV* cv)
+
+=for hackers
+Found in file op.c
+
=item load_module
Loads the module whose name is pointed to by the string part of name.
B<they are not for use in extensions>!
+=head1 CV reference counts and CvOUTSIDE
+
+=over 8
+
+=item CvWEAKOUTSIDE
+
+Each CV has a pointer, C<CvOUTSIDE()>, to its lexically enclosing
+CV (if any). Because pointers to anonymous sub prototypes are
+stored in C<&> pad slots, it is a possible to get a circular reference,
+with the parent pointing to the child and vice-versa. To avoid the
+ensuing memory leak, we do not increment the reference count of the CV
+pointed to by C<CvOUTSIDE> in the I<one specific instance> that the parent
+has a C<&> pad slot pointing back to us. In this case, we set the
+C<CvWEAKOUTSIDE> flag in the child. This allows us to determine under what
+circumstances we should decrement the refcount of the parent when freeing
+the child.
+
+There is a further complication with non-closure anonymous subs (ie those
+that do not refer to any lexicals outside that sub). In this case, the
+anonymous prototype is shared rather than being cloned. This has the
+consequence that the parent may be freed while there are still active
+children, eg
+
+ BEGIN { $a = sub { eval '$x' } }
+
+In this case, the BEGIN is freed immediately after execution since there
+are no active references to it: the anon sub prototype has
+C<CvWEAKOUTSIDE> set since it's not a closure, and $a points to the same
+CV, so it doesn't contribute to BEGIN's refcount either. When $a is
+executed, the C<eval '$x'> causes the chain of C<CvOUTSIDE>s to be followed,
+and the freed BEGIN is accessed.
+
+To avoid this, whenever a CV and its associated pad is freed, any
+C<&> entries in the pad are explicitly removed from the pad, and if the
+refcount of the pointed-to anon sub is still positive, then that
+child's C<CvOUTSIDE> is set to point to its grandparent. This will only
+occur in the single specific case of a non-closure anon prototype
+having one or more active references (such as C<$a> above).
+
+One other thing to consider is that a CV may be merely undefined
+rather than freed, eg C<undef &foo>. In this case, its refcount may
+not have reached zero, but we still delete its pad and its C<CvROOT> etc.
+Since various children may still have their C<CvOUTSIDE> pointing at this
+undefined CV, we keep its own C<CvOUTSIDE> for the time being, so that
+the chain of lexical scopes is unbroken. For example, the following
+should print 123:
+
+ my $x = 123;
+ sub tmp { sub { eval '$x' } }
+ my $a = tmp();
+ undef &tmp;
+ print $a->();
+
+ bool CvWEAKOUTSIDE(CV *cv)
+
+=for hackers
+Found in file cv.h
+
+
+=back
+
=head1 Functions in file pad.h
=item 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.
void pad_fixup_inner_anons(PADLIST *padlist, CV *old_cv, CV *new_cv)
We also repoint the CvOUTSIDE of any about-to-be-orphaned
inner subs to the outer of this cv.
+(This function should really be called pad_free, but the name was already
+taken)
+
void pad_undef(CV* cv)
=for hackers
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = outside ? (CV*)SvREFCNT_inc(outside) : outside;
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
/* set up a scratch pad */
CvDEPTH(dstr) = 0;
}
PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
- /* anon prototypes aren't refcounted */
- if (!CvANON(sstr) || CvCLONED(sstr))
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
- else
- CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
- CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
+ CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
+ CvOUTSIDE(dstr) =
+ CvWEAKOUTSIDE(sstr)
+ ? cv_dup( CvOUTSIDE(sstr), param)
+ : cv_dup_inc(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
use Config;
-print "1..177\n";
+print "1..181\n";
my $test = 1;
sub test (&) {
}
-# The following dumps core with perl <= 5.8.0
+# The following dumps core with perl <= 5.8.0 (bugid 9535) ...
BEGIN { $vanishing_pad = sub { eval $_[0] } }
$some_var = 123;
test { $vanishing_pad->( '$some_var' ) == 123 };
+# ... and here's another coredump variant - this time we explicitly
+# delete the sub rather than using a BEGIN ...
+
+sub deleteme { $a = sub { eval '$newvar' } }
+deleteme();
+*deleteme = sub {}; # delete the sub
+$newvar = 123; # realloc the SV of the freed CV
+test { $a->() == 123 };
+
+# ... and a further coredump variant - the fixup of the anon sub's
+# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
+# survive the outer eval also being freed.
+
+$x = 123;
+$a = eval q(
+ eval q[
+ sub { eval '$x' }
+ ]
+);
+@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
+test { $a->() == 123 };
+
# this coredumped on <= 5.8.0 because evaling the closure caused
# an SvFAKE to be added to the outer anon's pad, which was then grown.
my $outer;
}
fake();
+# undefining a sub shouldn't alter visibility of outer lexicals
+
+{
+ $x = 1;
+ my $x = 2;
+ sub tmp { sub { eval '$x' } }
+ my $a = tmp();
+ undef &tmp;
+ test { $a->() == 2 };
+}
+
+# handy class: $x = Watch->new(\$foo,'bar')
+# causes 'bar' to be appended to $foo when $x is destroyed
+sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
+sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
+
+
+# bugid 1028:
+# nested anon subs (and associated lexicals) not freed early enough
+
+sub linger {
+ my $x = Watch->new($_[0], '2');
+ sub {
+ $x;
+ my $y;
+ sub { $y; };
+ };
+}
+{
+ my $watch = '1';
+ linger(\$watch);
+ test { $watch eq '12' }
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff