Proper fix for CvOUTSIDE weak refcounting

Message-ID: <20021210012644.A7843@fdgroup.com>

p4raw-id: //depot/perl@18302

13 files changed, 276 insertions, 66 deletions

diff --git a/cv.h b/cv.h
index 4611387d8c..6e8383a20a 100644
--- a/cv.h
+++ b/cv.h
@@ -81,6 +81,8 @@ Returns the stash of the CV.
 #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)
 
@@ -135,3 +137,62 @@ Returns the stash of the CV.
 #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
+*/
diff --git a/dump.c b/dump.c
index d874d32811..e7f0af3185 100644
--- a/dump.c
+++ b/dump.c
@@ -981,6 +981,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	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,");
diff --git a/embed.fnc b/embed.fnc
index 08a8f9d13a..5c56027e13 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -130,7 +130,7 @@ p	|void	|cv_ckproto	|CV* cv|GV* gv|char* p
 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
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index b54a5af97b..37b98a0343 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -15,7 +15,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
 	 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);
@@ -1130,7 +1130,10 @@ sub lex_in_scope {
 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) {
@@ -1141,8 +1144,10 @@ sub populate_curcvlex {
 		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];
 	}
diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL
index 37bfeb7e9d..2c2aecf6af 100644
--- a/ext/B/defsubs_h.PL
+++ b/ext/B/defsubs_h.PL
@@ -13,7 +13,7 @@ foreach my $const (qw(
 		      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
 		      ))
  {
diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t
index cdcf8114e1..a1ed214d19 100644
--- a/ext/Devel/Peek/Peek.t
+++ b/ext/Devel/Peek/Peek.t
@@ -206,7 +206,7 @@ do_test(13,
   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 = ""
@@ -220,7 +220,7 @@ do_test(13,
     DEPTH = 0
 (?:    MUTEXP = $ADDR
     OWNER = $ADDR
-)?    FLAGS = 0x4
+)?    FLAGS = 0x404
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
diff --git a/op.c b/op.c
index c46bbfce0e..46347da306 100644
--- a/op.c
+++ b/op.c
@@ -3753,11 +3753,20 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
     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__ */
@@ -3782,24 +3791,21 @@ Perl_cv_undef(pTHX_ CV *cv)
 
     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
@@ -4161,13 +4167,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    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);
diff --git a/pad.c b/pad.c
index e1ac067672..560638f642 100644
--- a/pad.c
+++ b/pad.c
@@ -198,6 +198,9 @@ 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 the outer of this cv.
 
+(This function should really be called pad_free, but the name was already
+taken)
+
 =cut
 */
 
@@ -216,16 +219,15 @@ Perl_pad_undef(pTHX_ CV* cv)
 	  "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];
@@ -233,25 +235,26 @@ Perl_pad_undef(pTHX_ CV* cv)
 	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--];
@@ -434,6 +437,14 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
     /* 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;
 }
 
@@ -611,6 +622,8 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv)
 	);
 
 	curlist = CvPADLIST(cv);
+	if (!curlist)
+	    continue; /* an undef CV */
 	svp = av_fetch(curlist, 0, FALSE);
 	if (!svp || *svp == &PL_sv_undef)
 	    continue;
@@ -1277,7 +1290,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 
     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
@@ -1359,6 +1372,9 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 	    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);
 	}
     }
 
@@ -1387,7 +1403,8 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 =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
 */
@@ -1406,18 +1423,14 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 	    && *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
 
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 772be5f237..65b2878b17 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -562,6 +562,18 @@ Found in file cv.h
 
 =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.
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index ea5c902c0f..c2e246a8d9 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -11,6 +11,67 @@ format but are not marked as part of the Perl API. In other words,
 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
 
 
@@ -550,7 +611,8 @@ Found in file pad.c
 =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)
 
@@ -651,6 +713,9 @@ 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 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
diff --git a/pp_ctl.c b/pp_ctl.c
index 2bebcbcf58..143888d99a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2700,7 +2700,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     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 */
 
diff --git a/sv.c b/sv.c
index 90a99dfd62..a21cedf50e 100644
--- a/sv.c
+++ b/sv.c
@@ -9602,12 +9602,11 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 	  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;
diff --git a/t/op/closure.t b/t/op/closure.t
index 4e8694e756..6a81a44f36 100755
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -13,7 +13,7 @@ BEGIN {
 
 use Config;
 
-print "1..177\n";
+print "1..181\n";
 
 my $test = 1;
 sub test (&) {
@@ -510,11 +510,33 @@ END
 
 }
 
-# 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;
@@ -549,3 +571,36 @@ test {1};
 }
 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' }
+}