Speed up method calls like $o->Other::method() and $o->Other::SUPER::…

…method().

It was done by adding new OP_METHOD_REDIR and OP_METHOD_REDIR_SUPER optypes.
Class name to redirect is saved into METHOP as a shared hash string.
Method name is changed (class name removed) an saved into op_meth_sv as
a shared string hash.

So there is no need now to scan for '::' and calculate class and method names
at runtime (in gv_fetchmethod_*) and searching cache HV without precomputed hash.

B::* modules are changed to support new op types.
method_redir is now printed by Concise like (for threaded perl)
$obj->AAA::meth
5        <.> method_redir[PACKAGE "AAA", PV "meth"] ->6

dump.c

@@ -956,6 +956,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
     case OP_HINTSEVAL:
     case OP_METHOD_NAMED:
     case OP_METHOD_SUPER:
+    case OP_METHOD_REDIR:
+    case OP_METHOD_REDIR_SUPER:
 #ifndef USE_ITHREADS
 	/* with ITHREADS, consts are stored in the pad, and the right pad
 	 * may not be active here, so skip */

ext/B/B.xs

@@ -751,6 +751,11 @@ struct OP_methods {
   { STR_WITH_LEN("first"),   op_offset_special, 0,                     },/*53*/
   { STR_WITH_LEN("meth_sv"), op_offset_special, 0,                     },/*54*/
   { STR_WITH_LEN("pmregexp"),op_offset_special, 0,                     },/*55*/
+#  ifdef USE_ITHREADS
+  { STR_WITH_LEN("rclass"),  op_offset_special, 0,                     },/*56*/
+#  else
+  { STR_WITH_LEN("rclass"),  op_offset_special, 0,                     },/*56*/
+#  endif
 #endif
 };
 
@@ -1032,6 +1037,7 @@ next(o)
 	B::METHOP::first     = 53
 	B::METHOP::meth_sv   = 54
 	B::PMOP::pmregexp    = 55
+	B::METHOP::rclass    = 56
     PREINIT:
 	SV *ret;
     PPCODE:
@@ -1250,6 +1256,21 @@ next(o)
 	    case 55: /* B::PMOP::pmregexp */
 		ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo));
 		break;
+	    case 56: /* B::METHOP::rclass */
+#ifdef USE_ITHREADS
+		ret = sv_2mortal(newSVuv(
+		    (o->op_type == OP_METHOD_REDIR ||
+		     o->op_type == OP_METHOD_REDIR_SUPER) ?
+		      cMETHOPx(o)->op_rclass_targ : 0
+		));
+#else
+		ret = make_sv_object(aTHX_
+		    (o->op_type == OP_METHOD_REDIR ||
+		     o->op_type == OP_METHOD_REDIR_SUPER) ?
+		      cMETHOPx(o)->op_rclass_sv : NULL
+		);
+#endif
+		break;
 	    default:
 		croak("method %s not implemented", op_methods[ix].name);
 	} else {

ext/B/B/Concise.pm

@@ -898,12 +898,19 @@ sub concise_op {
 	}
     }
     elsif ($h{class} eq "METHOP") {
+        my $prefix = '';
+        if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') {
+            my $rclass_sv = $op->rclass;
+            $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv]
+                unless ref $rclass_sv;
+            $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", ';
+        }
         if ($h{name} ne "method") {
             if (${$op->meth_sv}) {
-                $h{arg} = "(" . concise_sv($op->meth_sv, \%h, 1) . ")";
+                $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")";
             } else {
                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
-                $h{arg} = "[" . concise_sv($sv, \%h, 1) . "]";
+                $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]";
                 $h{targarglife} = $h{targarg} = "";
             }
         }

ext/Opcode/Opcode.pm

@@ -340,7 +340,7 @@ invert_opset function.
     rv2cv anoncode prototype coreargs
 
     entersub leavesub leavesublv return method method_named
-    method_super
+    method_super method_redir method_redir_super
      -- XXX loops via recursion?
 
     leaveeval -- needed for Safe to operate, is safe

lib/B/Deparse.pm

