develooper Front page | perl.perl5.porters | Postings from March 2001

Re: CvOUTSIDE

Thread Previous | Thread Next
From:
Gurusamy Sarathy
Date:
March 12, 2001 10:10
Subject:
Re: CvOUTSIDE
Message ID:
200103121809.f2CI9ca14322@smtp3.ActiveState.com
FYI, here's how that patch finally turned out.


Sarathy
gsar@ActiveState.com
-----------------------------------8<-----------------------------------
Change 9108 by gsar@sparcu10v8-gsar on 2001/03/12 10:21:31

	fix memory leak in C<sub X { sub {} }> arising from a refcount
	loop between the outer sub and the inner prototype anonsub
	
	this also enables closures returned by subroutines that
	subsequently get redefined to work without generating coredumps :)
	
	completely removed the free_closures() hack--it shouldn't be
	needed anymore

Affected files ...

... //depot/maint-5.6/perl/MANIFEST#41 edit
... //depot/maint-5.6/perl/embed.h#31 edit
... //depot/maint-5.6/perl/embed.pl#46 edit
... //depot/maint-5.6/perl/op.c#36 edit
... //depot/maint-5.6/perl/op.h#9 edit
... //depot/maint-5.6/perl/pod/perlapi.pod#34 edit
... //depot/maint-5.6/perl/pp_ctl.c#31 edit
... //depot/maint-5.6/perl/proto.h#36 edit
... //depot/maint-5.6/perl/sv.c#54 edit
... //depot/maint-5.6/perl/t/op/anonsub.t#1 add

Differences ...

==== //depot/maint-5.6/perl/MANIFEST#41 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~	Mon Mar 12 10:08:11 2001
+++ perl/MANIFEST	Mon Mar 12 10:08:11 2001
@@ -1407,6 +1407,7 @@
 t/lib/timelocal.t	See if Time::Local works
 t/lib/trig.t		See if Math::Trig works
 t/op/64bitint.t		See if 64 bit integers work
+t/op/anonsub.t		See if anonymous subroutines work
 t/op/append.t		See if . works
 t/op/args.t		See if operations on @_ work
 t/op/arith.t		See if arithmetic works

==== //depot/maint-5.6/perl/embed.h#31 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~	Mon Mar 12 10:08:11 2001
+++ perl/embed.h	Mon Mar 12 10:08:11 2001
@@ -970,7 +970,6 @@
 #define dopoptoloop		S_dopoptoloop
 #define dopoptosub		S_dopoptosub
 #define dopoptosub_at		S_dopoptosub_at
-#define free_closures		S_free_closures
 #define save_lines		S_save_lines
 #define doeval			S_doeval
 #define doopen_pmc		S_doopen_pmc
@@ -2430,7 +2429,6 @@
 #define dopoptoloop(a)		S_dopoptoloop(aTHX_ a)
 #define dopoptosub(a)		S_dopoptosub(aTHX_ a)
 #define dopoptosub_at(a,b)	S_dopoptosub_at(aTHX_ a,b)
-#define free_closures()		S_free_closures(aTHX)
 #define save_lines(a,b)		S_save_lines(aTHX_ a,b)
 #define doeval(a,b)		S_doeval(aTHX_ a,b)
 #define doopen_pmc(a,b)		S_doopen_pmc(aTHX_ a,b)
@@ -4735,8 +4733,6 @@
 #define dopoptosub		S_dopoptosub
 #define S_dopoptosub_at		CPerlObj::S_dopoptosub_at
 #define dopoptosub_at		S_dopoptosub_at
-#define S_free_closures		CPerlObj::S_free_closures
-#define free_closures		S_free_closures
 #define S_save_lines		CPerlObj::S_save_lines
 #define save_lines		S_save_lines
 #define S_doeval		CPerlObj::S_doeval

==== //depot/maint-5.6/perl/embed.pl#46 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~	Mon Mar 12 10:08:11 2001
+++ perl/embed.pl	Mon Mar 12 10:08:11 2001
@@ -2338,7 +2338,6 @@
 s	|I32	|dopoptoloop	|I32 startingblock
 s	|I32	|dopoptosub	|I32 startingblock
 s	|I32	|dopoptosub_at	|PERL_CONTEXT* cxstk|I32 startingblock
-s	|void	|free_closures
 s	|void	|save_lines	|AV *array|SV *sv
 s	|OP*	|doeval		|int gimme|OP** startop
 s	|PerlIO *|doopen_pmc	|const char *name|const char *mode

==== //depot/maint-5.6/perl/op.c#36 (text) ====
Index: perl/op.c
--- perl/op.c.~1~	Mon Mar 12 10:08:11 2001
+++ perl/op.c	Mon Mar 12 10:08:11 2001
@@ -4133,14 +4133,19 @@
 	SAVEVPTR(PL_curpad);
 	PL_curpad = 0;
 
-	if (!CvCLONED(cv))
-	    op_free(CvROOT(cv));
+	op_free(CvROOT(cv));
 	CvROOT(cv) = Nullop;
 	LEAVE;
     }
     SvPOK_off((SV*)cv);		/* forget prototype */
     CvGV(cv) = Nullgv;
