In S_mro_get_linear_isa_dfs(), save copying by making a shared hash

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 4792ad1..f56d70c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3717,7 +3717,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
            Perl_croak(aTHX_ "Cannot copy to %s", type);
     } else if (sflags & SVf_ROK) {
        if (isGV_with_GP(dstr) && dtype == SVt_PVGV
-           && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+           && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
            sstr = SvRV(sstr);
            if (sstr == dstr) {
                if (GvIMPORTED(dstr) != GVf_IMPORTED
@@ -3728,10 +3728,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                GvMULTI_on(dstr);
                return;
            }
-           if (isGV_with_GP(sstr)) {
-               glob_assign_glob(dstr, sstr, dtype);
-               return;
-           }
+           glob_assign_glob(dstr, sstr, dtype);
+           return;
        }
 
        if (dtype >= SVt_PV) {
@@ -5007,6 +5005,24 @@ Perl_sv_rvweaken(pTHX_ SV *const sv)
  * back-reference to sv onto the array associated with the backref magic.
  */
 
+/* A discussion about the backreferences array and its refcount:
+ *
+ * The AV holding the backreferences is pointed to either as the mg_obj of
+ * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
+ * structure, from the xhv_backreferences field. (A HV without hv_aux will
+ * have the standard magic instead.) The array is created with a refcount
+ * of 2. This means that if during global destruction the array gets
+ * picked on first to have its refcount decremented by the random zapper,
+ * it won't actually be freed, meaning it's still theere for when its
+ * parent gets freed.
+ * When the parent SV is freed, in the case of magic, the magic is freed,
+ * Perl_magic_killbackrefs is called which decrements one refcount, then
+ * mg_obj is freed which kills the second count.
+ * In the vase of a HV being freed, one ref is removed by
+ * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
+ * calls.
+ */
+
 void
 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
 {
@@ -5035,7 +5051,7 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
            } else {
                av = newAV();
                AvREAL_off(av);
-               SvREFCNT_inc_simple_void(av);
+               SvREFCNT_inc_simple_void(av); /* see discussion above */
            }
            *avp = av;
        }
@@ -5048,9 +5064,7 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
            av = newAV();
            AvREAL_off(av);
            sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
-           /* av now has a refcnt of 2, which avoids it getting freed
-            * before us during global cleanup. The extra ref is removed
-            * by magic_killbackrefs() when tsv is being freed */
+           /* av now has a refcnt of 2; see discussion above */
        }
     }
     if (AvFILLp(av) >= AvMAX(av)) {
@@ -5086,14 +5100,11 @@ S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
        if (mg)
            av = (AV *)mg->mg_obj;
     }
-    if (!av) {
-       if (PL_in_clean_all)
-           return;
+
+    if (!av)
        Perl_croak(aTHX_ "panic: del_backref");
-    }
 
-    if (SvIS_FREED(av))
-       return;
+    assert(!SvIS_FREED(av));
 
     svp = AvARRAY(av);
     /* We shouldn't be in here more than once, but for paranoia reasons lets
@@ -5123,9 +5134,8 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
     PERL_UNUSED_ARG(sv);
 
-    /* Not sure why the av can get freed ahead of its sv, but somehow it does
-       in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
-    if (svp && !SvIS_FREED(av)) {
+    assert(!svp || !SvIS_FREED(av));
+    if (svp) {
        SV *const *const last = svp + AvFILLp(av);
 
        while (svp <= last) {
@@ -7492,6 +7502,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
     if (!hash)
        PERL_HASH(hash, src, len);
     new_SV(sv);
+    /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
+       changes here, update it there too.  */
     sv_upgrade(sv, SVt_PV);
     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
     SvCUR_set(sv, len);