Skip to content

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

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: blead
Choose a base branch
from
Open
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 9 additions & 2 deletions lib/B/Deparse.pm
Original file line number Diff line number Diff line change
@@ -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") }
11 changes: 11 additions & 0 deletions op.c
Original file line number Diff line number Diff line change
@@ -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)));
2 changes: 2 additions & 0 deletions op.h
Original file line number Diff line number Diff line change
@@ -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. */
8 changes: 7 additions & 1 deletion t/op/caller.t
Original file line number Diff line number Diff line change
@@ -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')
}
9 changes: 9 additions & 0 deletions t/perf/opcount.t
Original file line number Diff line number Diff line change
@@ -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();