Process $self in method subs as a subsignature parameter

This has at least three advantages:

 * Removes more special-case code from `class.c` and makes generated
   optrees more similar to others

 * Ensures that no other ops appear in the optree before signature
   handling (as the OP_METHSTART used to). This will be useful for
   upcoming faster-signatures changes

 * Corrects the previous "off-by-one" error in parameter counts as
   reported by the argument count check exception messages

Author: leonerd

class.c

@@ -953,6 +953,25 @@ Perl_class_prepare_method_parse(pTHX_ CV *cv)
     CvIsMETHOD_on(cv);
 }
 
+#define find_op_methstart(o)  S_find_op_methstart(aTHX_ o)
+static OP *
+S_find_op_methstart(pTHX_ OP *o)
+{
+    if(o->op_type == OP_METHSTART)
+        return o;
+
+    if(!(o->op_flags & OPf_KIDS))
+        return NULL;
+
+    for(OP *kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+        OP *methstart = find_op_methstart(kid);
+        if(methstart)
+            return methstart;
+    }
+
+    return NULL;
+}
+
 OP *
 Perl_class_wrap_method_body(pTHX_ OP *o)
 {
@@ -1010,7 +1029,18 @@ Perl_class_wrap_method_body(pTHX_ OP *o)
     if(o->op_type != OP_LINESEQ)
         o = newLISTOP(OP_LINESEQ, 0, o, NULL);
 
-    op_sibling_splice(o, NULL, 0, newUNOP_AUX(OP_METHSTART, 0, NULL, aux));
+    if(CvSIGNATURE(PL_compcv)) {
+        /* A signatured method has already injected the OP_METHSTART; we just
+         * have to find it and attach the aux structure to it
+         */
+        OP *methstartop = find_op_methstart(o);
+        assert(methstartop);
+        assert(!cUNOP_AUXx(methstartop)->op_aux);
+
+        cUNOP_AUXx(methstartop)->op_aux = aux;
+    }
+    else
+        op_sibling_splice(o, NULL, 0, newUNOP_AUX(OP_METHSTART, 0, NULL, aux));
 
     return o;
 }
@@ -1108,13 +1138,14 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value)
 
     I32 save_ix = block_start(TRUE);
 
-    subsignature_start();
-
     PADOFFSET padix;
 
     padix = pad_add_name_pvs("$self", 0, NULL, NULL);
     assert(padix == PADIX_SELF);
 
+    subsignature_start();
+    CvSIGNATURE_on(PL_compcv);
+
     OP *sigop = subsignature_finish();
 
     padix = pad_import_field(pn);
@@ -1175,13 +1206,14 @@ apply_field_attribute_writer(pTHX_ PADNAME *pn, SV *value)
 
     I32 save_ix = block_start(TRUE);
 
-    subsignature_start();
-
     PADOFFSET padix;
 
     padix = pad_add_name_pvs("$self", 0, NULL, NULL);
     assert(padix == PADIX_SELF);
 
+    subsignature_start();
+    CvSIGNATURE_on(PL_compcv);
+
     /* param pad variable doesn't technically need a name, so don't bother as
      * reusing the field name will provoke a warning */
     PADOFFSET param_padix = padix = pad_add_name_pvn("$", 1, 0, NULL, NULL);

lib/B/Deparse.pm

