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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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