This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add padrange op
authorDavid Mitchell <davem@iabyn.com>
Mon, 24 Sep 2012 12:50:22 +0000 (13:50 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sat, 10 Nov 2012 13:39:31 +0000 (13:39 +0000)
This single op can, in some circumstances, replace the sequence of a
pushmark followed by one or more padsv/padav/padhv ops, and possibly
a trailing 'list' op, but only where the targs of the pad ops form
a continuous range.

This is generally more efficient, but is particularly so in the case
of void-context my declarations, such as:

    my ($a,@b);

Formerly this would be executed as the following set of ops:

    pushmark  pushes a new mark
    padsv[$a] pushes $a, does a SAVEt_CLEARSV
    padav[@b] pushes all the flattened elements (i.e. none) of @a,
              does a SAVEt_CLEARSV
    list      pops the mark, and pops all stack elements except the last
    nextstate pops the remaining stack element

It's now:

    padrange[$a..@b] does two SAVEt_CLEARSV's
    nextstate        nothing needing doing to the stack

Note that in the case above, this commit changes user-visible behaviour in
pathological cases; in particular, it has always been possible to modify a
lexical var *before* the my is executed, using goto or closure tricks.
So in principle someone could tie an array, then could notice that FETCH
is no longer being called, e.g.

    f();
    my ($s, @a); # this no longer triggers two FETCHES
    sub f {
tie @a, ...;
push @a, 1,2;
    }

But I think we can live with that.

Note also that having a padrange operator will allow us shortly to have
a corresponding SAVEt_CLEARPADRANGE save type, that will replace multiple
individual SAVEt_CLEARSV's.

18 files changed:
dist/B-Deparse/Deparse.pm
dist/B-Deparse/t/deparse.t
dump.c
ext/B/B/Concise.pm
ext/B/B/Xref.pm
ext/B/t/optree_sort.t
ext/B/t/optree_varinit.t
ext/Opcode/Opcode.pm
op.c
op.h
opcode.h
opnames.h
pp_hot.c
pp_proto.h
regcomp.c
regen/opcodes
sv.c
t/op/sort.t

index 07386d5..85b3cb4 100644 (file)
@@ -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';
index d1c6cb0..0b04467 100644 (file)
@@ -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 cdc3118..c74c003 100644 (file)
--- 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;
     }
index 796841a..8bebdfc 100644 (file)
@@ -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} = "";
index 3a44454..8beb243 100644 (file)
@@ -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];
index b602e43..a78b31e 100644 (file)
@@ -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
index e0a95b7..4c46325 100644 (file)
@@ -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
index 06a66f6..f71e700 100644 (file)
@@ -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 e89f0a2..bf1a4c6 100644 (file)
--- 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 bf933e4..67f2b33 100644 (file)
--- 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
index 02769ba..540dc0b 100644 (file)
--- 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
 
index 4b9bd8c..5502ba4 100644 (file)
--- 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
index 212fe5f..e5ea2cc 100644 (file)
--- 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;
index 4eafd78..a4dd46d 100644 (file)
@@ -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);
index 740bc94..e472fc0 100644 (file)
--- 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);
index 1ab82de..9c86d69 100644 (file)
@@ -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 360de04..ffc098a 100644 (file)
--- 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;
            }
index 0371f4f..0da7a27 100644 (file)
@@ -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";
+}