Perl_newSLICEOP: Optimise '(caller)[0]' into 'scalar caller'

A subroutine can obtain just the package of its caller in a couple of ways.
Both seem somewhat common.

 * `caller` - in scaler context, as in `my $x = caller;`
 * `(caller)[0]`, as in `my $x = (caller)[0];`

In the first, `caller` finds the package name, sticks it in a new SV, and
puts that (or `undef`) on the stack:

    <0> caller[t2] s

In the second, `caller` (a) finds the package name, filename, and line
(b) creates three new SVs to hold them all (c) puts those SVs on the stack
(d) does a list slice to leave just the package SV on the stack.

    7        <2> lslice sK/2 ->8
    -           <1> ex-list lK ->5
    3              <0> pushmark s ->4
    4              <$> const[IV 0] s ->5
    -           <1> ex-list lK ->7
    5              <0> pushmark s ->6
    6              <0> caller[t2] l ->7

This commit checks for the second case inside `Perl_newSLICEOP` and
instead of constructing a `lslice` OP, returns just the `caller` OP
with scalar context applied.

Author: richardleach

lib/B/Deparse.pm

@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse 1.85;
+package B::Deparse 1.86;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -2586,7 +2586,14 @@ sub pp_akeys { unop(@_, "keys") }
 sub pp_pop { unop(@_, "pop") }
 sub pp_shift { unop(@_, "shift") }
 
-sub pp_caller { unop(@_, "caller") }
+sub pp_caller {
+    my ($self, $op, $cx) = @_;
+    if ($op->flags & OPf_SPECIAL) {
+        return "scalar ".unop(@_, "caller");
+    } else {
+        return unop(@_, "caller") 
+    }
+}
 sub pp_reset { unop(@_, "reset") }
 sub pp_exit { unop(@_, "exit") }
 sub pp_prototype { unop(@_, "prototype") }

op.c

@@ -8534,6 +8534,17 @@ constructed op tree.
 OP *
 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
 {
+    /* (caller)[0] is much more efficiently written as scalar(caller) */
+    if (OP_TYPE_IS(subscript, OP_CONST) && OP_TYPE_IS(listval, OP_CALLER)
+        && ! (listval->op_flags & OPf_KIDS) ) {
+        SV *theconst = cSVOPx_sv(subscript);
+        if (SvIOK(theconst) && 0 == SvIVX(theconst)) {
+            op_free(subscript);
+            listval->op_flags |= OPf_SPECIAL; /* For B::Deparse */
+            return scalar(listval);
+        }
+    }
+
     return newBINOP(OP_LSLICE, flags,
             list(op_force_list(subscript)),
             list(op_force_list(listval)));

op.h

@@ -164,6 +164,8 @@ Deprecated.  Use C<GIMME_V> instead.
                                 /*  On OP_RETURN, module_true is in effect */
                                 /*  On OP_NEXT/OP_LAST/OP_REDO, there is no
                                  *  loop label */
+                                /*  On OP_CALLER, "(caller)[0]" was optimised to
+                                 *  "caller" with scalar context explicitly set. */
 /* There is no room in op_flags for this one, so it has its own bit-
    field member (op_folded) instead.  The flag is only used to tell
    op_convert_list to set op_folded.  */

t/op/caller.t

@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc('../lib');
-    plan( tests => 112 ); # some tests are run in a BEGIN block
+    plan( tests => 113 ); # some tests are run in a BEGIN block
 }
 
 my @c;
@@ -393,3 +393,9 @@ do './op/caller.pl' or die $@;
     }
     ->($a[0], 'B');
 }
+
+{
+    my @x = (caller)[0]; # This may be optimised to: my @x = caller
+                         # either way, @x should only have one element
+    is( $#x, 0, 'my @x = (caller)[0] puts one element in @x')
+}

t/perf/opcount.t

@@ -1106,4 +1106,13 @@ test_opcount(0, "substr with const zero offset  (gv)",
                     sassign      => 1
                 });
 
+test_opcount(0, "(caller)[0]",
+                sub { my $x = (caller)[0] },
+                {
+                    caller      => 1,
+                    const       => 0,
+                    lslice      => 0,
+                    pushmark    => 0,
+                });
+
 done_testing();