Front page | perl.perl5.porters |
Postings from January 2001
[PATCH @8269] Continue blocks and B::Deparse
Thread Next
From:
Stephen McCamant
Date:
January 3, 2001 13:31
Subject:
[PATCH @8269] Continue blocks and B::Deparse
Message ID:
14931.37732.62835.279605@soda.csua.berkeley.edu
The following patch is really two different related changes. The first
one enhances the peephole optimizer to bypass null ops that are the
targets of loop control operators and substitution replacements. Null
ops are already bypassed in the normal flow of control and the `other'
branches of tests, so this is mainly a consistency change, though it
could lead to a marginal performance improvement (say if the inner
loop of your program was repeatedly redo()-ing itself). In a related
change, I deleted the OPpLOOP_CONTINUE flag, which was a remnant of a
previous continue-block scope fix that is now gone.
The second change is a rewrite of B::Deparse's handling of continue
blocks; the old version was a terrible hack, and it wouldn't have
worked in all cases with the more direct nextop routing in the op.c
patch. (The new version still looks for the continue block by seeing
where the nextop pointer goes, but it looks for patterns
characteristic of the absence of a continue block, which are more
predictable). As a benefit of this change, B::Deparse can now also
distinguish between for( ; ; ) loops and while loops with continue
blocks, but in case anyone liked seeing the translation, you can still
get the continue blocks if you want with the -x option. The last hunk
is a minor tweak to one of the b.t tests; the absence of a semicolon
it was looking for was an artifact of the old way of handling continue
blocks.
-- Stephen McCamant
--- op.c.orig Tue Jan 2 00:22:04 2001
+++ op.c Wed Jan 3 15:16:30 2001
@@ -3907,7 +3907,6 @@
if (cont) {
next = LINKLIST(cont);
- loopflags |= OPpLOOP_CONTINUE;
}
if (expr) {
OP *unstack = newOP(OP_UNSTACK, 0);
@@ -6702,8 +6701,14 @@
case OP_ENTERLOOP:
o->op_seq = PL_op_seqmax++;
+ while (cLOOP->op_redoop->op_type == OP_NULL)
+ cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
+ while (cLOOP->op_nextop->op_type == OP_NULL)
+ cLOOP->op_nextop = cLOOP->op_nextop->op_next;
peep(cLOOP->op_nextop);
+ while (cLOOP->op_lastop->op_type == OP_NULL)
+ cLOOP->op_lastop = cLOOP->op_lastop->op_next;
peep(cLOOP->op_lastop);
break;
@@ -6711,6 +6716,9 @@
case OP_MATCH:
case OP_SUBST:
o->op_seq = PL_op_seqmax++;
+ while (cPMOP->op_pmreplstart &&
+ cPMOP->op_pmreplstart->op_type == OP_NULL)
+ cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
peep(cPMOP->op_pmreplstart);
break;
--- op.h.orig Sat Dec 30 10:48:28 2000
+++ op.h Wed Jan 3 15:16:10 2001
@@ -139,9 +139,6 @@
/* Private for OP_REPEAT */
#define OPpREPEAT_DOLIST 64 /* List replication. */
-/* Private for OP_LEAVELOOP */
-#define OPpLOOP_CONTINUE 64 /* a continue block is present */
-
/* Private for OP_RV2?V, OP_?ELEM */
#define OPpDEREF (32|64) /* Want ref to something: */
#define OPpDEREF_AV 32 /* Want ref to AV. */
--- ext/B/B/Deparse.pm.orig Mon Dec 11 21:29:50 2000
+++ ext/B/B/Deparse.pm Wed Jan 3 15:04:59 2001
@@ -17,7 +17,7 @@
CVf_METHOD CVf_LOCKED CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.591;
+$VERSION = 0.60;
use strict;
# Changes between 0.50 and 0.51:
@@ -83,6 +83,12 @@
# - added support for Chip's OP_METHOD_NAMED
# - added support for Ilya's OPpTARGET_MY optimization
# - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
# Todo:
# - finish tr/// changes
@@ -93,8 +99,8 @@
# - left/right context
# - recognize `use utf8', `use integer', etc
# - treat top-level block specially for incremental output
-# - interpret in high bit chars in string as utf8 \x{...} (when?)
-# - copy comments (look at real text with $^P?)
+# - interpret high bit chars in string as utf8 \x{...} (when?)
+# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - ',' => '=>' (auto-unquote?)
@@ -108,7 +114,6 @@
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - auto-apply `-u'?
-# - while{} with one-statement continue => for(; XXX; XXX) {}?
# - -uPackage:: descend recursively?
# - here-docs?
# - <DATA>?
@@ -357,6 +362,8 @@
$self->{'unquote'} = 1;
} elsif (substr($arg, 0, 2) eq "-s") {
$self->style_opts(substr $arg, 2);
+ } elsif ($arg =~ /^-x(\d)$/) {
+ $self->{'expand'} = $1;
}
}
return $self;
@@ -393,6 +400,7 @@
my $self = shift;
my($op, $cx) = @_;
# cluck if class($op) eq "NULL";
+# cluck unless $op;
# return $self->$ {\("pp_" . $op->name)}($op, $cx);
my $meth = "pp_" . $op->name;
return $self->$meth($op, $cx);
@@ -684,70 +692,69 @@
return "XXX";
}
-# leave and scope/lineseq should probably share code
-sub pp_leave {
+sub lineseq {
my $self = shift;
- my($op, $cx) = @_;
- my ($kid, $expr);
- my @exprs;
- local($self->{'curstash'}) = $self->{'curstash'};
- $kid = $op->first->sibling; # skip enter
- if (is_miniwhile($kid)) {
- my $top = $kid->first;
- my $name = $top->name;
- if ($name eq "and") {
- $name = "while";
- } elsif ($name eq "or") {
- $name = "until";
- } else { # no conditional -> while 1 or until 0
- return $self->deparse($top->first, 1) . " while 1";
- }
- my $cond = $top->first;
- my $body = $cond->sibling->first; # skip lineseq
- $cond = $self->deparse($cond, 1);
- $body = $self->deparse($body, 1);
- return "$body $name $cond";
- }
- for (; !null($kid); $kid = $kid->sibling) {
+ my(@ops) = @_;
+ my($expr, @exprs);
+ for (my $i = 0; $i < @ops; $i++) {
$expr = "";
- if (is_state $kid) {
- $expr = $self->deparse($kid, 0);
- $kid = $kid->sibling;
- last if null $kid;
+ if (is_state $ops[$i]) {
+ $expr = $self->deparse($ops[$i], 0);
+ $i++;
+ last if $i > $#ops;
+ }
+ if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
+ $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
+ {
+ push @exprs, $expr . $self->for_loop($ops[$i], 0);
+ $i++;
+ next;
}
- $expr .= $self->deparse($kid, 0);
+ $expr .= $self->deparse($ops[$i], 0);
push @exprs, $expr if length $expr;
}
- if ($cx > 0) { # inside an expression
- return "do { " . join(";\n", @exprs) . " }";
- } else {
- return join(";\n", @exprs) . ";";
- }
+ return join(";\n", @exprs);
}
-sub pp_scope {
- my $self = shift;
- my($op, $cx) = @_;
- my ($kid, $expr);
- my @exprs;
- for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
- $expr = "";
- if (is_state $kid) {
- $expr = $self->deparse($kid, 0);
- $kid = $kid->sibling;
- last if null $kid;
+sub scopeop {
+ my($real_block, $self, $op, $cx) = @_;
+ my $kid;
+ my @kids;
+ local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
+ if ($real_block) {
+ $kid = $op->first->sibling; # skip enter
+ if (is_miniwhile($kid)) {
+ my $top = $kid->first;
+ my $name = $top->name;
+ if ($name eq "and") {
+ $name = "while";
+ } elsif ($name eq "or") {
+ $name = "until";
+ } else { # no conditional -> while 1 or until 0
+ return $self->deparse($top->first, 1) . " while 1";
+ }
+ my $cond = $top->first;
+ my $body = $cond->sibling->first; # skip lineseq
+ $cond = $self->deparse($cond, 1);
+ $body = $self->deparse($body, 1);
+ return "$body $name $cond";
}
- $expr .= $self->deparse($kid, 0);
- push @exprs, $expr if length $expr;
+ } else {
+ $kid = $op->first;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @kids, $kid;
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
- return "do { " . join(";\n", @exprs) . " }";
+ return "do { " . $self->lineseq(@kids) . " }";
} else {
- return join(";\n", @exprs) . ";";
+ return $self->lineseq(@kids) . ";";
}
}
-sub pp_lineseq { pp_scope(@_) }
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
# The BEGIN {} is used here because otherwise this code isn't executed
# when you run B::Deparse on itself.
@@ -1385,11 +1392,14 @@
my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
my $left = $op->first;
my $right = $op->first->sibling;
- if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
+ if ($cx == 0 and is_scope($right) and $blockname
+ and $self->{'expand'} < 7)
+ { # if ($a) {$b}
$left = $self->deparse($left, 1);
$right = $self->deparse($right, 0);
return "$blockname ($left) {\n\t$right\n\b}\cK";
- } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
+ } elsif ($cx == 0 and $blockname and not $self->{'parens'}
+ and $self->{'expand'} < 7) { # $b if $a
$right = $self->deparse($right, 1);
$left = $self->deparse($left, 1);
return "$right $blockname $left";
@@ -1680,7 +1690,8 @@
my $false = $true->sibling;
my $cuddle = $self->{'cuddle'};
unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
- (is_scope($false) || is_ifelse_cont($false))) {
+ (is_scope($false) || is_ifelse_cont($false))
+ and $self->{'expand'} < 7) {
$cond = $self->deparse($cond, 8);
$true = $self->deparse($true, 8);
$false = $self->deparse($false, 8);
@@ -1709,20 +1720,24 @@
return $head . join($cuddle, "", @elsifs) . $false;
}
-sub pp_leaveloop {
+sub loop_common {
my $self = shift;
- my($op, $cx) = @_;
+ my($op, $cx, $init) = @_;
my $enter = $op->first;
my $kid = $enter->sibling;
local($self->{'curstash'}) = $self->{'curstash'};
my $head = "";
my $bare = 0;
+ my $body;
+ my $cond = undef;
if ($kid->name eq "lineseq") { # bare or infinite loop
if (is_state $kid->last) { # infinite
$head = "for (;;) "; # shorter than while (1)
+ $cond = "";
} else {
$bare = 1;
}
+ $body = $kid;
} elsif ($enter->name eq "enteriter") { # foreach
my $ary = $enter->first->sibling; # first was pushmark
my $var = $ary->sibling;
@@ -1754,66 +1769,60 @@
$var = "\$" . $self->deparse($var, 1);
}
$head = "foreach $var ($ary) ";
- $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
} elsif ($kid->name eq "null") { # while/until
$kid = $kid->first;
- my $name = {"and" => "while", "or" => "until"}
- ->{$kid->name};
- $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
- $kid = $kid->first->sibling;
+ my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+ $cond = $self->deparse($kid->first, 1);
+ $head = "$name ($cond) ";
+ $body = $kid->first->sibling;
} elsif ($kid->name eq "stub") { # bare and empty
return "{;}"; # {} could be a hashref
}
- # The third-to-last kid is the continue block if the pointer used
- # by `next BLOCK' points to its first OP, which happens to be the
- # the op_next of the head of the _previous_ statement.
- # Unless it's a bare loop, in which case it's last, since there's
- # no unstack or extra nextstate.
- # Except if the previous head isn't null but the first kid is
- # (because it's a nulled out nextstate in a scope), in which
- # case the head's next is advanced past the null but the nextop's
- # isn't, so we need to try nextop->next.
- my $precont;
- my $cont = $kid->first;
- if ($bare) {
- while (!null($cont->sibling)) {
- $precont = $cont;
- $cont = $cont->sibling;
- }
- } else {
- while (!null($cont->sibling->sibling->sibling)) {
- $precont = $cont;
- $cont = $cont->sibling;
+ # If there isn't a continue block, then the next pointer for the loop
+ # will point to the unstack, which is kid's penultimate child, except
+ # in a bare loop, when it will point to the leaveloop. When neither of
+ # these conditions hold, then the third-to-last child in the continue
+ # block (or the last in a bare loop).
+ my $cont_start = $enter->nextop;
+ my $cont;
+ if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
+ if ($bare) {
+ $cont = $body->last;
+ } else {
+ $cont = $body->first;
+ while (!null($cont->sibling->sibling->sibling)) {
+ $cont = $cont->sibling;
+ }
+ }
+ my $state = $body->first;
+ my $cuddle = $self->{'cuddle'};
+ my @states;
+ for (; $$state != $$cont; $state = $state->sibling) {
+ push @states, $state;
+ }
+ $body = $self->lineseq(@states);
+ if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+ $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+ $cont = "\cK";
+ } else {
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
}
- }
- if ($precont and $ {$precont->next} == $ {$enter->nextop}
- || $ {$precont->next} == $ {$enter->nextop->next} )
- {
- my $state = $kid->first;
- my $cuddle = $self->{'cuddle'};
- my($expr, @exprs);
- for (; $$state != $$cont and can $state "sibling"; $state = $state->sibling) {
- $expr = "";
- if (is_state $state) {
- $expr = $self->deparse($state, 0);
- $state = $state->sibling;
- last if null $state;
- }
- $expr .= $self->deparse($state, 0);
- push @exprs, $expr if $expr;
- }
- $kid = join(";\n", @exprs);
- if (class($cont) eq "LISTOP") {
- $cont = $cuddle . "continue {\n\t" .
- $self->deparse($cont, 0) . "\n\b}\cK";
- } else {
- $cont = "\cK";
- }
} else {
$cont = "\cK";
- $kid = $self->deparse($kid, 0);
+ $body = $self->deparse($body, 0);
}
- return $head . "{\n\t" . $kid . "\n\b}" . $cont;
+ return $head . "{\n\t" . $body . "\n\b}" . $cont;
+}
+
+sub pp_leaveloop { loop_common(@_, "") }
+
+sub for_loop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $init = $self->deparse($op, 1);
+ return $self->loop_common($op->sibling, $cx, $init);
}
sub pp_leavetry {
@@ -3006,6 +3015,55 @@
=back
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, for loops will be translated into equivalent
+while loops with a continue block; for instance
+
+ for ($i = 0; $i < 10; ++$i) {
+ print $i;
+ }
+
+turns into
+
+ $i = 0;
+ while ($i < 10) {
+ print $i;
+ } continue {
+ ++$i
+ }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop'd initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 7, if statements will be translated into equivalent
+expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+ print 'hi' if $nice;
+ if ($nice) {
+ print 'hi';
+ }
+ if ($nice) {
+ print 'hi';
+ } else {
+ print 'bye';
+ }
+
+turns into
+
+ $nice and print 'hi';
+ $nice and do { print 'hi' };
+ $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
=back
=head1 USING B::Deparse AS A MODULE
@@ -3052,7 +3110,7 @@
=head1 AUTHOR
-Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
--- t/lib/b.t.orig Thu Dec 28 16:56:18 2000
+++ t/lib/b.t Tue Jan 2 04:08:00 2001
@@ -76,7 +76,7 @@
LINE: while (defined($_ = <ARGV>)) {
chomp $_;
@F = split(/\s+/, $_, 0);
- '???'
+ '???';
}
EOF
Thread Next
-
[PATCH @8269] Continue blocks and B::Deparse
by Stephen McCamant