! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs deques dlists hashtables kernel
-make sorting namespaces sequences combinators
-combinators.short-circuit fry math compiler.cfg.rpo
-compiler.cfg.utilities compiler.cfg.loop-detection
-compiler.cfg.predecessors sets hash-sets ;
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg.loop-detection compiler.cfg.predecessors
+compiler.cfg.rpo compiler.cfg.utilities deques dlists fry kernel
+make math namespaces sequences sets sorting ;
FROM: namespaces => set ;
IN: compiler.cfg.linearization
<PRIVATE
-SYMBOLS: work-list loop-heads visited ;
+SYMBOLS: loop-heads visited ;
: visited? ( bb -- ? ) visited get in? ;
-: add-to-work-list ( bb -- )
- dup visited? [ drop ] [
- work-list get push-back
- ] if ;
-
-: init-linearization-order ( cfg -- )
- <dlist> work-list set
- HS{ } clone visited set
- entry>> add-to-work-list ;
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
: (find-alternate-loop-head) ( bb -- bb' )
dup {
nip (find-alternate-loop-head)
] if ;
-: predecessors-ready? ( bb -- ? )
- [ predecessors>> ] keep '[
- _ 2dup back-edge?
- [ 2drop t ] [ drop visited? ] if
- ] all? ;
-
-: process-successor ( bb -- )
- dup predecessors-ready? [
- dup loop-entry? [ find-alternate-loop-head ] when
- add-to-work-list
- ] [ drop ] if ;
-
: sorted-successors ( bb -- seq )
successors>> <reversed> [ loop-nesting-at ] sort-with ;
-: process-block ( bb -- )
- dup visited get ?adjoin [
- [ , ]
- [ sorted-successors [ process-successor ] each ]
- bi
- ] [ drop ] if ;
+: process-block ( bb -- bbs )
+ dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
+ [ predecessors-ready? ] filter
+ [ dup loop-entry? [ find-alternate-loop-head ] when ] map
+ [ visited? ] reject ;
: (linearization-order) ( cfg -- bbs )
- init-linearization-order
-
- [ work-list get [ process-block ] slurp-deque ] { } make
- ! [ unlikely?>> not ] partition append
- ;
+ HS{ } clone visited set
+ entry>> <dlist> [ push-back ] keep
+ [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
PRIVATE>
: linearization-order ( cfg -- bbs )
- needs-post-order needs-loops needs-predecessors
-
- dup linear-order>> [ ] [
- dup (linearization-order)
- >>linear-order linear-order>>
- ] ?if ;
+ {
+ [ needs-post-order ]
+ [ needs-loops ]
+ [ needs-predecessors ]
+ [
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if
+ ]
+ } cleave ;
SYMBOL: numbers
: number-blocks ( bbs -- )
H{ } zip-index-as numbers set ;
+
+: cfg>insns ( cfg -- insns )
+ linearization-order [ instructions>> ] map concat ;