@@ -1238,6 +1238,8 @@ sub deparse_argops {
         # skip trailing nextstate
         last if $$o == $$last;
 
+        next if $cv->CvFLAGS & CVf_IsMETHOD and $o->name eq "methstart";
+
         # OP_NEXTSTATE
         return unless $o->name =~ /^(next|db)state$/;
         return if $o->label;
@@ -1296,6 +1298,13 @@ sub deparse_argops {
 
     }
 
+    if ($cv->CvFLAGS & CVf_IsMETHOD) {
+        # Remove the implied `$self` argument
+        warn "Expected first signature argument to be named \$self"
+            unless @sig and $sig[0] eq '$self';
+        shift @sig;
+    }
+
     while (++$last_ix < $params) {
         push @sig, $last_ix <  $mandatory ? '$' : '$=';
     }
@@ -1361,10 +1370,6 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
         my $is_list = ($lineseq->name eq "lineseq");
         my $firstop = $is_list ? $lineseq->first : $lineseq;
 
-        if ($is_method and $firstop->name eq "methstart") {
-            $firstop = $firstop->sibling;
-        }
-
         # Try to deparse first subtree as a signature if possible.
         # Top of signature subtree has an ex-argcheck as a placeholder
         if (    $has_sig

op.c

@@ -16516,6 +16516,18 @@ Perl_subsignature_start(pTHX)
 
     SAVEVPTR(PL_parser->signature);
     PL_parser->signature = signature;
+
+    /* TODO: This should ideally be performed by some sort of "magic" or
+     * "hook" mechanism on PL_compcv that class.c installed, thus decoupling
+     * this otherwise tightly-coupled mechanism here
+     */
+    if(CvIsMETHOD(PL_compcv)) {
+        assert(PadnamelistMAX(PL_comppad_name) >= 1);
+        /* PADIX_SELF == 1 */
+        assert(PadnamePV(PadnamelistARRAY(PL_comppad_name)[1])[0] == '$');
+        subsignature_append_positional(1, 0, NULL);
+        subsignature_append_fence_op(newUNOP_AUX(OP_METHSTART, OPpSELF_IN_PAD << 8, NULL, NULL));
+    }
 }
 
 /* Appends another arbitrary optree into the accumulated set of signature-

pod/perldelta.pod

@@ -37,6 +37,17 @@ here, but most should go in the L</Performance Enhancements> section.
 
 [ List each enhancement as a =head2 entry ]
 
+=head2 Reported argument counts in C<method> signatures now account for C<$self>
+
+In previous versions of Perl, the exception message thrown by a C<method>
+subroutine with a signature when it does not receive an appropriate number of
+arguments to match its declared parameters failed to account for the implied
+C<$self> parameter, causing the numbers in the message to be 1 fewer than
+intended.
+
+This has now been fixed, so messages report the correct number of arguments
+including the object invocant.
+
 =head1 Security
 
 XXX Any security-related notices go here. In particular, any security

t/class/accessor.t

@@ -33,7 +33,7 @@ no warnings 'experimental::class';
     # Read accessor does not permit arguments
     ok(!eval { $o->s("value") },
         'Reader accessor fails with argument');
-    like($@, qr/^Too many arguments for subroutine \'Testcase1::s\' \(got 1; expected 0\) at /,
+    like($@, qr/^Too many arguments for subroutine \'Testcase1::s\' \(got 2; expected 1\) at /,
         'Failure from argument to accessor');
 }
 
@@ -51,11 +51,11 @@ no warnings 'experimental::class';
     # Write accessor wants exactly one argument
     ok(!eval { $o->set_s() },
         'Reader accessor fails with no argument');
-    like($@, qr/^Too few arguments for subroutine \'Testcase2::set_s\' \(got 0; expected 1\) at /,
+    like($@, qr/^Too few arguments for subroutine \'Testcase2::set_s\' \(got 1; expected 2\) at /,
         'Failure from argument to accessor');
     ok(!eval { $o->set_s(1, 2) },
         'Reader accessor fails with 2 arguments');
-    like($@, qr/^Too many arguments for subroutine \'Testcase2::set_s\' \(got 2; expected 1\) at /,
+    like($@, qr/^Too many arguments for subroutine \'Testcase2::set_s\' \(got 3; expected 2\) at /,
         'Failure from argument to accessor');
 }
 

t/class/method.t

@@ -21,7 +21,7 @@ no warnings 'experimental::class';
     is($obj->retself, $obj, '$self inside method');
 }
 
-# methods have signatures; signatures do not capture $self
+# methods have signatures
 {
     # Turn off the 'signatures' feature to prove that 'method' is always
     # signatured even without it
@@ -34,6 +34,11 @@ no warnings 'experimental::class';
     my $obj = Testcase2->new;
     is($obj->retfirst,      123, 'method signature params work');
     is($obj->retfirst(456), 456, 'method signature params skip $self');
+
+    # argument counts take account of implicit $self
+    my $e = eval { $obj->retfirst(1, 2) } ? undef : $@;
+    like($e, qr/^Too many arguments for subroutine 'Testcase2::retfirst' \(got 3; expected at most 2\) /,
+        'method signature fails with too many arguments');
 }
 
 # methods can still capture regular package lexicals