This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Proper fix for CvOUTSIDE weak refcounting
authorDave Mitchell <davem@fdisolutions.com>
Tue, 10 Dec 2002 01:26:44 +0000 (01:26 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Sat, 14 Dec 2002 22:34:25 +0000 (22:34 +0000)
Message-ID: <20021210012644.A7843@fdgroup.com>

p4raw-id: //depot/perl@18302

13 files changed:
cv.h
dump.c
embed.fnc
ext/B/B/Deparse.pm
ext/B/defsubs_h.PL
ext/Devel/Peek/Peek.t
op.c
pad.c
pod/perlapi.pod
pod/perlintern.pod
pp_ctl.c
sv.c
t/op/closure.t

diff --git a/cv.h b/cv.h
index 4611387..6e8383a 100644 (file)
--- 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 d874d32..e7f0af3 100644 (file)
--- 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,");
index 08a8f9d..5c56027 100644 (file)
--- 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
index b54a5af..37b98a0 100644 (file)
@@ -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];
        }
index 37bfeb7..2c2aecf 100644 (file)
@@ -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
                      ))
  {
index cdcf811..a1ed214 100644 (file)
@@ -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 c46bbfc..46347da 100644 (file)
--- 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 e1ac067..560638f 100644 (file)
--- 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
 
index 772be5f..65b2878 100644 (file)
@@ -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.
index ea5c902..c2e246a 100644 (file)
@@ -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
index 2bebcbc..143888d 100644 (file)
--- 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 90a99df..a21cedf 100644 (file)
--- 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;
index 4e8694e..6a81a44 100755 (executable)
@@ -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' }
+}