From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 23 Jun 2005 21:30:33 +0000 (+0000)
Subject: Remove the reference loop between symbol tables and typeglobs.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e15faf7d09c73a41f95fbe6a0045ad5b17c899a6;p=p5sagit%2Fp5-mst-13.2.git

Remove the reference loop between symbol tables and typeglobs.
Typeglobs now have a weak reference onto their symbol table.

p4raw-id: //depot/perl@24966
---

diff --git a/embed.fnc b/embed.fnc
index 20df862..a9b5afb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1229,14 +1229,17 @@ s	|void	|debprof	|const OP *o
 s	|SV*	|save_scalar_at	|SV **sptr
 #endif
 
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+po	|void	|sv_add_backref	|NN SV *tsv|NN SV *sv
+#endif
+
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 sR	|IV	|asIV		|NN SV* sv
 sR	|UV	|asUV		|NN SV* sv
 s	|void	|sv_unglob	|NN SV* sv
 s	|void	|not_a_number	|NN SV *sv
 s	|I32	|visit		|NN SVFUNC_t f|U32 flags|U32 mask
-s	|void	|sv_add_backref	|NN SV *tsv|NN SV *sv
-s	|void	|sv_del_backref	|NN SV *sv
+s	|void	|sv_del_backref	|NN SV *target|NN SV *ref
 sR	|SV *	|varname	|NULLOK GV *gv|NN const char *gvtype|PADOFFSET targ \
 				|NULLOK SV *keyname|I32 aindex|int subscript_type
 #  ifdef DEBUGGING
diff --git a/embed.h b/embed.h
index fa3dab0..7f67c22 100644
--- a/embed.h
+++ b/embed.h
@@ -1285,6 +1285,8 @@
 #define save_scalar_at		S_save_scalar_at
 #endif
 #endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#endif
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define asIV			S_asIV
@@ -1292,7 +1294,6 @@
 #define sv_unglob		S_sv_unglob
 #define not_a_number		S_not_a_number
 #define visit			S_visit
-#define sv_add_backref		S_sv_add_backref
 #define sv_del_backref		S_sv_del_backref
 #define varname			S_varname
 #endif
@@ -3249,6 +3250,10 @@
 #define save_scalar_at(a)	S_save_scalar_at(aTHX_ a)
 #endif
 #endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#endif
+#endif
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define asIV(a)			S_asIV(aTHX_ a)
@@ -3256,8 +3261,7 @@
 #define sv_unglob(a)		S_sv_unglob(aTHX_ a)
 #define not_a_number(a)		S_not_a_number(aTHX_ a)
 #define visit(a,b,c)		S_visit(aTHX_ a,b,c)
-#define sv_add_backref(a,b)	S_sv_add_backref(aTHX_ a,b)
-#define sv_del_backref(a)	S_sv_del_backref(aTHX_ a)
+#define sv_del_backref(a,b)	S_sv_del_backref(aTHX_ a,b)
 #define varname(a,b,c,d,e,f)	S_varname(aTHX_ a,b,c,d,e,f)
 #endif
 #  ifdef DEBUGGING
diff --git a/gv.c b/gv.c
index aaae2a2..7a078e8 100644
--- a/gv.c
+++ b/gv.c
@@ -132,7 +132,9 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     GvCVGEN(gv) = 0;
     GvEGV(gv) = gv;
     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
-    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
+    GvSTASH(gv) = stash;
+    if (stash)
+	Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
     GvNAME(gv) = savepvn(name, len);
     GvNAMELEN(gv) = len;
     if (multi || doproto)              /* doproto means it _was_ mentioned */
