From eae48c8938e50ebb341a72c2886c5ae8587092a5 Mon Sep 17 00:00:00 2001 From: Zefram Date: Tue, 19 Oct 2010 21:16:11 +0100 Subject: [PATCH] refactor and regularise label/statement grammar Refactoring of the grammar around statements. New production encompasses a statement without label. It includes all statement types, including declarations, with no unnecessary intermediate non-terminals. It generates an op tree for the statement's content, with no leading state op. The production has just one rule, consisting of optional label followed by . It puts a state op on the front of the statement's content ops. To support the regular statement op structure, the op sequence for for(;;) loops no longer has a second state op between the initialisation and the loop. Instead, the unstack op type is slightly adapted to achieve the stack clearing without a state op. The newFOROP() constructor function no longer generates a state op, that now being the job of the production. Consequently it no longer takes a parameter stating what label is to go in the state op. This brings it in line with the other op constructors. --- dist/B-Deparse/Deparse.pm | 20 +- embed.fnc | 2 +- embed.h | 2 +- ext/B/t/f_map.t | 4 +- ext/B/t/optree_samples.t | 10 +- op.c | 12 +- perly.act | 1260 ++++++++++++++++++++---------------------- perly.tab | 1345 ++++++++++++++++++++++----------------------- perly.y | 566 ++++++++----------- pp_ctl.c | 8 + pp_hot.c | 7 +- proto.h | 4 +- t/run/switchd.t | 4 +- 13 files changed, 1543 insertions(+), 1701 deletions(-) diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index 7ea5437..9bf6606 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -23,7 +23,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED), ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'), ($] < 5.011 ? 'CVf_LOCKED' : ()); -$VERSION = 0.99; +$VERSION = 1.00; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -958,14 +958,19 @@ sub is_for_loop { my $op = shift; # This OP might be almost anything, though it won't be a # nextstate. (It's the initialization, so in the canonical case it - # will be an sassign.) The sibling is a lineseq whose first child - # is a nextstate and whose second is a leaveloop. + # will be an sassign.) The sibling is (old style) a lineseq whose + # first child is a nextstate and whose second is a leaveloop, or + # (new style) an unstack whose sibling is a leaveloop. my $lseq = $op->sibling; - if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") { + return 0 unless !is_state($op) and !null($lseq); + if ($lseq->name eq "lineseq") { if ($lseq->first && !null($lseq->first) && is_state($lseq->first) && (my $sib = $lseq->first->sibling)) { return (!null($sib) && $sib->name eq "leaveloop"); } + } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) { + my $sib = $lseq->sibling; + return $sib && !null($sib) && $sib->name eq "leaveloop"; } return 0; } @@ -1215,7 +1220,8 @@ sub walk_lineseq { } } if (is_for_loop($kids[$i])) { - $callback->($expr . $self->for_loop($kids[$i], 0), $i++); + $callback->($expr . $self->for_loop($kids[$i], 0), + $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); next; } $expr .= $self->deparse($kids[$i], (@kids != 1)/2); @@ -2757,7 +2763,9 @@ sub for_loop { my $self = shift; my($op, $cx) = @_; my $init = $self->deparse($op, 1); - return $self->loop_common($op->sibling->first->sibling, $cx, $init); + my $s = $op->sibling; + my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling; + return $self->loop_common($ll, $cx, $init); } sub pp_leavetry { diff --git a/embed.fnc b/embed.fnc index 5fd1227..9f992c1 100644 --- a/embed.fnc +++ b/embed.fnc @@ -780,7 +780,7 @@ Ap |OP* |newFORM |I32 floor|NULLOK OP* o|NULLOK OP* block #else Ap |void |newFORM |I32 floor|NULLOK OP* o|NULLOK OP* block #endif -Apda |OP* |newFOROP |I32 flags|NULLOK char* label|line_t forline \ +Apda |OP* |newFOROP |I32 flags|line_t forline \ |NULLOK OP* sv|NN OP* expr|NULLOK OP* block|NULLOK OP* cont Apda |OP* |newGIVENOP |NN OP* cond|NN OP* block|PADOFFSET defsv_off Apda |OP* |newLOGOP |I32 optype|I32 flags|NN OP *first|NN OP *other diff --git a/embed.h b/embed.h index e14a0af..a7093f6 100644 --- a/embed.h +++ b/embed.h @@ -311,7 +311,7 @@ #define newCONDOP(a,b,c,d) Perl_newCONDOP(aTHX_ a,b,c,d) #define newCONSTSUB(a,b,c) Perl_newCONSTSUB(aTHX_ a,b,c) #define newCVREF(a,b) Perl_newCVREF(aTHX_ a,b) -#define newFOROP(a,b,c,d,e,f,g) Perl_newFOROP(aTHX_ a,b,c,d,e,f,g) +#define newFOROP(a,b,c,d,e,f) Perl_newFOROP(aTHX_ a,b,c,d,e,f) #define newGIVENOP(a,b,c) Perl_newGIVENOP(aTHX_ a,b,c) #define newGVOP(a,b,c) Perl_newGVOP(aTHX_ a,b,c) #define newGVREF(a,b) Perl_newGVREF(aTHX_ a,b) diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 11877ef..e56afdf 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -185,7 +185,7 @@ checkOptree(note => q{}, # p <2> sassign vKS/2 # q <0> unstack s # goto r -# t <2> leaveloop K/2 +# t <2> leaveloop KP/2 # u <2> leaveloop K/2 # v <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -218,7 +218,7 @@ EOT_EOT # p <2> sassign vKS/2 # q <0> unstack s # goto r -# t <2> leaveloop K/2 +# t <2> leaveloop KP/2 # u <2> leaveloop K/2 # v <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 2a78972..e61c970 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -281,7 +281,6 @@ checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', # g <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->g # 1 <;> nextstate(main 445 optree.t:167) v:>,<,% ->2 -# - <0> null v ->- # f <2> leaveloop K/2 ->g # 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d # - <0> ex-pushmark s ->2 @@ -307,7 +306,6 @@ EOT_EOT # g <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->g # 1 <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2 -# - <0> null v ->- # f <2> leaveloop K/2 ->g # 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d # - <0> ex-pushmark s ->2 @@ -337,7 +335,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <0> enter -# 2 <;> nextstate(main 2 -e:1) v:>,<,% +# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const[IV 1] s # 5 <$> const[IV 10] s @@ -357,7 +355,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', # i <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter -# 2 <;> nextstate(main 2 -e:1) v:>,<,% +# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const(IV 1) s # 5 <$> const(IV 10) s @@ -545,7 +543,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # n <2> sassign vKS/2 # o <0> unstack s # goto p -# r <2> leaveloop K/2 +# r <2> leaveloop KP/2 # s <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 505 (eval 24):1) v @@ -575,7 +573,7 @@ EOT_EOT # n <2> sassign vKS/2 # o <0> unstack s # goto p -# r <2> leaveloop K/2 +# r <2> leaveloop KP/2 # s <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/op.c b/op.c index f616761..c082921 100644 --- a/op.c +++ b/op.c @@ -5429,7 +5429,7 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my) } /* -=for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont +=for apidoc Am|OP *|newFOROP|I32 flags|line_t forline|OP *sv|OP *expr|OP *block|OP *cont Constructs, checks, and returns an op tree expressing a C loop (iteration through a list of values). This is a heavyweight loop, @@ -5447,16 +5447,13 @@ I gives the eight bits of C for the C op and, shifted up eight bits, the eight bits of C for the C op, except that (in both cases) some bits will be set automatically. I is the line number that should be attributed -to the loop's list expression. If I