optimize method name lookup

	Message-ID: <19990722134336.Q391@perlsupport.com>
	Subject: [PATCH] OP_METHOD_NAMED

p4raw-id: //depot/perl@3768

diff --git a/dump.c b/dump.c
index 28233e9..dced246 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -522,6 +522,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
            Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
        break;
     case OP_CONST:
+    case OP_METHOD_NAMED:
        Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
        break;
     case OP_SETSTATE:

diff --git a/embed.h b/embed.h
index 39d3b7f..5cddd1b 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -831,6 +831,7 @@
 #endif
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 #define get_db_sub             S_get_db_sub
+#define method_common          S_method_common
 #endif
 #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
 #define doform                 S_doform
@@ -986,6 +987,7 @@
 #define ck_lfun                        Perl_ck_lfun
 #define ck_listiob             Perl_ck_listiob
 #define ck_match               Perl_ck_match
+#define ck_method              Perl_ck_method
 #define ck_null                        Perl_ck_null
 #define ck_repeat              Perl_ck_repeat
 #define ck_require             Perl_ck_require
@@ -1188,6 +1190,7 @@
 #define pp_mapwhile            Perl_pp_mapwhile
 #define pp_match               Perl_pp_match
 #define pp_method              Perl_pp_method
+#define pp_method_named                Perl_pp_method_named
 #define pp_mkdir               Perl_pp_mkdir
 #define pp_modulo              Perl_pp_modulo
 #define pp_msgctl              Perl_pp_msgctl
@@ -2143,6 +2146,7 @@
 #endif
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 #define get_db_sub(a,b)                S_get_db_sub(aTHX_ a,b)
+#define method_common(a,b)     S_method_common(aTHX_ a,b)
 #endif
 #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
 #define doform(a,b,c)          S_doform(aTHX_ a,b,c)
@@ -2297,6 +2301,7 @@
 #define ck_lfun(a)             Perl_ck_lfun(aTHX_ a)
 #define ck_listiob(a)          Perl_ck_listiob(aTHX_ a)
 #define ck_match(a)            Perl_ck_match(aTHX_ a)
+#define ck_method(a)           Perl_ck_method(aTHX_ a)
 #define ck_null(a)             Perl_ck_null(aTHX_ a)
 #define ck_repeat(a)           Perl_ck_repeat(aTHX_ a)
 #define ck_require(a)          Perl_ck_require(aTHX_ a)
@@ -2499,6 +2504,7 @@
 #define pp_mapwhile()          Perl_pp_mapwhile(aTHX)
 #define pp_match()             Perl_pp_match(aTHX)
 #define pp_method()            Perl_pp_method(aTHX)
+#define pp_method_named()      Perl_pp_method_named(aTHX)
 #define pp_mkdir()             Perl_pp_mkdir(aTHX)
 #define pp_modulo()            Perl_pp_modulo(aTHX)
 #define pp_msgctl()            Perl_pp_msgctl(aTHX)
@@ -4229,6 +4235,8 @@
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 #define S_get_db_sub           CPerlObj::S_get_db_sub
 #define get_db_sub             S_get_db_sub
+#define S_method_common                CPerlObj::S_method_common
+#define method_common          S_method_common
 #endif
 #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
 #define S_doform               CPerlObj::S_doform
@@ -4507,6 +4515,8 @@
 #define ck_listiob             Perl_ck_listiob
 #define Perl_ck_match          CPerlObj::Perl_ck_match
 #define ck_match               Perl_ck_match
+#define Perl_ck_method         CPerlObj::Perl_ck_method
+#define ck_method              Perl_ck_method
 #define Perl_ck_null           CPerlObj::Perl_ck_null
 #define ck_null                        Perl_ck_null
 #define Perl_ck_repeat         CPerlObj::Perl_ck_repeat
@@ -4911,6 +4921,8 @@
 #define pp_match               Perl_pp_match
 #define Perl_pp_method         CPerlObj::Perl_pp_method
 #define pp_method              Perl_pp_method
+#define Perl_pp_method_named   CPerlObj::Perl_pp_method_named
+#define pp_method_named                Perl_pp_method_named
 #define Perl_pp_mkdir          CPerlObj::Perl_pp_mkdir
 #define pp_mkdir               Perl_pp_mkdir
 #define Perl_pp_modulo         CPerlObj::Perl_pp_modulo