diff --git a/mg.c b/mg.c
index 9dfcd53..dcc3a90 100644
--- a/mg.c
+++ b/mg.c
@@ -2034,22 +2034,37 @@ Perl_vivify_defelem(pTHX_ SV *sv)
 int
 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
 {
-    AV * const av = (AV*)mg->mg_obj;
-    SV ** const svp = AvARRAY(av);
-    I32 i = AvFILLp(av);
+    AV *const av = (AV*)mg->mg_obj;
+    SV **svp = AvARRAY(av);
     PERL_UNUSED_ARG(sv);
 
-    while (i >= 0) {
-	if (svp[i]) {
-	    if (!SvWEAKREF(svp[i]))
-		Perl_croak(aTHX_ "panic: magic_killbackrefs");
-	    /* XXX Should we check that it hasn't changed? */
-	    SvRV_set(svp[i], 0);
-	    SvOK_off(svp[i]);
-	    SvWEAKREF_off(svp[i]);
-	    svp[i] = Nullsv;
-	}
-	i--;
+    if (svp) {
+	SV *const *const last = svp + AvFILLp(av);
+
+	while (svp <= last) {
+	    if (*svp) {
+		SV *const referrer = *svp;
+		if (SvWEAKREF(referrer)) {
+		    /* XXX Should we check that it hasn't changed? */
+		    SvRV_set(referrer, 0);
+		    SvOK_off(referrer);
+		    SvWEAKREF_off(referrer);
+		} else if (SvTYPE(referrer) == SVt_PVGV ||
+			   SvTYPE(referrer) == SVt_PVLV) {
+		    /* You lookin' at me?  */
+		    assert(GvSTASH(referrer));
+		    assert(GvSTASH(referrer) == (HV*)sv);
+		    GvSTASH(referrer) = 0;
+		} else {
+		    Perl_croak(aTHX_
+			       "panic: magic_killbackrefs (flags=%"UVxf")",
+			       SvFLAGS(referrer));
+		}
+
+		*svp = Nullsv;
+	    }
+	    svp++;
+	}
     }
     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
     return 0;
diff --git a/pad.c b/pad.c
index 9c2b5a2..ed68c40 100644
--- a/pad.c
+++ b/pad.c
@@ -344,7 +344,8 @@ Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake
     }
     if (ourstash) {
 	SvFLAGS(namesv) |= SVpad_OUR;
-	GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
+	GvSTASH(namesv) = ourstash;
+	Perl_sv_add_backref(aTHX_ (SV*)ourstash, namesv);
     }
 
     av_store(PL_comppad_name, offset, namesv);
diff --git a/proto.h b/proto.h
index dcd4403..36a0c41 100644
--- a/proto.h
+++ b/proto.h
@@ -2574,6 +2574,13 @@ STATIC void	S_debprof(pTHX_ const OP *o);
 STATIC SV*	S_save_scalar_at(pTHX_ SV **sptr);
 #endif
 
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+PERL_CALLCONV void	Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
+#endif
+
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 STATIC IV	S_asIV(pTHX_ SV* sv)
 			__attribute__warn_unused_result__
@@ -2592,13 +2599,10 @@ STATIC void	S_not_a_number(pTHX_ SV *sv)
 STATIC I32	S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
 			__attribute__nonnull__(pTHX_1);
 
-STATIC void	S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+STATIC void	S_sv_del_backref(pTHX_ SV *target, SV *ref)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
-STATIC void	S_sv_del_backref(pTHX_ SV *sv)
-			__attribute__nonnull__(pTHX_1);
-
 STATIC SV *	S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, SV *keyname, I32 aindex, int subscript_type)
 			__attribute__warn_unused_result__
 			__attribute__nonnull__(pTHX_2);
diff --git a/sv.c b/sv.c
index dbec48e..4d1bfb9 100644
--- a/sv.c
+++ b/sv.c
@@ -414,20 +414,20 @@ Perl_sv_report_used(pTHX)
 /* called by sv_clean_objs() for each live SV */
 
 static void
-do_clean_objs(pTHX_ SV *sv)
+do_clean_objs(pTHX_ SV *ref)
 {
-    SV* rv;
+    SV* target;
 
-    if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
-	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
-	if (SvWEAKREF(sv)) {
-	    sv_del_backref(sv);
-	    SvWEAKREF_off(sv);
-	    SvRV_set(sv, NULL);
+    if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+	if (SvWEAKREF(ref)) {
+	    sv_del_backref(target, ref);
+	    SvWEAKREF_off(ref);
+	    SvRV_set(ref, NULL);
 	} else {
-	    SvROK_off(sv);
-	    SvRV_set(sv, NULL);
-	    SvREFCNT_dec(rv);
+	    SvROK_off(ref);
+	    SvRV_set(ref, NULL);
+	    SvREFCNT_dec(target);
 	}
     }
 
@@ -3843,7 +3843,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 		if (dtype != SVt_PVLV)
 		    sv_upgrade(dstr, SVt_PVGV);
 		sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
-		GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
+		GvSTASH(dstr) = GvSTASH(sstr);
+		if (GvSTASH(dstr))
+		    Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
 		GvNAME(dstr) = savepvn(name, len);
 		GvNAMELEN(dstr) = len;
 		SvFAKE_on(dstr);	/* can coerce to non-glob */
@@ -5200,7 +5202,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv)
 	return sv;
     }
     tsv = SvRV(sv);
-    sv_add_backref(tsv, sv);
+    Perl_sv_add_backref(aTHX_ tsv, sv);
     SvWEAKREF_on(sv);
     SvREFCNT_dec(tsv);
     return sv;
