From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Sun, 18 Mar 2001 18:39:21 +0000 (+0000)
Subject: Integrate change #9197 from maintperl to mainline.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5226ed68d621722eb9fc1e4a926ee31169462427;p=p5sagit%2Fp5-mst-13.2.git

Integrate change #9197 from maintperl to mainline.

more thorough cleaning of arenas.

p4raw-link: @9197 on //depot/maint-5.6/perl: ec3d44d040803cac937295d8f4740e6a36ba30fb

p4raw-id: //depot/perl@9201
p4raw-integrated: from //depot/maint-5.6/perl@9200 'merge in'
	t/op/sort.t (@7895..) perl.c (@9064..) sv.c (@9108..) embed.pl
	proto.h (@9154..)
---

diff --git a/embed.pl b/embed.pl
index bd46b1c..9557a2b 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2011,7 +2011,7 @@ Apd	|void	|sv_catpv	|SV* sv|const char* ptr
 Apd	|void	|sv_catpvn	|SV* sv|const char* ptr|STRLEN len
 Apd	|void	|sv_catsv	|SV* dsv|SV* ssv
 Apd	|void	|sv_chop	|SV* sv|char* ptr
-p	|void	|sv_clean_all
+p	|I32	|sv_clean_all
 p	|void	|sv_clean_objs
 Apd	|void	|sv_clear	|SV* sv
 Apd	|I32	|sv_cmp		|SV* sv1|SV* sv2
@@ -2493,7 +2493,7 @@ s	|void	|del_xpvbm	|XPVBM* p
 s	|void	|del_xrv	|XRV* p
 s	|void	|sv_unglob	|SV* sv
 s	|void	|not_a_number	|SV *sv
-s	|void	|visit		|SVFUNC_t f
+s	|I32	|visit		|SVFUNC_t f
 s	|void	|sv_add_backref	|SV *tsv|SV *sv
 s	|void	|sv_del_backref	|SV *sv
 #  if defined(DEBUGGING)
diff --git a/perl.c b/perl.c
index 3e999c4..bfaafd1 100644
--- a/perl.c
+++ b/perl.c
@@ -300,7 +300,6 @@ void
 perl_destruct(pTHXx)
 {
     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
-    I32 last_sv_count;
     HV *hv;
 #ifdef USE_THREADS
     Thread t;
@@ -663,13 +662,13 @@ perl_destruct(pTHXx)
     }
 
     /* Now absolutely destruct everything, somehow or other, loops or no. */
-    last_sv_count = 0;
     SvFLAGS(PL_fdpid) |= SVTYPEMASK;		/* don't clean out pid table now */
     SvFLAGS(PL_strtab) |= SVTYPEMASK;		/* don't clean out strtab now */
-    while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
-	last_sv_count = PL_sv_count;
-	sv_clean_all();
-    }
+
+    /* the 2 is for PL_fdpid and PL_strtab */
+    while (PL_sv_count > 2 && sv_clean_all())
+	;
+
     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
     SvFLAGS(PL_fdpid) |= SVt_PVAV;
     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
diff --git a/proto.h b/proto.h
index 1201e64..3e3a5d2 100644
--- a/proto.h
+++ b/proto.h
@@ -736,7 +736,7 @@ PERL_CALLCONV void	Perl_sv_catpv(pTHX_ SV* sv, const char* ptr);
 PERL_CALLCONV void	Perl_sv_catpvn(pTHX_ SV* sv, const char* ptr, STRLEN len);
 PERL_CALLCONV void	Perl_sv_catsv(pTHX_ SV* dsv, SV* ssv);
 PERL_CALLCONV void	Perl_sv_chop(pTHX_ SV* sv, char* ptr);
-PERL_CALLCONV void	Perl_sv_clean_all(pTHX);
+PERL_CALLCONV I32	Perl_sv_clean_all(pTHX);
 PERL_CALLCONV void	Perl_sv_clean_objs(pTHX);
 PERL_CALLCONV void	Perl_sv_clear(pTHX_ SV* sv);
 PERL_CALLCONV I32	Perl_sv_cmp(pTHX_ SV* sv1, SV* sv2);
@@ -1219,7 +1219,7 @@ STATIC void	S_del_xpvbm(pTHX_ XPVBM* p);
 STATIC void	S_del_xrv(pTHX_ XRV* p);
 STATIC void	S_sv_unglob(pTHX_ SV* sv);
 STATIC void	S_not_a_number(pTHX_ SV *sv);
-STATIC void	S_visit(pTHX_ SVFUNC_t f);
+STATIC I32	S_visit(pTHX_ SVFUNC_t f);
 STATIC void	S_sv_add_backref(pTHX_ SV *tsv, SV *sv);
 STATIC void	S_sv_del_backref(pTHX_ SV *sv);
 #  if defined(DEBUGGING)
diff --git a/sv.c b/sv.c
index 18c5ac9..d08c378 100644
--- a/sv.c
+++ b/sv.c
@@ -147,20 +147,24 @@ S_more_sv(pTHX)
     return sv;
 }
 
-STATIC void
+STATIC I32
 S_visit(pTHX_ SVFUNC_t f)
 {
     SV* sva;
     SV* sv;
     register SV* svend;
+    I32 visited = 0;
 
     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 	svend = &sva[SvREFCNT(sva)];
 	for (sv = sva + 1; sv < svend; ++sv) {
-	    if (SvTYPE(sv) != SVTYPEMASK)
+	    if (SvTYPE(sv) != SVTYPEMASK) {
 		(FCALL)(aTHXo_ sv);
+		++visited;
+	    }
 	}
     }
+    return visited;
 }
 
 void
@@ -181,12 +185,14 @@ Perl_sv_clean_objs(pTHX)
     PL_in_clean_objs = FALSE;
 }
 
-void
+I32
 Perl_sv_clean_all(pTHX)
 {
+    I32 cleaned;
     PL_in_clean_all = TRUE;
-    visit(do_clean_all);
+    cleaned = visit(do_clean_all);
     PL_in_clean_all = FALSE;
+    return cleaned;
 }
 
 void
diff --git a/t/op/sort.t b/t/op/sort.t
index c1dfb63..2a86b38 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -7,12 +7,6 @@ BEGIN {
 use warnings;
 print "1..58\n";
 
-# XXX known to leak scalars
-{
-  no warnings 'uninitialized';
-  $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-}
-
 # these shouldn't hang
 {
     no warnings;