-    SvREFCNT_dec(CvOUTSIDE(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))
+	SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
     if (CvPADLIST(cv)) {
 	/* may be during global destruction */
@@ -4248,7 +4253,7 @@
     CvFILE(cv)		= CvFILE(proto);
     CvGV(cv)		= CvGV(proto);
     CvSTASH(cv)		= CvSTASH(proto);
-    CvROOT(cv)		= CvROOT(proto);
+    CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)		= CvSTART(proto);
     if (outside)
 	CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc(outside);
@@ -4570,8 +4575,30 @@
 	CvOUTSIDE(PL_compcv) = 0;
 	CvPADLIST(cv) = CvPADLIST(PL_compcv);
 	CvPADLIST(PL_compcv) = 0;
-	if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
-	    CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+	/* inner references to PL_compcv must be fixed up ... */
+	{
+	    AV *padlist = CvPADLIST(cv);
+	    AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+	    AV *comppad = (AV*)AvARRAY(padlist)[1];
+	    SV **namepad = AvARRAY(comppad_name);
+	    SV **curpad = AvARRAY(comppad);
+	    for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+		SV *namesv = namepad[ix];
+		if (namesv && namesv != &PL_sv_undef
+		    && *SvPVX(namesv) == '&')
+		{
+		    CV *innercv = (CV*)curpad[ix];
+		    if (CvOUTSIDE(innercv) == PL_compcv) {
+			CvOUTSIDE(innercv) = cv;
+			if (!CvANON(innercv) || CvCLONED(innercv)) {
+			    (void)SvREFCNT_inc(cv);
+			    SvREFCNT_dec(PL_compcv);
+			}
+		    }
+		}
+	    }
+	}
+	/* ... before we throw it away */
 	SvREFCNT_dec(PL_compcv);
     }
     else {
@@ -4675,6 +4702,13 @@
 	}
     }
 
+    /* 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);

==== //depot/maint-5.6/perl/op.h#9 (text) ====
Index: perl/op.h
--- perl/op.h.~1~	Mon Mar 12 10:08:11 2001
+++ perl/op.h	Mon Mar 12 10:08:11 2001
@@ -410,19 +410,17 @@
 #  define OP_REFCNT_LOCK		MUTEX_LOCK(&PL_op_mutex)
 #  define OP_REFCNT_UNLOCK		MUTEX_UNLOCK(&PL_op_mutex)
 #  define OP_REFCNT_TERM		MUTEX_DESTROY(&PL_op_mutex)
-#  define OpREFCNT_set(o,n)		((o)->op_targ = (n))
-#  define OpREFCNT_inc(o)		((o) ? (++(o)->op_targ, (o)) : Nullop)
-#  define OpREFCNT_dec(o)		(--(o)->op_targ)
 #else
 #  define OP_REFCNT_INIT		NOOP
 #  define OP_REFCNT_LOCK		NOOP
 #  define OP_REFCNT_UNLOCK		NOOP
 #  define OP_REFCNT_TERM		NOOP
-#  define OpREFCNT_set(o,n)		NOOP
-#  define OpREFCNT_inc(o)		(o)
-#  define OpREFCNT_dec(o)		0
 #endif
 
+#define OpREFCNT_set(o,n)		((o)->op_targ = (n))
+#define OpREFCNT_inc(o)			((o) ? (++(o)->op_targ, (o)) : Nullop)
+#define OpREFCNT_dec(o)			(--(o)->op_targ)
+
 /* flags used by Perl_load_module() */
 #define PERL_LOADMOD_DENY		0x1
 #define PERL_LOADMOD_NOIMPORT		0x2

==== //depot/maint-5.6/perl/pod/perlapi.pod#34 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod.~1~	Mon Mar 12 10:08:11 2001
+++ perl/pod/perlapi.pod	Mon Mar 12 10:08:11 2001
@@ -2338,19 +2338,19 @@
 =for hackers
 Found in file sv.h
 
-=item svtype
+=item SvTYPE
+
+Returns the type of the SV.  See C<svtype>.
 
-An enum of flags for Perl types.  These are found in the file B<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+	svtype	SvTYPE(SV* sv)
 
 =for hackers
 Found in file sv.h
 
-=item SvTYPE
+=item svtype
 
-Returns the type of the SV.  See C<svtype>.
-
-	svtype	SvTYPE(SV* sv)
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
 
 =for hackers
 Found in file sv.h

==== //depot/maint-5.6/perl/pp_ctl.c#31 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c.~1~	Mon Mar 12 10:08:11 2001
+++ perl/pp_ctl.c	Mon Mar 12 10:08:11 2001
@@ -1336,41 +1336,6 @@
     }
 }
 