@@ -3946,6 +3946,11 @@ sub _method {
 	$meth = $self->meth_sv($meth)->PV;
     } elsif ($meth->name eq "method_super") {
 	$meth = "SUPER::".$self->meth_sv($meth)->PV;
+    } elsif ($meth->name eq "method_redir") {
+        $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
+    } elsif ($meth->name eq "method_redir_super") {
+        $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
+                $self->meth_sv($meth)->PV;
     } else {
 	$meth = $meth->first;
 	if ($meth->name eq "const") {
@@ -4586,6 +4591,15 @@ sub meth_sv {
     return $sv;
 }
 
+sub meth_rclass_sv {
+    my $self = shift;
+    my $op = shift;
+    my $sv = $op->rclass;
+    # the constant could be in the pad (under useithreads)
+    $sv = $self->padval($sv) unless ref $sv;
+    return $sv;
+}
+
 sub pp_const {
     my $self = shift;
     my($op, $cx) = @_;

lib/B/Op_private.pm

@@ -406,6 +406,8 @@ $bits{lvavref}{0} = $bf[0];
 $bits{mapwhile}{0} = $bf[0];
 $bits{method}{0} = $bf[0];
 $bits{method_named}{0} = $bf[0];
+$bits{method_redir}{0} = $bf[0];
+$bits{method_redir_super}{0} = $bf[0];
 $bits{method_super}{0} = $bf[0];
 @{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
 @{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);

op.c

@@ -852,6 +852,17 @@ Perl_op_clear(pTHX_ OP *o)
 	    }
 	}
 	break;
+    case OP_METHOD_REDIR:
+    case OP_METHOD_REDIR_SUPER:
+#ifdef USE_ITHREADS
+	if (cMETHOPx(o)->op_rclass_targ) {
+	    pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
+	    cMETHOPx(o)->op_rclass_targ = 0;
+	}
+#else
+	SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
+	cMETHOPx(o)->op_rclass_sv = NULL;
+#endif
     case OP_METHOD_NAMED:
     case OP_METHOD_SUPER:
         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
@@ -2234,6 +2245,8 @@ S_finalize_op(pTHX_ OP* o)
     /* Relocate all the METHOP's SVs to the pad for thread safety. */
     case OP_METHOD_NAMED:
     case OP_METHOD_SUPER:
+    case OP_METHOD_REDIR:
+    case OP_METHOD_REDIR_SUPER:
         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
         break;
 #endif
@@ -4692,6 +4705,12 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth
         methop->op_next = (OP*)methop;
     }
 
+#ifdef USE_ITHREADS
+    methop->op_rclass_targ = 0;
+#else
+    methop->op_rclass_sv = NULL;
+#endif
+
     CHANGE_TYPE(methop, type);
     methop = (METHOP*) CHECKOP(type, methop);
 
@@ -10307,11 +10326,12 @@ Perl_ck_match(pTHX_ OP *o)
 OP *
 Perl_ck_method(pTHX_ OP *o)
 {
-    SV *sv, *methsv;
+    SV *sv, *methsv, *rclass;
     const char* method;
     char* compatptr;
     int utf8;
     STRLEN len, nsplit = 0, i;
+    OP* new_op;
     OP * const kid = cUNOPo->op_first;
 
     PERL_ARGS_ASSERT_CK_METHOD;
@@ -10346,7 +10366,21 @@ Perl_ck_method(pTHX_ OP *o)
         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
     }
 
-    return o;
+    /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
+    if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
+        rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
+        new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
+    } else {
+        rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
+        new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
+    }
+#ifdef USE_ITHREADS
+    op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
+#else
+    cMETHOPx(new_op)->op_rclass_sv = rclass;
+#endif
+    op_free(o);
+    return new_op;
 }
 
 OP *
@@ -11644,6 +11678,8 @@ Perl_ck_subr(pTHX_ OP *o)
 	case OP_METHOD:
 	case OP_METHOD_NAMED:
 	case OP_METHOD_SUPER:
