Change 18302 by rgs@rgs-home on 2002/12/14 22:34:25 Subject: Proper fix for CvOUTSIDE weak refcounting From: Dave Mitchell <[EMAIL PROTECTED]> Date: Tue, 10 Dec 2002 01:26:44 +0000 Message-ID: <[EMAIL PROTECTED]>
Affected files ... ... //depot/perl/cv.h#40 edit ... //depot/perl/dump.c#128 edit ... //depot/perl/embed.fnc#57 edit ... //depot/perl/ext/B/B/Deparse.pm#125 edit ... //depot/perl/ext/B/defsubs_h.PL#14 edit ... //depot/perl/ext/Devel/Peek/Peek.t#21 edit ... //depot/perl/op.c#530 edit ... //depot/perl/pad.c#7 edit ... //depot/perl/pod/perlapi.pod#145 edit ... //depot/perl/pod/perlintern.pod#26 edit ... //depot/perl/pp_ctl.c#330 edit ... //depot/perl/sv.c#603 edit ... //depot/perl/t/op/closure.t#17 edit Differences ... ==== //depot/perl/cv.h#40 (text) ==== Index: perl/cv.h --- perl/cv.h#39~18220~ Sun Dec 1 16:58:54 2002 +++ perl/cv.h Sat Dec 14 14:34:25 2002 @@ -81,6 +81,8 @@ #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 @@ #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 +*/ ==== //depot/perl/dump.c#128 (text) ==== Index: perl/dump.c --- perl/dump.c#127~18220~ Sun Dec 1 16:58:54 2002 +++ perl/dump.c Sat Dec 14 14:34:25 2002 @@ -981,6 +981,7 @@ 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,"); ==== //depot/perl/embed.fnc#57 (text) ==== Index: perl/embed.fnc --- perl/embed.fnc#56~18220~ Sun Dec 1 16:58:54 2002 +++ perl/embed.fnc Sat Dec 14 14:34:25 2002 @@ -130,7 +130,7 @@ 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 ==== //depot/perl/ext/B/B/Deparse.pm#125 (text) ==== Index: perl/ext/B/B/Deparse.pm --- perl/ext/B/B/Deparse.pm#124~17898~ Wed Sep 11 13:58:46 2002 +++ perl/ext/B/B/Deparse.pm Sat Dec 14 14:34:25 2002 @@ -15,7 +15,7 @@ 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 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 @@ 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]; } ==== //depot/perl/ext/B/defsubs_h.PL#14 (text) ==== Index: perl/ext/B/defsubs_h.PL --- perl/ext/B/defsubs_h.PL#13~14104~ Sun Jan 6 07:08:14 2002 +++ perl/ext/B/defsubs_h.PL Sat Dec 14 14:34:25 2002 @@ -13,7 +13,7 @@ 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 )) { ==== //depot/perl/ext/Devel/Peek/Peek.t#21 (text) ==== Index: perl/ext/Devel/Peek/Peek.t --- perl/ext/Devel/Peek/Peek.t#20~18223~ Sun Dec 1 18:46:17 2002 +++ perl/ext/Devel/Peek/Peek.t Sat Dec 14 14:34:25 2002 @@ -206,7 +206,7 @@ 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 @@ DEPTH = 0 (?: MUTEXP = $ADDR OWNER = $ADDR -)? FLAGS = 0x4 +)? FLAGS = 0x404 OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) ==== //depot/perl/op.c#530 (text) ==== Index: perl/op.c --- perl/op.c#529~18220~ Sun Dec 1 16:58:54 2002 +++ perl/op.c Sat Dec 14 14:34:25 2002 @@ -3753,11 +3753,20 @@ 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 @@ 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 @@ -4160,13 +4166,6 @@ if (ps && !*ps && op_const_sv(block, cv)) 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; ==== //depot/perl/pad.c#7 (text) ==== Index: perl/pad.c --- perl/pad.c#6~18223~ Sun Dec 1 18:46:17 2002 +++ perl/pad.c Sat Dec 14 14:34:25 2002 @@ -198,6 +198,9 @@ 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 @@ "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 @@ 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 @@ /* 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 @@ ); 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 @@ 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 @@ 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 @@ =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,17 +1423,13 @@ && *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 ==== //depot/perl/pod/perlapi.pod#145 (text+w) ==== Index: perl/pod/perlapi.pod --- perl/pod/perlapi.pod#144~17990~ Thu Oct 10 04:19:57 2002 +++ perl/pod/perlapi.pod Sat Dec 14 14:34:25 2002 @@ -562,6 +562,18 @@ =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. ==== //depot/perl/pod/perlintern.pod#26 (text+w) ==== Index: perl/pod/perlintern.pod --- perl/pod/perlintern.pod#25~18239~ Tue Dec 3 04:49:01 2002 +++ perl/pod/perlintern.pod Sat Dec 14 14:34:25 2002 @@ -11,6 +11,67 @@ 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 @@ =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) @@ -650,6 +712,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) ==== //depot/perl/pp_ctl.c#330 (text) ==== Index: perl/pp_ctl.c --- perl/pp_ctl.c#329~18264~ Sun Dec 8 14:04:39 2002 +++ perl/pp_ctl.c Sat Dec 14 14:34:25 2002 @@ -2700,7 +2700,7 @@ 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 */ ==== //depot/perl/sv.c#603 (text) ==== Index: perl/sv.c --- perl/sv.c#602~18229~ Mon Dec 2 07:43:16 2002 +++ perl/sv.c Sat Dec 14 14:34:25 2002 @@ -9602,12 +9602,11 @@ 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; ==== //depot/perl/t/op/closure.t#17 (xtext) ==== Index: perl/t/op/closure.t --- perl/t/op/closure.t#16~18223~ Sun Dec 1 18:46:17 2002 +++ perl/t/op/closure.t Sat Dec 14 14:34:25 2002 @@ -13,7 +13,7 @@ use Config; -print "1..177\n"; +print "1..181\n"; my $test = 1; sub test (&) { @@ -510,11 +510,33 @@ } -# 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 @@ } 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' } +} End of Patch.