diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 668ab90c7e3c..67aded29ef7b 100644 --- a/lib/B/Deparse.pm +++ b/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") } diff --git a/op.c b/op.c index f616532c491c..aa28c71e1a8a 100644 --- a/op.c +++ b/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))); diff --git a/op.h b/op.h index 33bea989456f..38002eaf339c 100644 --- a/op.h +++ b/op.h @@ -164,6 +164,8 @@ Deprecated. Use C 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. */ diff --git a/t/op/caller.t b/t/op/caller.t index e755a110eb4f..51deef5e1802 100644 --- a/t/op/caller.t +++ b/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') +} diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 8695e162d16e..0be2c4b568e6 100644 --- a/t/perf/opcount.t +++ b/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();