diff options
| -rw-r--r-- | dump.c | 1 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 2 | ||||
| -rw-r--r-- | objXSUB.h | 8 | ||||
| -rw-r--r-- | op.c | 36 | ||||
| -rw-r--r-- | opcode.h | 10 | ||||
| -rwxr-xr-x | opcode.pl | 3 | ||||
| -rwxr-xr-x | perlapi.c | 14 | ||||
| -rw-r--r-- | pp.sym | 2 | ||||
| -rw-r--r-- | pp_hot.c | 69 | ||||
| -rw-r--r-- | pp_proto.h | 2 | ||||
| -rw-r--r-- | proto.h | 1 |
13 files changed, 129 insertions, 32 deletions
@@ -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: @@ -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 @@ -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 ac6abc7e54..38c8e6559b 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 @@ -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 @@ -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) { @@ -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 @@ -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$ @@ -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) @@ -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 @@ -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 300637c129..5c3d301ed4 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) @@ -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); |