From: Ilya Zakharevich <ilya@math.berkeley.edu>
Date: Fri, 15 Dec 2000 05:26:57 +0000 (-0500)
Subject: speeding up object creation/destruction 4x times
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=32251b26ec0781f53d9925938cad5bd9e89c80f2;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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] } ) ];