summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--dist/B-Deparse/Deparse.pm126
-rw-r--r--dist/B-Deparse/t/deparse.t86
-rw-r--r--dump.c58
-rw-r--r--ext/B/B/Concise.pm55
-rw-r--r--ext/B/B/Xref.pm11
-rw-r--r--ext/B/t/optree_sort.t82
-rw-r--r--ext/B/t/optree_varinit.t16
-rw-r--r--ext/Opcode/Opcode.pm4
-rw-r--r--op.c138
-rw-r--r--op.h4
-rw-r--r--opcode.h5
-rw-r--r--opnames.h3
-rw-r--r--pp_hot.c23
-rw-r--r--pp_proto.h1
-rw-r--r--regcomp.c15
-rw-r--r--regen/opcodes1
-rw-r--r--sv.c24
-rw-r--r--t/op/sort.t19
18 files changed, 562 insertions, 109 deletions
diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 07386d5626..85b3cb4544 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = '1.18';
+$VERSION = '1.19';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
@@ -311,6 +311,109 @@ BEGIN {
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
+
+
+
+# _pessimise_walk(): recursively walk the optree of a sub,
+# possibly undoing optimisations along the way.
+
+sub _pessimise_walk {
+ my ($self, $startop) = @_;
+
+ return unless $$startop;
+ my ($op, $prevop);
+ for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
+ my $ppname = $op->name;
+
+ # pessimisations start here
+
+ if ($ppname eq "padrange") {
+ # remove PADRANGE:
+ # the original optimisation changed this:
+ # pushmark -> (various pad and list and null ops) -> the_rest
+ # into this:
+ # padrange ----------------------------------------> the_rest
+ # so we just need to convert the padrange back into a
+ # pushmark, and set its op_next to op_sibling, which is the
+ # head of the original chain of optimised-away pad ops.
+
+ $B::overlay->{$$op} = {
+ name => 'pushmark',
+ private => ($op->private & OPpLVAL_INTRO),
+ next => $op->sibling,
+ };
+ }
+
+ # pessimisations end here
+
+ if (class($op) eq 'PMOP'
+ && ref($op->pmreplroot)
+ && ${$op->pmreplroot}
+ && $op->pmreplroot->isa( 'B::OP' ))
+ {
+ $self-> _pessimise_walk($op->pmreplroot);
+ }
+
+ if ($op->flags & OPf_KIDS) {
+ $self-> _pessimise_walk($op->first);
+ }
+
+ }
+}
+
+
+# _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
+# possibly undoing optimisations along the way.
+
+sub _pessimise_walk_exe {
+ my ($self, $startop, $visited) = @_;
+
+ return unless $$startop;
+ return if $visited->{$$startop};
+ my ($op, $prevop);
+ for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
+ last if $visited->{$$op};
+ $visited->{$$op} = 1;
+ my $ppname = $op->name;
+ if ($ppname =~
+ /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
+ # entertry is also a logop, but its op_other invariably points
+ # into the same chain as the main execution path, so we skip it
+ ) {
+ $self->_pessimise_walk_exe($op->other, $visited);
+ }
+ elsif ($ppname eq "subst") {
+ $self->_pessimise_walk_exe($op->pmreplstart, $visited);
+ }
+ elsif ($ppname =~ /^(enter(loop|iter))$/) {
+ # redoop and nextop will already be covered by the main block
+ # of the loop
+ $self->_pessimise_walk_exe($op->lastop, $visited);
+ }
+
+ # pessimisations start here
+ }
+}
+
+# Go through an optree and and "remove" some optimisations by using an
+# overlay to selectively modify or un-null some ops. Deparsing in the
+# absence of those optimisations is then easier.
+#
+# Note that older optimisations are not removed, as Deparse was already
+# written to recognise them before the pessimise/overlay system was added.
+
+sub pessimise {
+ my ($self, $root, $start) = @_;
+
+ # walk tree in root-to-branch order
+ $self->_pessimise_walk($root);
+
+ my %visited;
+ # walk tree in execution order
+ $self->_pessimise_walk_exe($start, \%visited);
+}
+
+
sub null {
my $op = shift;
return class($op) eq "NULL";
@@ -377,6 +480,8 @@ sub begin_is_use {
my ($self, $cv) = @_;
my $root = $cv->ROOT;
local @$self{qw'curcv curcvlex'} = ($cv);
+ local $B::overlay = {};
+ $self->pessimise($root, $cv->START);
#require B::Debug;
#B::walkoptree($cv->ROOT, "debug");
my $lineseq = $root->first;
@@ -680,8 +785,12 @@ sub compile {
print $self->print_protos;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
- print $self->indent($self->deparse_root(main_root)), "\n"
- unless null main_root;
+ my $root = main_root;
+ local $B::overlay = {};
+ unless (null $root) {
+ $self->pessimise($root, main_start);
+ print $self->indent($self->deparse_root($root)), "\n";
+ }
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
push @text, $self->next_todo;
@@ -889,8 +998,11 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
local(@$self{qw'curstash warnings hints hinthash'})
= @$self{qw'curstash warnings hints hinthash'};
my $body;
- if (not null $cv->ROOT) {
- my $lineseq = $cv->ROOT->first;
+ my $root = $cv->ROOT;
+ local $B::overlay = {};
+ if (not null $root) {
+ $self->pessimise($root, $cv->START);
+ my $lineseq = $root->first;
if ($lineseq->name eq "lineseq") {
my @ops;
for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
@@ -904,7 +1016,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
}
}
else {
- $body = $self->deparse($cv->ROOT->first, 0);
+ $body = $self->deparse($root->first, 0);
}
}
else {
@@ -929,6 +1041,8 @@ sub deparse_format {
local(@$self{qw'curstash warnings hints hinthash'})
= @$self{qw'curstash warnings hints hinthash'};
my $op = $form->ROOT;
+ local $B::overlay = {};
+ $self->pessimise($op, $form->START);
my $kid;
return "\f." if $op->first->name eq 'stub'
|| $op->first->name eq 'nextstate';
diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t
index d1c6cb0a1f..0b04467a0b 100644
--- a/dist/B-Deparse/t/deparse.t
+++ b/dist/B-Deparse/t/deparse.t
@@ -1279,3 +1279,89 @@ select F;
select $f;
select $mfh;
select 'a+b';
+####
+# 'my' works with padrange op
+my($z, @z);
+my $m1;
+$m1 = 1;
+$z = $m1;
+my $m2 = 2;
+my($m3, $m4);
+($m3, $m4) = (1, 2);
+@z = ($m3, $m4);
+my($m5, $m6) = (1, 2);
+my($m7, undef, $m8) = (1, 2, 3);
+@z = ($m7, undef, $m8);
+($m7, undef, $m8) = (1, 2, 3);
+####
+# 'our/local' works with padrange op
+no strict;
+our($z, @z);
+our $o1;
+local $o11;
+$o1 = 1;
+local $o1 = 1;
+$z = $o1;
+$z = local $o1;
+our $o2 = 2;
+our($o3, $o4);
+($o3, $o4) = (1, 2);
+local($o3, $o4) = (1, 2);
+@z = ($o3, $o4);
+@z = local($o3, $o4);
+our($o5, $o6) = (1, 2);
+our($o7, undef, $o8) = (1, 2, 3);
+@z = ($o7, undef, $o8);
+@z = local($o7, undef, $o8);
+($o7, undef, $o8) = (1, 2, 3);
+local($o7, undef, $o8) = (1, 2, 3);
+####
+# 'state' works with padrange op
+no strict;
+use feature 'state';
+state($z, @z);
+state $s1;
+$s1 = 1;
+$z = $s1;
+state $s2 = 2;
+state($s3, $s4);
+($s3, $s4) = (1, 2);
+@z = ($s3, $s4);
+# assignment of state lists isn't implemented yet
+#state($s5, $s6) = (1, 2);
+#state($s7, undef, $s8) = (1, 2, 3);
+#@z = ($s7, undef, $s8);
+($s7, undef, $s8) = (1, 2, 3);
+####
+# anon lists with padrange
+my($a, $b);
+my $c = [$a, $b];
+my $d = {$a, $b};
+####
+# slices with padrange
+my($a, $b);
+my(@x, %y);
+@x = @x[$a, $b];
+@x = @y{$a, $b};
+####
+# binops with padrange
+my($a, $b, $c);
+$c = $a cmp $b;
+$c = $a + $b;
+$a += $b;
+$c = $a - $b;
+$a -= $b;
+$c = my $a1 cmp $b;
+$c = my $a2 + $b;
+$a += my $b1;
+$c = my $a3 - $b;
+$a -= my $b2;
+####
+# 'x' with padrange
+my($a, $b, $c, $d, @e);
+$c = $a x $b;
+$a x= $b;
+@e = ($a) x $d;
+@e = ($a, $b) x $d;
+@e = ($a, $b, $c) x $d;
+@e = ($a, 1) x $d;
diff --git a/dump.c b/dump.c
index cdc3118f25..c74c00363b 100644
--- a/dump.c
+++ b/dump.c
@@ -905,6 +905,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
}
if (o->op_private) {
SV * const tmpsv = newSVpvs("");
+
if (PL_opargs[optype] & OA_TARGLEX) {
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
@@ -962,10 +963,19 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
if (o->op_private & OPpFT_STACKED)
sv_catpv(tmpsv, ",FT_STACKED");
}
+
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
+
+ if (o->op_type == OP_PADRANGE)
+ Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf,
+ (UV)(o->op_private & OPpPADRANGE_COUNTMASK));
+
if (SvCUR(tmpsv))
Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
+ else
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
+ (UV)o->op_private);
SvREFCNT_dec(tmpsv);
}
@@ -2189,25 +2199,45 @@ Perl_debop(pTHX_ const OP *o)
else
PerlIO_printf(Perl_debug_log, "(NULL)");
break;
+
+ {
+ int count;
+
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
- {
+ count = 1;
+ goto dump_padop;
+ case OP_PADRANGE:
+ count = o->op_private & OPpPADRANGE_COUNTMASK;
+ dump_padop:
/* print the lexical's name */
- CV * const cv = deb_curcv(cxstack_ix);
- SV *sv;
- if (cv) {
- PADLIST * const padlist = CvPADLIST(cv);
- PAD * const comppad = *PadlistARRAY(padlist);
- sv = *av_fetch(comppad, o->op_targ, FALSE);
- } else
- sv = NULL;
- if (sv)
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
- else
- PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
- }
+ {
+ CV * const cv = deb_curcv(cxstack_ix);
+ SV *sv;
+ PAD * comppad = NULL;
+ int i;
+
+ if (cv) {
+ PADLIST * const padlist = CvPADLIST(cv);
+ comppad = *PadlistARRAY(padlist);
+ }
+ PerlIO_printf(Perl_debug_log, "(");
+ for (i = 0; i < count; i++) {
+ if (comppad &&
+ (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
+ PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
+ else
+ PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
+ (UV)o->op_targ+i);
+ if (i < count-1)
+ PerlIO_printf(Perl_debug_log, ",");
+ }
+ PerlIO_printf(Perl_debug_log, ")");
+ }
break;
+ }
+
default:
break;
}
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 796841a7e5..8bebdfc0cb 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -596,7 +596,7 @@ our %priv; # used to display each opcode's BASEOP.op_private values
$priv{$_}{128} = "LVINTRO"
for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
"rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
- "padav", "padhv", "enteriter", "entersub");
+ "padav", "padhv", "enteriter", "entersub", "padrange", "pushmark");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
$priv{"aassign"}{32} = "STATE";
@@ -787,30 +787,39 @@ sub concise_op {
$h{targarglife} = $h{targarg} = "$h{targ} $refs";
}
} elsif ($h{targ}) {
- my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
- if (defined $padname and class($padname) ne "SPECIAL") {
- $h{targarg} = $padname->PVX;
- if ($padname->FLAGS & SVf_FAKE) {
- # These changes relate to the jumbo closure fix.
- # See changes 19939 and 20005
- my $fake = '';
- $fake .= 'a'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
- $fake .= 'm'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
- $fake .= ':' . $padname->PARENT_PAD_INDEX
- if $curcv->CvFLAGS & CVf_ANON;
- $h{targarglife} = "$h{targarg}:FAKE:$fake";
- }
- else {
- my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
- my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $h{targarglife} = "$h{targarg}:$intro,$finish";
+ my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+ my (@targarg, @targarglife);
+ for my $i (0..$count-1) {
+ my ($targarg, $targarglife);
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
+ if (defined $padname and class($padname) ne "SPECIAL") {
+ $targarg = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $fake = '';
+ $fake .= 'a'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+ $fake .= 'm'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+ $fake .= ':' . $padname->PARENT_PAD_INDEX
+ if $curcv->CvFLAGS & CVf_ANON;
+ $targarglife = "$targarg:FAKE:$fake";
+ }
+ else {
+ my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
+ my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $targarglife = "$targarg:$intro,$finish";
+ }
+ } else {
+ $targarglife = $targarg = "t" . ($h{targ}+$i);
}
- } else {
- $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ push @targarg, $targarg;
+ push @targarglife, $targarglife;
}
+ $h{targarg} = join '; ', @targarg;
+ $h{targarglife} = join '; ', @targarglife;
}
$h{arg} = "";
$h{svclass} = $h{svaddr} = $h{svval} = "";
diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
index 3a44454857..8beb243f71 100644
--- a/ext/B/B/Xref.pm
+++ b/ext/B/B/Xref.pm
@@ -1,6 +1,6 @@
package B::Xref;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
=head1 NAME
@@ -275,6 +275,15 @@ sub pp_nextstate {
$top = UNKNOWN;
}
+sub pp_padrange {
+ my $op = shift;
+ my $count = $op->private & 127;
+ for my $i (0..$count-1) {
+ $top = $pad[$op->targ + $i];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+ }
+}
+
sub pp_padsv {
my $op = shift;
$top = $pad[$op->targ];
diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t
index b602e436a5..a78b31ee94 100644
--- a/ext/B/t/optree_sort.t
+++ b/ext/B/t/optree_sort.t
@@ -196,10 +196,9 @@ checkOptree ( name => 'sub {my @a; @a = sort @a}',
5 <0> pushmark s
6 <0> padav[@a:-437,-436] l
7 <@> sort lK
-8 <0> pushmark s
-9 <0> padav[@a:-437,-436] lRM*
-a <2> aassign[t2] KS/COMMON
-b <1> leavesub[1 ref] K/REFC,1
+8 <0> padrange[@a:-437,-436] l/1
+9 <2> aassign[t2] KS/COMMON
+a <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 427 optree_sort.t:172) v:>,<,%
# 2 <0> padav[@a:427,428] vM/LVINTRO
@@ -208,10 +207,9 @@ EOT_EOT
# 5 <0> pushmark s
# 6 <0> padav[@a:427,428] l
# 7 <@> sort lK
-# 8 <0> pushmark s
-# 9 <0> padav[@a:427,428] lRM*
-# a <2> aassign[t2] KS/COMMON
-# b <1> leavesub[1 ref] K/REFC,1
+# 8 <0> padrange[@a:427,428] l/1
+# 9 <2> aassign[t2] KS/COMMON
+# a <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'my @a; @a = sort @a',
@@ -224,20 +222,18 @@ checkOptree ( name => 'my @a; @a = sort @a',
3 <0> padav[@a:1,2] vM/LVINTRO
4 <;> nextstate(main 2 -e:1) v:>,<,%,{
5 <0> pushmark s
-6 <0> pushmark s
-7 <0> padav[@a:1,2] lRM*
-8 <@> sort lK/INPLACE
-9 <@> leave[1 ref] vKP/REFC
+6 <0> padrange[@a:1,2] l/1
+7 <@> sort lK/INPLACE
+8 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> padav[@a:1,2] vM/LVINTRO
# 4 <;> nextstate(main 2 -e:1) v:>,<,%,{
# 5 <0> pushmark s
-# 6 <0> pushmark s
-# 7 <0> padav[@a:1,2] lRM*
-# 8 <@> sort lK/INPLACE
-# 9 <@> leave[1 ref] vKP/REFC
+# 6 <0> padrange[@a:1,2] l/1
+# 7 <@> sort lK/INPLACE
+# 8 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}',
@@ -250,29 +246,25 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}',
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v:>,<,%
4 <0> pushmark s
-5 <0> pushmark s
-6 <0> padav[@a:-437,-436] lRM*
-7 <@> sort lK/INPLACE
-8 <;> nextstate(main -436 optree.t:325) v:>,<,%,{
-9 <0> pushmark s
-a <0> padav[@a:-437,-436] lRM
-b <$> const[IV 1] s
-c <@> push[t3] sK/2
-d <1> leavesub[1 ref] K/REFC,1
+5 <0> padrange[@a:-437,-436] l/1
+6 <@> sort lK/INPLACE
+7 <;> nextstate(main -436 optree.t:325) v:>,<,%,{
+8 <0> padrange[@a:-437,-436] l/1
+9 <$> const[IV 1] s
+a <@> push[t3] sK/2
+b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 429 optree_sort.t:219) v:>,<,%
# 2 <0> padav[@a:429,430] vM/LVINTRO
# 3 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%
# 4 <0> pushmark s
-# 5 <0> pushmark s
-# 6 <0> padav[@a:429,430] lRM*
-# 7 <@> sort lK/INPLACE
-# 8 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{
-# 9 <0> pushmark s
-# a <0> padav[@a:429,430] lRM
-# b <$> const(IV 1) s
-# c <@> push[t3] sK/2
-# d <1> leavesub[1 ref] K/REFC,1
+# 5 <0> padrange[@a:429,430] l/1
+# 6 <@> sort lK/INPLACE
+# 7 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{
+# 8 <0> padrange[@a:429,430] l/1
+# 9 <$> const(IV 1) s
+# a <@> push[t3] sK/2
+# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; 1}',
@@ -285,21 +277,19 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; 1}',
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v:>,<,%
4 <0> pushmark s
-5 <0> pushmark s
-6 <0> padav[@a:-437,-436] lRM*
-7 <@> sort lK/INPLACE
-8 <;> nextstate(main -436 optree.t:346) v:>,<,%,{
-9 <$> const[IV 1] s
-a <1> leavesub[1 ref] K/REFC,1
+5 <0> padrange[@a:-437,-436] l/1
+6 <@> sort lK/INPLACE
+7 <;> nextstate(main -436 optree.t:346) v:>,<,%,{
+8 <$> const[IV 1] s
+9 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 431 optree_sort.t:250) v:>,<,%
# 2 <0> padav[@a:431,432] vM/LVINTRO
# 3 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%
# 4 <0> pushmark s
-# 5 <0> pushmark s
-# 6 <0> padav[@a:431,432] lRM*
-# 7 <@> sort lK/INPLACE
-# 8 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{
-# 9 <$> const(IV 1) s
-# a <1> leavesub[1 ref] K/REFC,1
+# 5 <0> padrange[@a:431,432] l/1
+# 6 <@> sort lK/INPLACE
+# 7 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{
+# 8 <$> const(IV 1) s
+# 9 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t
index e0a95b7652..4c4632508d 100644
--- a/ext/B/t/optree_varinit.t
+++ b/ext/B/t/optree_varinit.t
@@ -390,18 +390,14 @@ checkOptree ( name => 'my ($a,$b)=()',
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> pushmark sRM*/128
-# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
-# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
-# 7 <2> aassign[t3] vKS
-# 8 <@> leave[1 ref] vKP/REFC
+# 4 <0> padrange[$a:1,2; $b:1,2] lRM*/LVINTRO,2
+# 5 <2> aassign[t3] vKS
+# 6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
# 3 <0> pushmark s
-# 4 <0> pushmark sRM*/128
-# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
-# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
-# 7 <2> aassign[t3] vKS
-# 8 <@> leave[1 ref] vKP/REFC
+# 4 <0> padrange[$a:1,2; $b:1,2] lRM*/LVINTRO,2
+# 5 <2> aassign[t3] vKS
+# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 06a66f6340..f71e700773 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -6,7 +6,7 @@ use strict;
our($VERSION, @ISA, @EXPORT_OK);
-$VERSION = "1.24";
+$VERSION = "1.25";
use Carp;
use Exporter ();
@@ -397,7 +397,7 @@ These are a hotchpotch of opcodes still waiting to be considered
gvsv gv gelem
- padsv padav padhv padcv padany introcv clonecv
+ padsv padav padhv padcv padany padrange introcv clonecv
once
diff --git a/op.c b/op.c
index e89f0a22fa..bf1a4c69c6 100644
--- a/op.c
+++ b/op.c
@@ -1892,6 +1892,7 @@ S_finalize_op(pTHX_ OP* o)
}
break;
}
+
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
@@ -10913,6 +10914,143 @@ Perl_rpeep(pTHX_ register OP *o)
}
break;
+ case OP_PUSHMARK:
+
+ /* Convert a series of PAD ops for my vars plus support into a
+ * single padrange op. Basically
+ *
+ * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
+ *
+ * becomes, depending on circumstances, one of
+ *
+ * padrange ----------------------------------> (list) -> rest
+ * padrange --------------------------------------------> rest
+ *
+ * where all the pad indexes are sequential and of the same type
+ * (INTRO or not).
+ * We convert the pushmark into a padrange op, then skip
+ * any other pad ops, and possibly some trailing ops.
+ * Note that we don't null() the skipped ops, to make it
+ * easier for Deparse to undo this optimisation (and none of
+ * the skipped ops are holding any resourses). It also makes
+ * it easier for find_uninit_var(), as it can just ignore
+ * padrange, and examine the original pad ops.
+ */
+ {
+ OP *p;
+ OP *followop = NULL; /* the op that will follow the padrange op */
+ U8 count = 0;
+ U8 intro = 0;
+ PADOFFSET base = 0; /* init only to stop compiler whining */
+ U8 gimme = 0; /* init only to stop compiler whining */
+
+ /* To allow Deparse to pessimise this, it needs to be able
+ * to restore the pushmark's original op_next, which it
+ * will assume to be the same as op_sibling. */
+ if (o->op_next != o->op_sibling)
+ break;
+
+ /* scan for PAD ops */
+
+ for (p = o->op_next; p; p = p->op_next) {
+ if (p->op_type == OP_NULL)
+ continue;
+
+ if (( p->op_type != OP_PADSV
+ && p->op_type != OP_PADAV
+ && p->op_type != OP_PADHV
+ )
+ /* any private flag other than INTRO? e.g. STATE */
+ || (p->op_private & ~OPpLVAL_INTRO)
+ )
+ break;
+
+ /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ * instead */
+ if ( p->op_type == OP_PADAV
+ && p->op_next
+ && p->op_next->op_type == OP_CONST
+ && p->op_next->op_next
+ && p->op_next->op_next->op_type == OP_AELEM
+ )
+ break;
+
+ /* for 1st padop, note what type it is and the range
+ * start; for the others, check that it's the same type
+ * and that the targs are contiguous */
+ if (count == 0) {
+ intro = (p->op_private & OPpLVAL_INTRO);
+ base = p->op_targ;
+ gimme = (p->op_flags & OPf_WANT);
+ }
+ else {
+ if ((p->op_private & OPpLVAL_INTRO) != intro)
+ break;
+ /* we expect targs to be contiguous in my($a,$b,$c)
+ * but not in ($a, $x, $z). In the latter case, stop
+ * on the first non-contiguous padop */
+ if (!intro && p->op_targ != base + count)
+ break;
+ assert(p->op_targ == base + count);
+ /* all the padops should be in the same context */
+ if (gimme != (p->op_flags & OPf_WANT))
+ break;
+ }
+
+ /* for AV, HV, only when we're not flattening */
+ if ( p->op_type != OP_PADSV
+ && gimme != OPf_WANT_VOID
+ && !(p->op_flags & OPf_REF)
+ )
+ break;
+
+ if (count >= OPpPADRANGE_COUNTMASK)
+ break;
+
+ /* Success! We've got another valid pad op to optimise away */
+ count++;
+ followop = p->op_next;
+ }
+
+ if (count < 1)
+ break;
+
+ /* op_padrange in specifically compile-time void context
+ * skips pushing a mark and lexicals; in all other contexts
+ * (including unknown till runtime) it pushes a mark and the
+ * lexicals. We must be very careful then, that the ops we
+ * optimise away would have exactly the same effect as the
+ * padrange.
+ * In particular in void context, we can only optimise to
+ * a padrange if see see the complete sequence
+ * pushmark, pad*v, ...., list, nextstate
+ * which has the net effect of of leaving the stack empty
+ * (for now we leave the nextstate in the execution chain, for
+ * its other side-effects).
+ */
+ assert(followop);
+ if (gimme == OPf_WANT_VOID) {
+ if (followop->op_type == OP_LIST
+ && gimme == (followop->op_flags & OPf_WANT)
+ && ( followop->op_next->op_type == OP_NEXTSTATE
+ || followop->op_next->op_type == OP_DBSTATE))
+ followop = followop->op_next; /* skip OP_LIST */
+ else
+ break;
+ }
+
+ /* Convert the pushmark into a padrange */
+ o->op_next = followop;
+ o->op_type = OP_PADRANGE;
+ o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
+ o->op_targ = base;
+ /* bit 7: INTRO; bit 6..0: count */
+ o->op_private = (intro | count);
+ o->op_flags = ((o->op_flags & ~OPf_WANT) | gimme);
+
+ break;
+ }
+
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
diff --git a/op.h b/op.h
index bf933e487c..67f2b338e7 100644
--- a/op.h
+++ b/op.h
@@ -235,6 +235,10 @@ Deprecated. Use C<GIMME_V> instead.
#define OPpPAD_STATE 16 /* is a "state" pad */
/* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
+ /* OP_PADRANGE only */
+ /* bit 7 is OPpLVAL_INTRO */
+#define OPpPADRANGE_COUNTMASK 127 /* bits 6..0 hold target range */
+
/* OP_RV2GV only */
#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */
/* (Therefore will return whatever is currently in the symbol table, not
diff --git a/opcode.h b/opcode.h
index 02769ba347..540dc0ba97 100644
--- a/opcode.h
+++ b/opcode.h
@@ -524,6 +524,7 @@ EXTCONST char* const PL_op_name[] = {
"padcv",
"introcv",
"clonecv",
+ "padrange",
"freed",
};
#endif
@@ -908,6 +909,7 @@ EXTCONST char* const PL_op_desc[] = {
"private subroutine",
"private subroutine",
"private subroutine",
+ "list of private variables",
"freed op",
};
#endif
@@ -1306,6 +1308,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
Perl_pp_padcv,
Perl_pp_introcv,
Perl_pp_clonecv,
+ Perl_pp_padrange,
}
#endif
#ifdef PERL_PPADDR_INITED
@@ -1700,6 +1703,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
Perl_ck_null, /* padcv */
Perl_ck_null, /* introcv */
Perl_ck_null, /* clonecv */
+ Perl_ck_null, /* padrange */
}
#endif
#ifdef PERL_CHECK_INITED
@@ -2088,6 +2092,7 @@ EXTCONST U32 PL_opargs[] = {
0x00000040, /* padcv */
0x00000040, /* introcv */
0x00000040, /* clonecv */
+ 0x00000040, /* padrange */
};
#endif
diff --git a/opnames.h b/opnames.h
index 4b9bd8cab8..5502ba4d15 100644
--- a/opnames.h
+++ b/opnames.h
@@ -390,10 +390,11 @@ typedef enum opcode {
OP_PADCV = 373,
OP_INTROCV = 374,
OP_CLONECV = 375,
+ OP_PADRANGE = 376,
OP_max
} opcode;
-#define MAXO 376
+#define MAXO 377
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
diff --git a/pp_hot.c b/pp_hot.c
index 212fe5f9e7..e5ea2cc8bc 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -306,6 +306,29 @@ PP(pp_concat)
}
}
+/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
+
+PP(pp_padrange)
+{
+ dVAR; dSP;
+ PADOFFSET base = PL_op->op_targ;
+ int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
+ int i;
+ /* note, this is only skipped for compile-time-known void cxt */
+ if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
+ EXTEND(SP, count);
+ PUSHMARK(SP);
+ for (i = 0; i <count; i++)
+ *++SP = PAD_SV(base+i);
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ for (i = 0; i <count; i++)
+ SAVECLEARSV(PAD_SVl(base+i));
+ }
+ RETURN;
+}
+
+
PP(pp_padsv)
{
dVAR; dSP; dTARGET;
diff --git a/pp_proto.h b/pp_proto.h
index 4eafd78b4a..a4dd46d5cc 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -167,6 +167,7 @@ PERL_CALLCONV OP *Perl_pp_pack(pTHX);
PERL_CALLCONV OP *Perl_pp_padav(pTHX);
PERL_CALLCONV OP *Perl_pp_padcv(pTHX);
PERL_CALLCONV OP *Perl_pp_padhv(pTHX);
+PERL_CALLCONV OP *Perl_pp_padrange(pTHX);
PERL_CALLCONV OP *Perl_pp_padsv(pTHX);
PERL_CALLCONV OP *Perl_pp_pipe_op(pTHX);
PERL_CALLCONV OP *Perl_pp_pos(pTHX);
diff --git a/regcomp.c b/regcomp.c
index 740bc94f5d..e472fc0bbe 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5433,7 +5433,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
if (pRExC_state->num_code_blocks) {
o = cLISTOPx(expr)->op_first;
- assert(o->op_type == OP_PUSHMARK);
+ assert( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ || o->op_type == OP_PADRANGE);
o = o->op_sibling;
}
@@ -5457,6 +5459,17 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
SV *sv, *msv = *svp;
SV *rx;
bool code = 0;
+ /* we make the assumption here that each op in the list of
+ * op_siblings maps to one SV pushed onto the stack,
+ * except for code blocks, with have both an OP_NULL and
+ * and OP_CONST.
+ * This allows us to match up the list of SVs against the
+ * list of OPs to find the next code block.
+ *
+ * Note that PUSHMARK PADSV PADSV ..
+ * is optimised to
+ * PADRANGE NULL NULL ..
+ * so the alignment still works. */
if (o) {
if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
assert(n < pRExC_state->num_code_blocks);
diff --git a/regen/opcodes b/regen/opcodes
index 1ab82de463..9c86d69a32 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -550,3 +550,4 @@ fc fc ck_fun fstu% S?
padcv private subroutine ck_null d0
introcv private subroutine ck_null d0
clonecv private subroutine ck_null d0
+padrange list of private variables ck_null d0
diff --git a/sv.c b/sv.c
index 360de04215..ffc098ac86 100644
--- a/sv.c
+++ b/sv.c
@@ -14041,8 +14041,16 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
case OP_PADAV:
case OP_PADHV:
{
- const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = ( obase->op_type == OP_PADAV
+ || obase->op_type == OP_PADHV
+ || obase->op_type == OP_PADRANGE
+ );
+
+ const bool hash = ( obase->op_type == OP_PADHV
+ || obase->op_type == OP_RV2HV
+ || (obase->op_type == OP_PADRANGE
+ && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+ );
I32 index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
@@ -14248,7 +14256,9 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
case OP_OPEN:
o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
+ if ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ )
o = o->op_sibling;
if (!o->op_sibling) {
@@ -14292,7 +14302,10 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ if ((obase->op_flags & OPf_STACKED)
+ &&
+ ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
o = o->op_sibling->op_sibling;
goto do_op2;
@@ -14420,6 +14433,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
* left that is not skipped, then we *know* it is responsible for
* the uninitialized value. If there is more than one op left, we
* have to look for an exact match in the while() loop below.
+ * Note that we skip padrange, because the individual pad ops that
+ * it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
@@ -14428,6 +14443,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (type == OP_PADRANGE)
)
continue;
}
diff --git a/t/op/sort.t b/t/op/sort.t
index 0371f4f7a8..0da7a27a1a 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -6,7 +6,7 @@ BEGIN {
require 'test.pl';
}
use warnings;
-plan( tests => 171 );
+plan( tests => 172 );
# these shouldn't hang
{
@@ -961,3 +961,20 @@ is @x, 0, 'sort; returns empty list';
eval '{@x = sort} 1';
is $@, '', '{sort} does not die';
is @x, 0, '{sort} returns empty list';
+
+# this happened while the padrange op was being added. Sort blocks
+# are executed in void context, and the padrange op was skipping pushing
+# the item in void cx. The net result was that the return value was
+# whatever was on the stack last.
+
+{
+ my @a = sort {
+ my $r = $a <=> $b;
+ if ($r) {
+ undef; # this got returned by mistake
+ return $r
+ }
+ return 0;
+ } 5,1,3,6,0;
+ is "@a", "0 1 3 5 6", "padrange and void context";
+}
View Lorry Controller Status