[perl #114864] Don’t use amt for DESTROY

DESTROY has been cached in overload tables since
perl-5.6.0-2080-g32251b2, making it 4 times faster than before (over-
load tables are faster than method lookup).

But it slows down symbol lookup on stashes with overload tables,
because overload tables use magic, and SvRMAGICAL results in calls to
mg_find on every hash lookup.

By reusing SvSTASH(stash) to cache the DESTROY method (if the stash
is unblessed, of course, as most stashes are), we can avoid making
all destroyable stashes magical and also speed up DESTROY lookup
slightly more.

The results:

• 10% increase in stash lookup speed after destructors.  That was just
  testing $Foo::{x}.  Other stash lookups will have other overheads
  that make the difference less impressive.

• 5% increase in DESTROY lookup speed.  I was using an empty DESTROY
  method to test this, so, again, real DESTROY methods will have more
  overhead and less speedup.

diff --git a/gv.c b/gv.c
index 9de8886..05ad515 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2252,7 +2252,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
   if (mg) {
       const AMT * const amtp = (AMT*)mg->mg_ptr;
       if (amtp->was_ok_sub == newgen) {
-         return AMT_OVERLOADED(amtp) ? 1 : 0;
+         return AMT_AMAGIC(amtp) ? 1 : 0;
       }
       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
   }
@@ -2265,8 +2265,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
   amt.flags = 0;
 
   {
-    int filled = 0, have_ovl = 0;
-    int i, lim = 1;
+    int filled = 0;
+    int i;
 
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
@@ -2278,7 +2278,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     if (!gv)
     {
       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
-       lim = DESTROY_amg;              /* Skip overloading entries. */
+       goto no_table;
     }
 #ifdef PERL_DONT_CREATE_GVSV
     else if (!sv) {
@@ -2292,19 +2292,15 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     else if (SvOK(sv)) {
        amt.fallback=AMGfallNEVER;
         filled = 1;
-        have_ovl = 1;
     }
     else {
         filled = 1;
-        have_ovl = 1;
     }
 
-    for (i = 1; i < lim; i++)
-       amt.table[i] = NULL;
-    for (; i < NofAMmeth; i++) {
+    for (i = 1; i < NofAMmeth; i++) {
        const char * const cooky = PL_AMG_names[i];
        /* Human-readable form, for debugging: */
-       const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+       const char * const cp = AMG_id2name(i);
        const STRLEN l = PL_AMG_namelens[i];
 
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
@@ -2316,10 +2312,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
           then we could have created stubs for "(+0" in A and C too.
           But if B overloads "bool", we may want to use it for
           numifying instead of C's "+0". */
-       if (i >= DESTROY_amg)
-           gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
-       else                            /* Autoload taken care of below */
-           gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
+       gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
         cv = 0;
         if (gv && (cv = GvCV(gv))) {
            if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
@@ -2365,8 +2358,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
                         cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
                         GvNAME(CvGV(cv))) );
            filled = 1;
-           if (i < DESTROY_amg)
-               have_ovl = 1;
        } else if (gv) {                /* Autoloaded... */
            cv = MUTABLE_CV(gv);
            filled = 1;
@@ -2375,15 +2366,13 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
-      if (have_ovl)
-         AMT_OVERLOADED_on(&amt);
       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
                                                (char*)&amt, sizeof(AMT));
-      return have_ovl;
+      return TRUE;
     }
   }
   /* Here we have no table: */
-  /* no_table: */
+ no_table:
   AMT_AMAGIC_off(&amt);
   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
                                                (char*)&amt, sizeof(AMTS));
@@ -2409,19 +2398,8 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
     if (!mg) {
       do_update:
-       /* If we're looking up a destructor to invoke, we must avoid
-        * that Gv_AMupdate croaks, because we might be dying already */
-       if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
-           /* and if it didn't found a destructor, we fall back
-            * to a simpler method that will only look for the
-            * destructor instead of the whole magic */
-           if (id == DESTROY_amg) {
-               GV * const gv = gv_fetchmethod(stash, "DESTROY");
-               if (gv)
-                   return GvCV(gv);
-           }
+       if (Gv_AMupdate(stash, 0) == -1)
            return NULL;
-       }
        mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
     }
     assert(mg);

