[perl #126410] keep the DESTROY cache in mro_meta
authorTony Cook <tony@develop-help.com>
Mon, 18 Jan 2016 06:42:32 +0000 (17:42 +1100)
committerTony Cook <tony@develop-help.com>
Mon, 8 Feb 2016 03:52:51 +0000 (14:52 +1100)
We're already keeping destroy_gen there, so keep the CV there too.

The previous implementation, introduced in 8c34e50d, kept the
destroy method cache in the stash's stash, which broke B's SvSTASH
method.

Before that, the DESTROY method was cached in overload magic.

A previous version of this patch didn't clear the destructor cache on
a clone, which caused ext/XS-APItest/t/clone_with_stack.t to fail.

ext/B/t/sv_stash.t
hv.h
mro_core.c
sv.c

index eaaabcf..e9abf4d 100644 (file)
@@ -14,7 +14,6 @@ plan 1;
 # RT #126410 = used to coredump when doing SvSTASH on %version::
 
 TODO: {
-    local $TODO = 'Broken since c07f9fb2c7 - revert of a revert: slowed down detruction with no DESTROY';
     fresh_perl_is(
         'use B; version->new("v5.22.0"); $s = B::svref_2object(\%version::); $s->SvSTASH; print "ok\n"',
         "ok\n", { stderr => 1 }, 'RT #126410 - SvSTASH against %version::'
diff --git a/hv.h b/hv.h
index e30f262..d7cc42f 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -82,6 +82,7 @@ struct mro_meta {
     const struct mro_alg *mro_which; /* which mro alg is in use? */
     HV      *isa;            /* Everything this class @ISA */
     HV      *super;          /* SUPER method cache */
+    CV      *destroy;        /* DESTROY method if destroy_gen non-zero */
     U32     destroy_gen;     /* Generation number of DESTROY cache */
 };
 
index c1e2da7..d4ca7f2 100644 (file)
@@ -191,6 +191,10 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
 
     newmeta->super = NULL;
 
+    /* clear the destructor cache */
+    newmeta->destroy = NULL;
+    newmeta->destroy_gen = 0;
+
     return newmeta;
 }
 
@@ -538,8 +542,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
     /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
 
-    /* DESTROY can be cached in SvSTASH. */
-    if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+    /* DESTROY can be cached in meta. */
+    meta->destroy_gen = 0;
 
     /* Iterate the isarev (classes that are our children),
        wiping out their linearization, method and isa caches
@@ -1320,8 +1324,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     /* Inc the package generation, since a local method changed */
     HvMROMETA(stash)->pkg_gen++;
 
-    /* DESTROY can be cached in SvSTASH. */
-    if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+    /* DESTROY can be cached in meta */
+    HvMROMETA(stash)->destroy_gen = 0;
 
     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
        invalidate all method caches globally */
@@ -1346,7 +1350,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
             mrometa->cache_gen++;
             if(mrometa->mro_nextmethod)
                 hv_clear(mrometa->mro_nextmethod);
-            if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
+            mrometa->destroy_gen = 0;
         }
     }
 
diff --git a/sv.c b/sv.c
index 71c398b..42baa29 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6775,25 +6775,31 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
          assert(SvTYPE(stash) == SVt_PVHV);
          if (HvNAME(stash)) {
            CV* destructor = NULL;
+            struct mro_meta *meta;
            assert (SvOOK(stash));
-           if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
-           if (!destructor || HvMROMETA(stash)->destroy_gen
-                               != PL_sub_generation)
-           {
+
+            DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
+                         HvNAME(stash)) );
+
+            /* don't make this an initialization above the assert, since it needs
+               an AUX structure */
+            meta = HvMROMETA(stash);
+            if (meta->destroy_gen && meta->destroy_gen == PL_sub_generation) {
+                destructor = meta->destroy;
+                DEBUG_o( Perl_deb(aTHX_ "Using cached DESTROY method %p for %s\n",
+                             (void *)destructor, HvNAME(stash)) );
+            }
+            else {
                GV * const gv =
                    gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
                if (gv) destructor = GvCV(gv);
-               if (!SvOBJECT(stash))
-               {
-                   SvSTASH(stash) =
-                       destructor ? (HV *)destructor : ((HV *)0)+1;
-                   HvAUX(stash)->xhv_mro_meta->destroy_gen =
-                       PL_sub_generation;
-               }
+                meta->destroy_gen = PL_sub_generation;
+                meta->destroy = destructor;
+                DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n",
+                             (void *)destructor, HvNAME(stash)) );
            }
-           assert(!destructor || destructor == ((CV *)0)+1
-               || SvTYPE(destructor) == SVt_PVCV);
-           if (destructor && destructor != ((CV *)0)+1
+           assert(!destructor || SvTYPE(destructor) == SVt_PVCV);
+           if (destructor
                /* A constant subroutine can have no side effects, so
                   don't bother calling it.  */
                && !CvCONST(destructor)