compiler.cfg.linearization: can't use slurp/replenish-queue here because

the successors need to be pushed to the back of the deque
db4
Björn Lindqvist 2015-04-28 02:54:48 +02:00 committed by John Benediktsson
parent 24ca0e3160
commit d0c1493f36
2 changed files with 30 additions and 10 deletions

View File

@ -1,6 +1,6 @@
USING: accessors compiler.cfg.debugger compiler.cfg compiler.cfg.linearization USING: accessors assocs compiler.cfg.debugger compiler.cfg
compiler.cfg.linearization.private compiler.cfg.utilities dlists kernel make compiler.cfg.linearization compiler.cfg.linearization.private
namespaces sequences tools.test ; compiler.cfg.utilities dlists kernel make namespaces sequences tools.test ;
IN: compiler.cfg.linearization.tests IN: compiler.cfg.linearization.tests
! linearization-order ! linearization-order
@ -17,6 +17,26 @@ V{ } 2 test-bb
0 get block>cfg linearization-order [ number>> ] map 0 get block>cfg linearization-order [ number>> ] map
] unit-test ] unit-test
! (linearization-order)
{ { 10 20 30 } } [
V{ } 10 insns>block
[ V{ } 20 insns>block connect-bbs ] keep
[ V{ } 30 insns>block connect-bbs ] keep
block>cfg (linearization-order) [ number>> ] map
] unit-test
{ { 0 1 2 3 4 5 } } [
6 iota [ V{ } clone over insns>block ] { } map>assoc dup
{
{ 0 1 } { 0 2 } { 0 5 }
{ 2 3 }
{ 3 4 }
{ 4 2 }
} make-edges
0 of block>cfg (linearization-order)
[ number>> ] map
] unit-test
! process-block ! process-block
{ { } V{ 10 } } [ { { } V{ 10 } } [
HS{ } clone visited set HS{ } clone visited set

View File

@ -16,6 +16,12 @@ SYMBOLS: loop-heads visited ;
: visited? ( bb -- ? ) visited get in? ; : visited? ( bb -- ? ) visited get in? ;
: predecessors-ready? ( bb -- ? )
[ predecessors>> ] keep '[
_ 2dup back-edge?
[ 2drop t ] [ drop visited? ] if
] all? ;
: (find-alternate-loop-head) ( bb -- bb' ) : (find-alternate-loop-head) ( bb -- bb' )
dup { dup {
[ predecessor visited? not ] [ predecessor visited? not ]
@ -32,12 +38,6 @@ SYMBOLS: loop-heads visited ;
nip (find-alternate-loop-head) nip (find-alternate-loop-head)
] if ; ] if ;
: predecessors-ready? ( bb -- ? )
[ predecessors>> ] keep '[
_ 2dup back-edge?
[ 2drop t ] [ drop visited? ] if
] all? ;
: sorted-successors ( bb -- seq ) : sorted-successors ( bb -- seq )
successors>> <reversed> [ loop-nesting-at ] sort-with ; successors>> <reversed> [ loop-nesting-at ] sort-with ;
@ -50,7 +50,7 @@ SYMBOLS: loop-heads visited ;
: (linearization-order) ( cfg -- bbs ) : (linearization-order) ( cfg -- bbs )
HS{ } clone visited set HS{ } clone visited set
entry>> <dlist> [ push-back ] keep entry>> <dlist> [ push-back ] keep
[ [ process-block ] slurp/replenish-deque ] { } make ; [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
PRIVATE> PRIVATE>