@@ -5210,8 +5212,8 @@ Perl_sv_rvweaken(pTHX_ SV *sv)
  * back-reference to sv onto the array associated with the backref magic.
  */
 
-STATIC void
-S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+void
+Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
 {
     AV *av;
     MAGIC *mg;
@@ -5235,13 +5237,16 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
  */
 
 STATIC void
-S_sv_del_backref(pTHX_ SV *sv)
+S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
 {
     AV *av;
     SV **svp;
     I32 i;
-    SV * const tsv = SvRV(sv);
     MAGIC *mg = NULL;
+    if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+	if (PL_in_clean_all)
+	    return;
+    }
     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
 	Perl_croak(aTHX_ "panic: del_backref");
     av = (AV *)mg->mg_obj;
@@ -5574,10 +5579,11 @@ Perl_sv_clear(pTHX_ register SV *sv)
     case SVt_PV:
     case SVt_RV:
 	if (SvROK(sv)) {
+	    SV *target = SvRV(sv);
 	    if (SvWEAKREF(sv))
-	        sv_del_backref(sv);
+	        sv_del_backref(target, sv);
 	    else
-	        SvREFCNT_dec(SvRV(sv));
+	        SvREFCNT_dec(target);
 	}
 #ifdef PERL_OLD_COPY_ON_WRITE
 	else if (SvPVX_const(sv)) {
@@ -5654,7 +5660,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
 	SvFLAGS(sv) |= SVTYPEMASK;
 	/* decrease refcount of the stash that owns this GV, if any */
 	if (stash)
-	    SvREFCNT_dec(stash);
+	    sv_del_backref((SV*)stash, sv);
 	return; /* not break, SvFLAGS reset already happened */
     case SVt_PVBM:
 	del_XPVBM(SvANY(sv));
@@ -8356,7 +8362,7 @@ S_sv_unglob(pTHX_ SV *sv)
     if (GvGP(sv))
 	gp_free((GV*)sv);
     if (GvSTASH(sv)) {
-	SvREFCNT_dec(GvSTASH(sv));
+	sv_del_backref((SV*)GvSTASH(sv), sv);
 	GvSTASH(sv) = Nullhv;
     }
     sv_unmagic(sv, PERL_MAGIC_glob);
@@ -8388,24 +8394,24 @@ See C<SvROK_off>.
 */
 
 void
-Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
+Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
 {
-    SV* rv = SvRV(sv);
+    SV* target = SvRV(ref);
 
-    if (SvWEAKREF(sv)) {
-    	sv_del_backref(sv);
-	SvWEAKREF_off(sv);
-	SvRV_set(sv, NULL);
+    if (SvWEAKREF(ref)) {
+    	sv_del_backref(target, ref);
+	SvWEAKREF_off(ref);
+	SvRV_set(ref, NULL);
 	return;
     }
-    SvRV_set(sv, NULL);
-    SvROK_off(sv);
-    /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+    SvRV_set(ref, NULL);
+    SvROK_off(ref);
+    /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
        assigned to as BEGIN {$a = \"Foo"} will fail.  */
-    if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
-	SvREFCNT_dec(rv);
+    if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
+	SvREFCNT_dec(target);
     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
-	sv_2mortal(rv);		/* Schedule for freeing later */
+	sv_2mortal(target);	/* Schedule for freeing later */
 }
 
 /*
@@ -10491,7 +10497,9 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 		break;
 	    case SVt_PVGV:
 		GvNAME(dstr)	= SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
-		GvSTASH(dstr)	= hv_dup_inc(GvSTASH(dstr), param);
+		GvSTASH(dstr)	= hv_dup(GvSTASH(dstr), param);
+		/* Don't call sv_add_backref here as it's going to be created
+		   as part of the magic cloning of the symbol table.  */
 		GvGP(dstr)	= gp_dup(GvGP(dstr), param);
 		(void)GpREFCNT_inc(GvGP(dstr));
 		break;
diff --git a/t/op/gv.t b/t/op/gv.t
index 655e624..66c1cfd 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 
 require './test.pl';
-plan( tests => 66 );
+plan( tests => 68 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -246,6 +246,19 @@ is($j[0], 1);
     is($x, "rocks\n");
 }
 
+{
+    my $output = runperl(prog => <<'EOPROG', stderr => 1);
+package M;
+sub DESTROY {warn "Farewell $_[0]"}
+package main;
+
+bless \$A::B, 'M';
+*A:: = \*B::;
+EOPROG
+    like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
+    unlike($output, qr/global destruction/,
+           "unreferenced symbol tables should be cleaned up immediately");
+}
 __END__
 Perl
 Rules