diff --git a/lib/overload/numbers.pm b/lib/overload/numbers.pm
index f56fa63..a90c175 100644 (file)
--- a/lib/overload/numbers.pm
+++ b/lib/overload/numbers.pm
@@ -82,7 +82,6 @@ our @names = qw#
     (~~
     (-X
     (qr
-    DESTROY
 #;
 
 our @enums = qw#
@@ -154,7 +153,6 @@ our @enums = qw#
     smart
     ftest
     regexp
-    DESTROY
 #;
 
 { my $i = 0; our %names = map { $_ => $i++ } @names }

diff --git a/mro.c b/mro.c
index 1264754..2d1d887 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -544,6 +544,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
     /* Changes to @ISA might turn overloading on */
     HvAMAGIC_on(stash);
 
+    /* DESTROY can be cached in SvSTASH. */
+    if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+
     /* Iterate the isarev (classes that are our children),
        wiping out their linearization, method and isa caches
        and upating PL_isarev. */
@@ -1327,6 +1330,9 @@ 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;
+
     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
        invalidate all method caches globally */
     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))

diff --git a/overload.c b/overload.c
index 91e2d20..cd28df4 100644 (file)
--- a/overload.c
+++ b/overload.c
@@ -84,8 +84,7 @@ static const U8 PL_AMG_namelens[NofAMmeth] = {
     3,
     3,
     3,
-    3,
-    7
+    3
 };
 
 static const char * const PL_AMG_names[NofAMmeth] = {
@@ -161,8 +160,7 @@ static const char * const PL_AMG_names[NofAMmeth] = {
     "(.=",             /* concat_ass */
     "(~~",             /* smart      */
     "(-X",             /* ftest      */
-    "(qr",             /* regexp     */
-    "DESTROY"
+    "(qr"
 };
 
 /* ex: set ro: */

diff --git a/overload.h b/overload.h
index 24cde2a..1628ac0 100644 (file)
--- a/overload.h
+++ b/overload.h
@@ -82,7 +82,6 @@ enum {
     smart_amg,         /* 0x41 ~~       */
     ftest_amg,         /* 0x42 -X       */
     regexp_amg,                /* 0x43 qr       */
-    DESTROY_amg,       /* 0x44 DESTROY  */
     max_amg_code
     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };

diff --git a/perl.h b/perl.h
index f68a336..70dc87e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5240,13 +5240,9 @@ typedef struct am_table_short AMTS;
 #define AMGfallYES     3
 
 #define AMTf_AMAGIC            1
-#define AMTf_OVERLOADED                2
 #define AMT_AMAGIC(amt)                ((amt)->flags & AMTf_AMAGIC)
 #define AMT_AMAGIC_on(amt)     ((amt)->flags |= AMTf_AMAGIC)
 #define AMT_AMAGIC_off(amt)    ((amt)->flags &= ~AMTf_AMAGIC)
-#define AMT_OVERLOADED(amt)    ((amt)->flags & AMTf_OVERLOADED)
-#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED)
-#define AMT_OVERLOADED_off(amt)        ((amt)->flags &= ~AMTf_OVERLOADED)
 
 #define StashHANDLER(stash,meth)       gv_handler((stash),CAT2(meth,_amg))
 

diff --git a/regen/overload.pl b/regen/overload.pl
index 652b2b7..6d9e04d 100644 (file)
--- a/regen/overload.pl
+++ b/regen/overload.pl
@@ -198,5 +198,3 @@ concat_ass  (.=
 smart          (~~
 ftest           (-X
 regexp          (qr
-# Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
-DESTROY                DESTROY

diff --git a/sv.c b/sv.c
index 4d7219d..7557790 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6332,9 +6332,17 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
        dSP;
        HV* stash;
        do {
-           CV* destructor;
-           stash = SvSTASH(sv);
-           destructor = StashHANDLER(stash,DESTROY);
+         if ((stash = SvSTASH(sv)) && HvNAME(stash)) {
+           CV* destructor = NULL;
+           if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
+           if (!destructor) {
+               GV * const gv =
+                   gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
+               if (gv && (destructor = GvCV(gv))) {
+                   if (!SvOBJECT(stash))
+                       SvSTASH(stash) = (HV *)destructor;
+               }
+           }
            if (destructor
                /* A constant subroutine can have no side effects, so
                   don't bother calling it.  */
@@ -6374,6 +6382,7 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
                }
                SvREFCNT_dec(tmpref);
            }
+         }
        } while (SvOBJECT(sv) && SvSTASH(sv) != stash);