diff --git a/embed.pl b/embed.pl
index 915a2f6..726554e 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1872,6 +1872,7 @@ s |void   |qsortsv        |SV ** array|size_t num_elts|SVCOMPARE_t f
 
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 s      |CV*    |get_db_sub     |SV **svp|CV *cv
+s      |SV*    |method_common  |SV* meth|U32* hashp
 #endif
 
 #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index ac6abc7..38c8e65 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -336,7 +336,7 @@ invert_opset function.
 
     rv2cv anoncode prototype
 
-    entersub leavesub return method -- XXX loops via recursion?
+    entersub leavesub return method method_named -- XXX loops via recursion?
 
     leaveeval -- needed for Safe to operate, is safe without entereval
 

diff --git a/objXSUB.h b/objXSUB.h
index 9f2e517..7246cb6 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -3626,6 +3626,10 @@
 #define Perl_ck_match          pPerl->Perl_ck_match
 #undef  ck_match
 #define ck_match               Perl_ck_match
+#undef  Perl_ck_method
+#define Perl_ck_method         pPerl->Perl_ck_method
+#undef  ck_method
+#define ck_method              Perl_ck_method
 #undef  Perl_ck_null
 #define Perl_ck_null           pPerl->Perl_ck_null
 #undef  ck_null
@@ -4434,6 +4438,10 @@
 #define Perl_pp_method         pPerl->Perl_pp_method
 #undef  pp_method
 #define pp_method              Perl_pp_method
+#undef  Perl_pp_method_named
+#define Perl_pp_method_named   pPerl->Perl_pp_method_named
+#undef  pp_method_named
+#define pp_method_named                Perl_pp_method_named
 #undef  Perl_pp_mkdir
 #define Perl_pp_mkdir          pPerl->Perl_pp_mkdir
 #undef  pp_mkdir

diff --git a/op.c b/op.c
index ece04f7..8b47448 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2762,7 +2762,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
        }
        else {
            OP *pack;
-           OP *meth;
 
            if (version->op_type != OP_CONST || !SvNIOK(vesv))
                Perl_croak(aTHX_ "Version number must be constant number");
@@ -2771,11 +2770,11 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
            pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
 
            /* Fake up a method call to VERSION */
-           meth = newSVOP(OP_CONST, 0, newSVpvn("VERSION", 7));
            veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
                            append_elem(OP_LIST,
                            prepend_elem(OP_LIST, pack, list(version)),
-                           newUNOP(OP_METHOD, 0, meth)));
+                           newSVOP(OP_METHOD_NAMED, 0,
+                                   newSVpvn("VERSION", 7))));
        }
     }
 
@@ -2788,15 +2787,12 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
     else {
        /* Make copy of id so we don't free it twice */
        pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
-       meth = newSVOP(OP_CONST, 0,
-           aver
-               ? newSVpvn("import", 6)
-               : newSVpvn("unimport", 8)
-           );
        imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
                    append_elem(OP_LIST,
                        prepend_elem(OP_LIST, pack, list(arg)),
-                       newUNOP(OP_METHOD, 0, meth)));
+                       newSVOP(OP_METHOD_NAMED, 0,
+                               aver ? newSVpvn("import", 6)
+                                    : newSVpvn("unimport", 8))));
     }
 
     /* Fake up a require, handle override, if any */
@@ -5168,6 +5164,26 @@ Perl_ck_match(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_method(pTHX_ OP *o)
+{
+    OP *kid = cUNOPo->op_first;
+    if (kid->op_type == OP_CONST) {
+       SV* sv = kSVOP->op_sv;
+       if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
+           OP *cmop;
+           sv_upgrade(sv, SVt_PVIV);
+           SvIOK_on(sv);
+           PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv));
+           cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
+           kSVOP->op_sv = Nullsv;
+           op_free(o);
+           return cmop;
+       }
+    }
+    return o;
+}
+
+OP *
 Perl_ck_null(pTHX_ OP *o)
 {
     return o;
@@ -5461,7 +5477,7 @@ Perl_ck_subr(pTHX_ OP *o)
            }
        }
     }
