Make OP_METHOD* to be of new class METHOP

Introduce a new opcode class, METHOP, which will hold class/method related
info needed at runtime to improve performance of class/object method
calls, then change OP_METHOD and OP_METHOD_NAMED from being UNOP/SVOP to
being METHOP.

Note that because OP_METHOD is a UNOP with an op_first, while
OP_METHOD_NAMED is an SVOP, the first field of the METHOP structure
is a union holding either op_first or op_sv. This was seen as less messy
than having to introduce two new op classes.

The new op class's character is '.'

Nothing has changed in functionality and/or performance by this commit.
It just introduces new structure which will be extended with extra
fields and used in later commits.

Added METHOP constructors:
- newMETHOP() for method ops with dynamic method names.
  The only optype for this op is OP_METHOD.
- newMETHOP_named() for method ops with constant method names.
  Optypes for this op are: OP_METHOD_NAMED (currently) and (later)
  OP_METHOD_SUPER, OP_METHOD_REDIR, OP_METHOD_NEXT, OP_METHOD_NEXTCAN,
  OP_METHOD_MAYBENEXT

(This commit includes fixups by davem)

Author: syber

dump.c

@@ -962,7 +962,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #ifndef USE_ITHREADS
 	/* with ITHREADS, consts are stored in the pad, and the right pad
 	 * may not be active here, so skip */
-	Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
+	Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
 #endif
 	break;
     case OP_NEXTSTATE:

embed.fnc

@@ -471,6 +471,11 @@ p	|char*	|find_script	|NN const char *scriptname|bool dosearch \
 s	|OP*	|force_list	|NULLOK OP* arg|bool nullit
 i	|OP*	|op_integerize	|NN OP *o
 i	|OP*	|op_std_init	|NN OP *o
+#if defined(USE_ITHREADS)
+i	|void	|op_relocate_sv	|NN SV** svp|NN PADOFFSET* targp
+#endif
+i	|OP*	|newMETHOP_internal	|I32 type|I32 flags|NULLOK OP* dynamic_meth \
+					|NULLOK SV* const_meth
 : FIXME
 s	|OP*	|fold_constants	|NN OP *o
 #endif
@@ -1029,6 +1034,8 @@ Apda	|OP*	|newWHENOP	|NULLOK OP* cond|NN OP* block
 Apda	|OP*	|newWHILEOP	|I32 flags|I32 debuggable|NULLOK LOOP* loop \
 				|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
 				|I32 has_my
+Apda	|OP*	|newMETHOP	|I32 type|I32 flags|NN OP* dynamic_meth
+Apda	|OP*	|newMETHOP_named|I32 type|I32 flags|NN SV* const_meth
 Apd	|CV*	|rv2cv_op_cv	|NN OP *cvop|U32 flags
 Apd	|OP*	|ck_entersub_args_list|NN OP *entersubop
 Apd	|OP*	|ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv

embed.h

@@ -371,6 +371,8 @@
 #define newLOGOP(a,b,c,d)	Perl_newLOGOP(aTHX_ a,b,c,d)
 #define newLOOPEX(a,b)		Perl_newLOOPEX(aTHX_ a,b)
 #define newLOOPOP(a,b,c,d)	Perl_newLOOPOP(aTHX_ a,b,c,d)
+#define newMETHOP(a,b,c)	Perl_newMETHOP(aTHX_ a,b,c)
+#define newMETHOP_named(a,b,c)	Perl_newMETHOP_named(aTHX_ a,b,c)
 #define newMYSUB(a,b,c,d,e)	Perl_newMYSUB(aTHX_ a,b,c,d,e)
 #define newNULLLIST()		Perl_newNULLLIST(aTHX)
 #define newOP(a,b)		Perl_newOP(aTHX_ a,b)
@@ -1525,6 +1527,7 @@
 #define my_kid(a,b,c)		S_my_kid(aTHX_ a,b,c)
 #define newDEFSVOP()		S_newDEFSVOP(aTHX)
 #define newGIVWHENOP(a,b,c,d,e)	S_newGIVWHENOP(aTHX_ a,b,c,d,e)