-/*
- * Closures mentioned at top level of eval cannot be referenced
- * again, and their presence indirectly causes a memory leak.
- * (Note that the fact that compcv and friends are still set here
- * is, AFAIK, an accident.)  --Chip
- *
- * XXX need to get comppad et al from eval's cv rather than
- * relying on the incidental global values.
- */
-STATIC void
-S_free_closures(pTHX)
-{
-    SV **svp = AvARRAY(PL_comppad_name);
-    I32 ix;
-    for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
-	SV *sv = svp[ix];
-	if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
-	    SvREFCNT_dec(sv);
-	    svp[ix] = &PL_sv_undef;
-
-	    sv = PL_curpad[ix];
-	    if (CvCLONE(sv)) {
-		SvREFCNT_dec(CvOUTSIDE(sv));
-		CvOUTSIDE(sv) = Nullcv;
-	    }
-	    else {
-		SvREFCNT_dec(sv);
-		sv = NEWSV(0,0);
-		SvPADTMP_on(sv);
-		PL_curpad[ix] = sv;
-	    }
-	}
-    }
-}
-
 void
 Perl_qerror(pTHX_ SV *err)
 {
@@ -1901,8 +1866,6 @@
 	POPEVAL(cx);
 	if (CxTRYBLOCK(cx))
 	    break;
-	if (AvFILLp(PL_comppad_name) >= 0)
-	    free_closures();
 	lex_end();
 	if (optype == OP_REQUIRE &&
 	    (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
@@ -3445,9 +3408,6 @@
     }
     PL_curpm = newpm;	/* Don't pop $1 et al till now */
 
-    if (AvFILLp(PL_comppad_name) >= 0)
-	free_closures();
-
 #ifdef DEBUGGING
     assert(CvDEPTH(PL_compcv) == 1);
 #endif

==== //depot/maint-5.6/perl/proto.h#36 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~	Mon Mar 12 10:08:11 2001
+++ perl/proto.h	Mon Mar 12 10:08:11 2001
@@ -1082,7 +1082,6 @@
 STATIC I32	S_dopoptoloop(pTHX_ I32 startingblock);
 STATIC I32	S_dopoptosub(pTHX_ I32 startingblock);
 STATIC I32	S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock);
-STATIC void	S_free_closures(pTHX);
 STATIC void	S_save_lines(pTHX_ AV *array, SV *sv);
 STATIC OP*	S_doeval(pTHX_ int gimme, OP** startop);
 STATIC PerlIO *	S_doopen_pmc(pTHX_ const char *name, const char *mode);

==== //depot/maint-5.6/perl/sv.c#54 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~	Mon Mar 12 10:08:11 2001
+++ perl/sv.c	Mon Mar 12 10:08:11 2001
@@ -7186,7 +7186,10 @@
 	}
 	else
 	    CvPADLIST(dstr)	= av_dup_inc(CvPADLIST(sstr));
-	CvOUTSIDE(dstr)	= cv_dup_inc(CvOUTSIDE(sstr));
+	if (!CvANON(sstr) || CvCLONED(sstr))
+	    CvOUTSIDE(dstr)	= cv_dup_inc(CvOUTSIDE(sstr));
+	else
+	    CvOUTSIDE(dstr)	= cv_dup(CvOUTSIDE(sstr));
 	CvFLAGS(dstr)	= CvFLAGS(sstr);
 	break;
     default:

==== //depot/maint-5.6/perl/t/op/anonsub.t#1 (xtext) ====
Index: perl/t/op/anonsub.t
--- perl/t/op/anonsub.t.~1~	Mon Mar 12 10:08:11 2001
+++ perl/t/op/anonsub.t	Mon Mar 12 10:08:11 2001
@@ -0,0 +1,93 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = '../lib';
+$Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
+$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "asubtmp000";
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+for (@prgs){
+    my $switch = "";
+    if (s/^\s*(-\w+)//){
+       $switch = $1;
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    open TEST, ">$tmpfile";
+    print TEST "$prog\n";
+    close TEST;
+    my $results = $Is_VMS ?
+                  `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
+		      $Is_MSWin32 ?  
+			  `.\\perl -I../lib $switch $tmpfile 2>&1` :
+			      `./perl $switch $tmpfile 2>&1`;
+    my $status = $?;
+    $results =~ s/\n+$//;
+    # allow expected output to be written as if $prog is on STDIN
+    $results =~ s/runltmp\d+/-/g;
+    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
+    $expected =~ s/\n+$//;
+    if ($results ne $expected) {
+       print STDERR "PROG: $switch\n$prog\n";
+       print STDERR "EXPECTED:\n$expected\n";
+       print STDERR "GOT:\n$results\n";
+       print "not ";
+    }
+    print "ok ", ++$i, "\n";
+}
+
+__END__
+sub X {
+    my $n = "ok 1\n";
+    sub { print $n };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    sub {
+        my $dummy = $n;	# eval can't close on $n without internal reference
+	eval 'print $n';
+	die $@ if $@;
+    };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub { print $n }';
+}
+my $x = X();
+die $@ if $@;
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X;
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub Y { my $p = shift; $p->() }';
+    die $@ if $@;
+    Y(sub { print $n });
+}
+X();
+EXPECT
+ok 1
End of Patch.

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About