-    else if (cvop->op_type == OP_METHOD) {
+    else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
        if (o2->op_type == OP_CONST)
            o2->op_private &= ~OPpCONST_STRICT;
        else if (o2->op_type == OP_LIST) {

diff --git a/opcode.h b/opcode.h
index 01a36a0..58d86ea 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -358,10 +358,11 @@ typedef enum {
        OP_LOCK,        /* 346 */
        OP_THREADSV,    /* 347 */
        OP_SETSTATE,    /* 348 */
+       OP_METHOD_NAMED,/* 349 */
        OP_max          
 } opcode;
 
-#define MAXO 349
+#define MAXO 350
 
 
 START_EXTERN_C
@@ -719,6 +720,7 @@ EXT char *PL_op_name[] = {
        "lock",
        "threadsv",
        "setstate",
+       "method_named",
 };
 #endif
 
@@ -1075,6 +1077,7 @@ EXT char *PL_op_desc[] = {
        "lock",
        "per-thread variable",
        "set statement info",
+       "method with known name",
 };
 #endif
 
@@ -1436,6 +1439,7 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = {
        Perl_pp_lock,
        Perl_pp_threadsv,
        Perl_pp_setstate,
+       Perl_pp_method_named,
 };
 #endif
 
@@ -1608,7 +1612,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
        Perl_ck_null,   /* cond_expr */
        Perl_ck_null,   /* andassign */
        Perl_ck_null,   /* orassign */
-       Perl_ck_null,   /* method */
+       Perl_ck_method, /* method */
        Perl_ck_subr,   /* entersub */
        Perl_ck_null,   /* leavesub */
        Perl_ck_fun,    /* caller */
@@ -1792,6 +1796,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
        Perl_ck_rfun,   /* lock */
        Perl_ck_null,   /* threadsv */
        Perl_ck_null,   /* setstate */
+       Perl_ck_null,   /* method_named */
 };
 #endif
 
@@ -2148,6 +2153,7 @@ EXT U32 PL_opargs[] = {
        0x00003604,     /* lock */
        0x00000044,     /* threadsv */
        0x00001404,     /* setstate */
+       0x00000c40,     /* method_named */
 };
 #endif
 

diff --git a/opcode.pl b/opcode.pl
index f2b876d..c26dab8 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -535,7 +535,7 @@ cond_expr   conditional expression  ck_null         d|
 andassign      logical and assignment  ck_null         s|      
 orassign       logical or assignment   ck_null         s|      
 
-method         method lookup           ck_null         d1
+method         method lookup           ck_method       d1
 entersub       subroutine entry        ck_subr         dmt1    L
 leavesub       subroutine exit         ck_null         1       
 caller         caller                  ck_fun          t%      S?
@@ -781,3 +781,4 @@ threadsv    per-thread variable     ck_null         ds0
 
 # Control (contd.)
 setstate       set statement info      ck_null         s;
+method_named   method with known name  ck_null         d$

diff --git a/perlapi.c b/perlapi.c
index 3e7e0ab..ff5c859 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -4958,6 +4958,13 @@ Perl_ck_match(pTHXo_ OP *o)
     return ((CPerlObj*)pPerl)->Perl_ck_match(o);
 }
 
+#undef  Perl_ck_method
+OP *
+Perl_ck_method(pTHXo_ OP *o)
+{
+    return ((CPerlObj*)pPerl)->Perl_ck_method(o);
+}
+
 #undef  Perl_ck_null
 OP *
 Perl_ck_null(pTHXo_ OP *o)
@@ -6372,6 +6379,13 @@ Perl_pp_method(pTHXo)
     return ((CPerlObj*)pPerl)->Perl_pp_method();
 }
 
+#undef  Perl_pp_method_named
+OP *
+Perl_pp_method_named(pTHXo)
+{
+    return ((CPerlObj*)pPerl)->Perl_pp_method_named();
+}
+
 #undef  Perl_pp_mkdir
 OP *
 Perl_pp_mkdir(pTHXo)

diff --git a/pp.sym b/pp.sym
index 00e4b4e..cbbbaae 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -23,6 +23,7 @@ Perl_ck_lengthconst
 Perl_ck_lfun
 Perl_ck_listiob
 Perl_ck_match
+Perl_ck_method
 Perl_ck_null
 Perl_ck_repeat
 Perl_ck_require
@@ -383,3 +384,4 @@ Perl_pp_syscall
 Perl_pp_lock
 Perl_pp_threadsv
 Perl_pp_setstate
+Perl_pp_method_named