+#define newMETHOP_internal(a,b,c,d)	S_newMETHOP_internal(aTHX_ a,b,c,d)
 #define new_logop(a,b,c,d)	S_new_logop(aTHX_ a,b,c,d)
 #define no_bareword_allowed(a)	S_no_bareword_allowed(aTHX_ a)
 #define no_fh_allowed(a)	S_no_fh_allowed(aTHX_ a)
@@ -1543,6 +1546,9 @@
 #define simplify_sort(a)	S_simplify_sort(aTHX_ a)
 #define too_few_arguments_pv(a,b,c)	S_too_few_arguments_pv(aTHX_ a,b,c)
 #define too_many_arguments_pv(a,b,c)	S_too_many_arguments_pv(aTHX_ a,b,c)
+#    if defined(USE_ITHREADS)
+#define op_relocate_sv(a,b)	S_op_relocate_sv(aTHX_ a,b)
+#    endif
 #  endif
 #  if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
 #define report_redefined_cv(a,b,c)	Perl_report_redefined_cv(aTHX_ a,b,c)

ext/B/B.pm

@@ -69,10 +69,11 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs
 @B::LOOP::ISA = 'B::LISTOP';
 @B::PMOP::ISA = 'B::LISTOP';
 @B::COP::ISA = 'B::OP';
+@B::METHOP::ISA = 'B::OP';
 
 @B::SPECIAL::ISA = 'B::OBJECT';
 
-@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
+@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP METHOP);
 # bytecode.pl contained the following comment:
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
@@ -1065,17 +1066,17 @@ information is no longer stored directly in the hash.
 =head2 OP-RELATED CLASSES
 
 C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
-C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>.
+C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>, C<B::METHOP>.
 
 These classes correspond in the obvious way to the underlying C
 structures of similar names.  The inheritance hierarchy mimics the
 underlying C "inheritance":
 
                                  B::OP
                                    |
