speeding up object creation/destruction 4x times

Message-ID: <20001215052657.A8319@math.mps.ohio-state.edu>

p4raw-id: //depot/perl@8131

diff --git a/embed.h b/embed.h
index 70d4c36..4528382 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -68,6 +68,7 @@
 #endif
 #define amagic_call            Perl_amagic_call
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#define gv_handler             Perl_gv_handler
 #define append_elem            Perl_append_elem
 #define append_list            Perl_append_list
 #define apply                  Perl_apply
@@ -1556,6 +1557,7 @@
 #endif
 #define amagic_call(a,b,c,d)   Perl_amagic_call(aTHX_ a,b,c,d)
 #define Gv_AMupdate(a)         Perl_Gv_AMupdate(aTHX_ a)
+#define gv_handler(a,b)                Perl_gv_handler(aTHX_ a,b)
 #define append_elem(a,b,c)     Perl_append_elem(aTHX_ a,b,c)
 #define append_list(a,b,c)     Perl_append_list(aTHX_ a,b,c)
 #define apply(a,b,c)           Perl_apply(aTHX_ a,b,c)
@@ -3021,6 +3023,8 @@
 #define amagic_call            Perl_amagic_call
 #define Perl_Gv_AMupdate       CPerlObj::Perl_Gv_AMupdate
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#define Perl_gv_handler                CPerlObj::Perl_gv_handler
+#define gv_handler             Perl_gv_handler
 #define Perl_append_elem       CPerlObj::Perl_append_elem
 #define append_elem            Perl_append_elem
 #define Perl_append_list       CPerlObj::Perl_append_list

diff --git a/embed.pl b/embed.pl
index fa22c84..69548b6 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1376,6 +1376,7 @@ START_EXTERN_C
 #  include "pp_proto.h"
 Ap     |SV*    |amagic_call    |SV* left|SV* right|int method|int dir
 Ap     |bool   |Gv_AMupdate    |HV* stash
+Ap     |CV*    |gv_handler     |HV* stash|I32 id
 p      |OP*    |append_elem    |I32 optype|OP* head|OP* tail
 p      |OP*    |append_list    |I32 optype|LISTOP* first|LISTOP* last
 p      |I32    |apply          |I32 type|SV** mark|SV** sp

diff --git a/gv.c b/gv.c
index 8f9395f..fa830bf 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1155,7 +1155,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
   if (mg && amtp->was_ok_am == PL_amagic_generation
       && amtp->was_ok_sub == PL_sub_generation)
-      return AMT_AMAGIC(amtp);
+      return AMT_OVERLOADED(amtp);
   if (amtp && AMT_AMAGIC(amtp)) {      /* Have table. */
     int i;
     for (i=1; i<NofAMmeth; i++) {
@@ -1174,8 +1174,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   amt.flags = 0;
 
   {
-    int filled = 0;
-    int i;
+    int filled = 0, have_ovl = 0;
+    int i, lim = 1;
     const char *cp;
     SV* sv = NULL;
 
@@ -1187,15 +1187,18 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
        sv = GvSV(gv);
 
     if (!gv)
-       goto no_table;
+       lim = DESTROY_amg;              /* Skip overloading entries. */
     else if (SvTRUE(sv))
        amt.fallback=AMGfallYES;
     else if (SvOK(sv))
        amt.fallback=AMGfallNEVER;
 
-    for (i = 1; i < NofAMmeth; i++) {
+    for (i = 1; i < lim; i++)
+       amt.table[i] = Nullcv;
+    for (; i < NofAMmeth; i++) {
        char *cooky = PL_AMG_names[i];
-       char *cp = AMG_id2name(i); /* Human-readable form, for debugging */
+       /* Human-readable form, for debugging: */
+       char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
        STRLEN l = strlen(cooky);
 
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
@@ -1231,13 +1234,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
                         cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
                         GvNAME(CvGV(cv))) );
            filled = 1;
+           if (i < DESTROY_amg)
+               have_ovl = 1;
        }
        amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
+      if (have_ovl)
+         AMT_OVERLOADED_on(&amt);
       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
-      return TRUE;
+      return have_ovl;
     }
   }
   /* Here we have no table: */
@@ -1247,6 +1254,29 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   return FALSE;
 }
 
