From f5d5a27c761624409884a263632e1a922439502b Mon Sep 17 00:00:00 2001 From: Chip Salzenberg Date: Thu, 22 Jul 1999 09:43:36 -0400 Subject: [PATCH] optimize method name lookup Message-ID: <19990722134336.Q391@perlsupport.com> Subject: [PATCH] OP_METHOD_NAMED p4raw-id: //depot/perl@3768 --- dump.c | 1 + embed.h | 12 +++++++++ embed.pl | 1 + ext/Opcode/Opcode.pm | 2 +- objXSUB.h | 8 ++++++ op.c | 36 +++++++++++++++++++-------- opcode.h | 10 ++++++-- opcode.pl | 3 ++- perlapi.c | 14 +++++++++++ pp.sym | 2 ++ pp_hot.c | 69 ++++++++++++++++++++++++++++++++++++++-------------- pp_proto.h | 2 ++ proto.h | 1 + 13 files changed, 129 insertions(+), 32 deletions(-) diff --git a/dump.c b/dump.c index 28233e9..dced246 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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); -- 2.7.4