diff --git a/pp_hot.c b/pp_hot.c
index 30b4406..fd2d79a 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2504,25 +2504,46 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 PP(pp_method)
 {
     djSP;
+    SV* sv = TOPs;
+
+    if (SvROK(sv)) {
+       SV* rsv = SvRV(rsv);
+       if (SvTYPE(rsv) == SVt_PVCV) {
+           SETs(rsv);
+           RETURN;
+       }
+    }
+
+    SETs(method_common(sv, Null(U32*)));
+    RETURN;
+}
+
+PP(pp_method_named)
+{
+    djSP;
+    SV* sv = cSVOP->op_sv;
+    U32 hash = SvUVX(sv);
+
+    XPUSHs(method_common(sv, &hash));
+    RETURN;
+}
+
+STATIC SV *
+S_method_common(pTHX_ SV* meth, U32* hashp)
+{
+    djSP;
     SV* sv;
     SV* ob;
     GV* gv;
     HV* stash;
     char* name;
+    STRLEN namelen;
     char* packname;
     STRLEN packlen;
 
-    if (SvROK(TOPs)) {
-       sv = SvRV(TOPs);
-       if (SvTYPE(sv) == SVt_PVCV) {
-           SETs(sv);
-           RETURN;
-       }
-    }
-
-    name = SvPV(TOPs, packlen);
+    name = SvPV(meth, namelen);
     sv = *(PL_stack_base + TOPMARK + 1);
-    
+
     if (SvGMAGICAL(sv))
         mg_get(sv);
     if (SvROK(sv))
@@ -2542,9 +2563,9 @@ PP(pp_method)
                    : !isIDFIRST(*packname)
                ))
            {
-               DIE(aTHX_ "Can't call method \"%s\" %s", name,
-                   SvOK(sv)? "without a package or object reference"
-                           : "on an undefined value");
+               Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+                          SvOK(sv) ? "without a package or object reference"
+                                   : "on an undefined value");
            }
            stash = gv_stashpvn(packname, packlen, TRUE);
            goto fetch;
@@ -2553,11 +2574,23 @@ PP(pp_method)
     }
 
     if (!ob || !SvOBJECT(ob))
-       DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
+       Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+                  name);
 
     stash = SvSTASH(ob);
 
   fetch:
+    /* shortcut for simple names */
+    if (hashp) {
+       HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
+       if (he) {
+           gv = (GV*)HeVAL(he);
+           if (isGV(gv) && GvCV(gv) &&
+               (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+               return (SV*)GvCV(gv);
+       }
+    }
+
     gv = gv_fetchmethod(stash, name);
     if (!gv) {
        char* leaf = name;
@@ -2578,11 +2611,11 @@ PP(pp_method)
            packname = name;
            packlen = sep - name;
        }
-       DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
-           leaf, (int)packlen, packname);
+       Perl_croak(aTHX_
+                  "Can't locate object method \"%s\" via package \"%s\"",
+                  leaf, packname);
     }
-    SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
-    RETURN;
+    return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
 
 #ifdef USE_THREADS

diff --git a/pp_proto.h b/pp_proto.h
index 300637c..5c3d301 100644 (file)
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -22,6 +22,7 @@ PERL_CKDEF(Perl_ck_lengthconst)
 PERL_CKDEF(Perl_ck_lfun)
 PERL_CKDEF(Perl_ck_listiob)
 PERL_CKDEF(Perl_ck_match)
+PERL_CKDEF(Perl_ck_method)
 PERL_CKDEF(Perl_ck_null)
 PERL_CKDEF(Perl_ck_repeat)
 PERL_CKDEF(Perl_ck_require)
@@ -384,3 +385,4 @@ PERL_PPDEF(Perl_pp_syscall)
 PERL_PPDEF(Perl_pp_lock)
 PERL_PPDEF(Perl_pp_threadsv)
 PERL_PPDEF(Perl_pp_setstate)
+PERL_PPDEF(Perl_pp_method_named)

diff --git a/proto.h b/proto.h
index 7672780..b41868e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -840,6 +840,7 @@ STATIC void S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f);
 #endif
 #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
 STATIC CV*     S_get_db_sub(pTHX_ SV **svp, CV *cv);
+STATIC SV*     S_method_common(pTHX_ SV* meth, U32* hashp);
 #endif
 #if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
 STATIC OP*     S_doform(pTHX_ CV *cv, GV *gv, OP *retop);