This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
This commit speeds up class method calls when class name is constant.
authorsyber <syber@crazypanda.ru>
Fri, 21 Nov 2014 17:21:00 +0000 (20:21 +0300)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 24 Nov 2014 06:09:27 +0000 (22:09 -0800)
I.e.
MyClass->method()
and
MyClass->$dynamic_method()

By about 30%.

It was done by saving class name (as shared COW string) in METHOP
and later checking it in method_common().

If it was set, then it fetches stash via gv_stashsv using precomputed
hash value instead of falling into a bunch of conditions and fetching
stash without hash value.

op.c
op.h
pp_hot.c

diff --git a/op.c b/op.c
index 104d30f..5e8553f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -862,6 +862,14 @@ Perl_op_clear(pTHX_ OP *o)
             o->op_targ = 0;
         }
 #endif
+    case OP_METHOD:
+       SvREFCNT_dec(cMETHOPx(o)->op_class_sv);
+#ifdef USE_ITHREADS
+       if (cMETHOPx(o)->op_class_targ) {
+           pad_swipe(cMETHOPx(o)->op_class_targ, 1);
+           cMETHOPx(o)->op_class_targ = 0;
+       }
+#endif
         break;
     case OP_CONST:
     case OP_HINTSEVAL:
@@ -2230,6 +2238,9 @@ S_finalize_op(pTHX_ OP* o)
     /* Relocate all the METHOP's SVs to the pad for thread safety. */
     case OP_METHOD_NAMED:
         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
+    case OP_METHOD:
+       if (cMETHOPx(o)->op_class_sv)
+           op_relocate_sv(&cMETHOPx(o)->op_class_sv, &cMETHOPx(o)->op_class_targ);
         break;
 #endif
 
@@ -4682,6 +4693,8 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth
         methop->op_next = (OP*)methop;
     }
 
+    methop->op_class_sv = NULL;
+    methop->op_class_targ = 0;
     CHANGE_TYPE(methop, type);
     methop = (METHOP*) CHECKOP(type, methop);
 
@@ -11576,6 +11589,7 @@ Perl_ck_subr(pTHX_ OP *o)
     OP *aop, *cvop;
     CV *cv;
     GV *namegv;
+    SV *const_class = NULL;
 
     PERL_ARGS_ASSERT_CK_SUBR;
 
@@ -11592,17 +11606,33 @@ Perl_ck_subr(pTHX_ OP *o)
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
        o->op_private |= OPpENTERSUB_DB;
-    if (cvop->op_type == OP_RV2CV) {
-       o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
-       op_null(cvop);
-    } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
-       if (aop->op_type == OP_CONST)
-           aop->op_private &= ~OPpCONST_STRICT;
-       else if (aop->op_type == OP_LIST) {
-           OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
-           if (sib && sib->op_type == OP_CONST)
-               sib->op_private &= ~OPpCONST_STRICT;
-       }
+    switch (cvop->op_type) {
+       case OP_RV2CV:
+           o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+           op_null(cvop);
+           break;
+       case OP_METHOD:
+       case OP_METHOD_NAMED:
+           if (aop->op_type == OP_CONST) {
+               aop->op_private &= ~OPpCONST_STRICT;
+               const_class = cSVOPx(aop)->op_sv;
+           }
+           else if (aop->op_type == OP_LIST) {
+               OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
+               if (sib && sib->op_type == OP_CONST) {
+                   sib->op_private &= ~OPpCONST_STRICT;
+                   const_class = cSVOPx(sib)->op_sv;
+               }
+           }
+           /* cache const class' name to speedup class method calls */
+           if (const_class) {
+               STRLEN len;
+               const char* str = SvPV(const_class, len);
+               if (len) cMETHOPx(cvop)->op_class_sv = newSVpvn_share(
+                   str, SvUTF8(const_class) ? -len : len, 0
+               );
+           }
+           break;
     }
 
     if (!cv) {
diff --git a/op.h b/op.h
index e4fadf6..e623cd9 100644 (file)
--- a/op.h
+++ b/op.h
@@ -202,6 +202,8 @@ struct methop {
         OP* op_first;   /* optree for method name */
         SV* op_meth_sv; /* static method name */
     } op_u;
+    SV*       op_class_sv;   /* static class name */
+    PADOFFSET op_class_targ; /* pad index for class name if threaded */
 };
 
 struct pmop {
@@ -441,6 +443,8 @@ struct loop {
                                 ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
 #  define      cSVOPx_svp(v)   (cSVOPx(v)->op_sv \
                                 ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ))
+#  define      cMETHOPx_class(v) (cMETHOPx(v)->op_class_targ ? \
+       PAD_SVl(cMETHOPx(v)->op_class_targ) : cMETHOPx(v)->op_class_sv)
 #else
 #  define      cGVOPx_gv(o)    ((GV*)cSVOPx(o)->op_sv)
 #  ifndef PERL_CORE
@@ -449,6 +453,7 @@ struct loop {
 #  endif
 #  define      cSVOPx_sv(v)    (cSVOPx(v)->op_sv)
 #  define      cSVOPx_svp(v)   (&cSVOPx(v)->op_sv)
+#  define       cMETHOPx_class(v) (cMETHOPx(v)->op_class_sv)
 #endif
 
 #  define      cMETHOPx_meth(v)        cSVOPx_sv(v)
index 4908525..8ec576a 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3006,15 +3006,21 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     SV* ob;
     GV* gv;
     HV* stash;
-    SV *packsv = NULL;
-    SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
+    SV *packsv = NULL, *const_class, *sv;
+
+    PERL_ARGS_ASSERT_METHOD_COMMON;
+
+    if ((const_class = cMETHOPx_class(PL_op))) {
+       stash = gv_stashsv(const_class, GV_CACHE_ONLY);
+       if (stash) goto fetch;
+    }
+
+    sv = PL_stack_base + TOPMARK == PL_stack_sp
        ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
                            "package or object reference", SVfARG(meth)),
           (SV *)NULL)
        : *(PL_stack_base + TOPMARK + 1);
 
-    PERL_ARGS_ASSERT_METHOD_COMMON;
-
     if (UNLIKELY(!sv))
        undefined:
        Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",