+
+CV*
+Perl_gv_handler(pTHX_ HV *stash, I32 id)
+{
+    dTHR;
+    MAGIC *mg = mg_find((SV*)stash,'c');
+    AMT *amtp;
+
+    if (!mg) {
+      do_update:
+       Gv_AMupdate(stash);
+       mg = mg_find((SV*)stash,'c');
+    }
+    amtp = (AMT*)mg->mg_ptr;
+    if ( amtp->was_ok_am != PL_amagic_generation
+        || amtp->was_ok_sub != PL_sub_generation )
+       goto do_update;
+    if (AMT_AMAGIC(amtp))
+       return amtp->table[id];
+    return Nullcv;
+}
+
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {

diff --git a/objXSUB.h b/objXSUB.h
index 5a3850c..599d683 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -35,6 +35,10 @@
 #define Perl_Gv_AMupdate       pPerl->Perl_Gv_AMupdate
 #undef  Gv_AMupdate
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#undef  Perl_gv_handler
+#define Perl_gv_handler                pPerl->Perl_gv_handler
+#undef  gv_handler
+#define gv_handler             Perl_gv_handler
 #undef  Perl_apply_attrs_string
 #define Perl_apply_attrs_string        pPerl->Perl_apply_attrs_string
 #undef  apply_attrs_string

diff --git a/perl.h b/perl.h
index e1c9438..8313c07 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3055,7 +3055,7 @@ enum {
   to_sv_amg,   to_av_amg,
   to_hv_amg,   to_gv_amg,
   to_cv_amg,   iter_amg,    
-  max_amg_code
+  DESTROY_amg, max_amg_code
   /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };
 
@@ -3101,6 +3101,7 @@ EXTCONST char * PL_AMG_names[NofAMmeth] = {
   "(${}",      "(@{}",
   "(%{}",      "(*{}",
   "(&{}",      "(<>",
+  "DESTROY",
 };
 #else
 EXTCONST char * PL_AMG_names[NofAMmeth];
@@ -3128,10 +3129,15 @@ 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))
 
 /*
  * some compilers like to redefine cos et alia as faster

diff --git a/proto.h b/proto.h
index 288a311..ac277ac 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -58,6 +58,7 @@ START_EXTERN_C
 #  include "pp_proto.h"
 PERL_CALLCONV SV*      Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir);
 PERL_CALLCONV bool     Perl_Gv_AMupdate(pTHX_ HV* stash);
+PERL_CALLCONV CV*      Perl_gv_handler(pTHX_ HV* stash, I32 id);
 PERL_CALLCONV OP*      Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail);
 PERL_CALLCONV OP*      Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
 PERL_CALLCONV I32      Perl_apply(pTHX_ I32 type, SV** mark, SV** sp);

diff --git a/sv.c b/sv.c
index 7c9c4db..46d11ff 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3721,7 +3721,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
     if (SvOBJECT(sv)) {
        if (PL_defstash) {              /* Still have a symbol table? */
            djSP;
-           GV* destructor;
+           CV* destructor;
            SV tmpref;
 
            Zero(&tmpref, 1, SV);
@@ -3730,9 +3730,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
            SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
            SvREFCNT(&tmpref) = 1;
 
-           do {
+           do {            
                stash = SvSTASH(sv);
-               destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+               destructor = StashHANDLER(stash,DESTROY);
                if (destructor) {
                    ENTER;
                    PUSHSTACKi(PERLSI_DESTROY);
@@ -3741,8 +3741,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
                    PUSHMARK(SP);
                    PUSHs(&tmpref);
                    PUTBACK;
-                   call_sv((SV*)GvCV(destructor),
-                           G_DISCARD|G_EVAL|G_KEEPERR);
+                   call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
                    SvREFCNT(sv)--;
                    POPSTACK;
                    SPAGAIN;

diff --git a/t/pragma/overload.t b/t/pragma/overload.t
index c7105dc..bf24c07 100755 (executable)
--- a/t/pragma/overload.t
+++ b/t/pragma/overload.t
@@ -133,6 +133,7 @@ test ( $a eq "087");                # 29
 test ( $b eq "88");            # 30
 test (ref $a eq "Oscalar");    # 31
 
+undef $b;                      # Destroying updates tables too...
 
 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];