+	case OP_METHOD_REDIR:
+	case OP_METHOD_REDIR_SUPER:
 	    if (aop->op_type == OP_CONST) {
 		aop->op_private &= ~OPpCONST_STRICT;
 		const_class = &cSVOPx(aop)->op_sv;

op.h

@@ -202,6 +202,11 @@ struct methop {
         OP* op_first;   /* optree for method name */
         SV* op_meth_sv; /* static method name */
     } op_u;
+#ifdef USE_ITHREADS
+    PADOFFSET op_rclass_targ; /* pad index for redirect class */
+#else
+    SV*       op_rclass_sv;   /* static redirect class $o->A::meth() */
+#endif
 };
 
 struct pmop {
@@ -441,6 +446,7 @@ 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_rclass(v) PAD_SVl(cMETHOPx(v)->op_rclass_targ)
 #else
 #  define	cGVOPx_gv(o)	((GV*)cSVOPx(o)->op_sv)
 #  ifndef PERL_CORE
@@ -449,6 +455,7 @@ struct loop {
 #  endif
 #  define	cSVOPx_sv(v)	(cSVOPx(v)->op_sv)
 #  define	cSVOPx_svp(v)	(&cSVOPx(v)->op_sv)
+#  define	cMETHOPx_rclass(v) (cMETHOPx(v)->op_rclass_sv)
 #endif
 
 #  define	cMETHOPx_meth(v)	cSVOPx_sv(v)

opcode.h

@@ -351,6 +351,8 @@ EXTCONST char* const PL_op_name[] = {
 	"exit",
 	"method_named",
 	"method_super",
+	"method_redir",
+	"method_redir_super",
 	"entergiven",
 	"leavegiven",
 	"enterwhen",
@@ -743,6 +745,8 @@ EXTCONST char* const PL_op_desc[] = {
 	"exit",
 	"method with known name",
 	"super with known name",
+	"redirect method with known name",
+	"redirect super method with known name",
 	"given()",
 	"leave given block",
 	"when()",
@@ -1149,6 +1153,8 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 	Perl_pp_exit,
 	Perl_pp_method_named,
 	Perl_pp_method_super,
+	Perl_pp_method_redir,
+	Perl_pp_method_redir_super,
 	Perl_pp_entergiven,
 	Perl_pp_leavegiven,
 	Perl_pp_enterwhen,
@@ -1551,6 +1557,8 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_fun,		/* exit */
 	Perl_ck_null,		/* method_named */
 	Perl_ck_null,		/* method_super */
+	Perl_ck_null,		/* method_redir */
+	Perl_ck_null,		/* method_redir_super */
 	Perl_ck_null,		/* entergiven */
 	Perl_ck_null,		/* leavegiven */
 	Perl_ck_null,		/* enterwhen */
@@ -1947,6 +1955,8 @@ EXTCONST U32 PL_opargs[] = {
 	0x00009b04,	/* exit */
 	0x00000e40,	/* method_named */
 	0x00000e40,	/* method_super */
+	0x00000e40,	/* method_redir */
+	0x00000e40,	/* method_redir_super */
 	0x00000340,	/* entergiven */
 	0x00000100,	/* leavegiven */
 	0x00000340,	/* enterwhen */
@@ -2569,6 +2579,8 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       48, /* exit */
        0, /* method_named */
        0, /* method_super */
+       0, /* method_redir */
+       0, /* method_redir_super */
        0, /* entergiven */
        0, /* leavegiven */
        0, /* enterwhen */
@@ -2768,7 +2780,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
  */
 
 EXTCONST U16  PL_op_private_bitdefs[] = {
-    0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */
+    0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */
     0x281c, 0x3a19, /* pushmark */
     0x00bd, /* wantarray, runcv */
     0x03b8, 0x1490, 0x3acc, 0x3588, 0x2be5, /* const */
@@ -3043,6 +3055,8 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* EXIT       */ (OPpARG4_MASK),
     /* METHOD_NAMED */ (OPpARG1_MASK),
     /* METHOD_SUPER */ (OPpARG1_MASK),
+    /* METHOD_REDIR */ (OPpARG1_MASK),
+    /* METHOD_REDIR_SUPER */ (OPpARG1_MASK),
     /* ENTERGIVEN */ (OPpARG1_MASK),
     /* LEAVEGIVEN */ (OPpARG1_MASK),
     /* ENTERWHEN  */ (OPpARG1_MASK),