-                   +---------------+--------+--------+-------+
-                   |               |        |        |       |
-                B::UNOP          B::SVOP B::PADOP  B::COP  B::PVOP
+                   +----------+---------+--------+-------+---------+
+                   |          |         |        |       |         |
+                B::UNOP    B::SVOP  B::PADOP  B::COP  B::PVOP  B::METHOP
                  ,'  `-.
                 /       `--.
            B::BINOP     B::LOGOP
@@ -1263,6 +1264,16 @@ Since perl 5.17.1
 
 =back
 
+=head2 B::METHOP Methods (Since Perl 5.22)
+
+=over 4
+
+=item first
+
+=item meth_sv
+
+=back
+
 =head2 OTHER CLASSES
 
 Perl 5.18 introduces a new class, B::PADLIST, returned by B::CV's

ext/B/B.xs

@@ -60,7 +60,8 @@ typedef enum {
     OPc_PADOP,	/* 8 */
     OPc_PVOP,	/* 9 */
     OPc_LOOP,	/* 10 */
-    OPc_COP	/* 11 */
+    OPc_COP,	/* 11 */
+    OPc_METHOP	/* 12 */
 } opclass;
 
 static const char* const opclassnames[] = {
@@ -75,7 +76,8 @@ static const char* const opclassnames[] = {
     "B::PADOP",
     "B::PVOP",
     "B::LOOP",
-    "B::COP"	
+    "B::COP",
+    "B::METHOP"
 };
 
 static const size_t opsizes[] = {
@@ -90,7 +92,8 @@ static const size_t opsizes[] = {
     sizeof(PADOP),
     sizeof(PVOP),
     sizeof(LOOP),
-    sizeof(COP)	
+    sizeof(COP),
+    sizeof(METHOP)
 };
 
 #define MY_CXT_KEY "B::_guts" XS_VERSION
@@ -232,6 +235,8 @@ cc_opclass(pTHX_ const OP *o)
 	    return OPc_BASEOP;
 	else
 	    return OPc_PVOP;
+    case OA_METHOP:
+	return OPc_METHOP;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
 	 OP_NAME(o));
@@ -586,6 +591,7 @@ typedef PADOP	*B__PADOP;
 typedef PVOP	*B__PVOP;
 typedef LOOP	*B__LOOP;
 typedef COP	*B__COP;
+typedef METHOP  *B__METHOP;
 
 typedef SV	*B__SV;
 typedef SV	*B__IV;
@@ -735,6 +741,10 @@ struct OP_methods {
   { STR_WITH_LEN("parent"),  op_offset_special, 0,                     },/*52*/
 #  endif
 #endif
+#if PERL_VERSION >= 21
+  { STR_WITH_LEN("first"),   op_offset_special, 0,                     },/*53*/
+  { STR_WITH_LEN("meth_sv"), op_offset_special, 0,                     },/*54*/
+#endif
 };
 
 #include "const-c.inc"
@@ -1012,6 +1022,8 @@ next(o)
 	B::OP::folded        = 50
 	B::OP::lastsib       = 51
 	B::OP::parent        = 52
+	B::METHOP::first     = 53
+	B::METHOP::meth_sv   = 54
     PREINIT:
 	SV *ret;
     PPCODE:
@@ -1208,6 +1220,25 @@ next(o)
 	    case 52: /* B::OP::parent */
 		ret = make_op_object(aTHX_ op_parent(o));
 		break;
+	    case 53: /* B::METHOP::first   */
+                /* METHOP struct has an op_first/op_meth_sv union
+                 * as its first extra field. How to interpret the
+                 * union depends on the op type. For the purposes of
+                 * B, we treat it as a struct with both fields present,
+                 * where one of the fields always happens to be null
+                 * (i.e. we return NULL in preference to croaking with
+                 * 'method not implemented').
+                 */
+		ret = make_op_object(aTHX_
+                            o->op_type == OP_METHOD
+                                ? cMETHOPx(o)->op_u.op_first : NULL);
+		break;
+	    case 54: /* B::METHOP::meth_sv */
+                /* see comment above about METHOP */
+		ret = make_sv_object(aTHX_
+                            o->op_type == OP_METHOD
+                                ? NULL : cMETHOPx(o)->op_u.op_meth_sv);
+		break;
 	    default:
 		croak("method %s not implemented", op_methods[ix].name);
 	} else {

ext/B/B/Concise.pm

@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "0.993";
+our $VERSION   = "0.994";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
 		     concise_subref concise_cv concise_main
@@ -400,7 +400,8 @@ my $lastnext;	# remembers op-chain, used to insert gotos
 
 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
 	       'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
-	       'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
+	       'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
+	       'METHOP' => '.');
 
 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
 my @linenoise =
@@ -891,16 +892,26 @@ sub concise_op {
     elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
 	unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
 	    my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
-	    my $preferpv = $h{name} eq "method_named";
 	    if ($h{class} eq "PADOP" or !${$op->sv}) {
 		my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
-		$h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
+		$h{arg} = "[" . concise_sv($sv, \%h, 0) . "]";
 		$h{targarglife} = $h{targarg} = "";
 	    } else {
-		$h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
+		$h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")";
 	    }
 	}
     }
+    elsif ($h{class} eq "METHOP") {
+        if ($h{name} eq "method_named") {
+            if (${$op->meth_sv}) {
+                $h{arg} = "(" . 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{targarglife} = $h{targarg} = "";
+            }
+        }
+    }
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
     $h{opt} = $op->opt;
@@ -1379,6 +1390,7 @@ B:: namespace that represents the ops in your Perl code.
     {      LOOP             An OP that holds pointers for a loop
     ;      COP              An OP that marks the start of a statement
     #      PADOP            An OP with a GV on the pad
+    .      METHOP           An OP with method call info
 
 =head2 OP flags abbreviations