use reject instead of [ ... not ] filter.

[factor.git] / basis / compiler / cfg / linearization / linearization.factor

diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index c44b29d27122dcbfb7df9075a9faa7e42d176973..998bcdfd09dcea21226e7a3b4cc9ca46b4c464ac 100644 (file)
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,10 +1,9 @@
 ! 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
 
@@ -13,19 +12,15 @@ 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 {
@@ -43,49 +38,41 @@ SYMBOLS: work-list loop-heads visited ;
         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? [ drop ] [
-        [ , ]
-        [ visited get adjoin ]
-        [ sorted-successors [ process-successor ] each ]
-        tri
-    ] 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
 
 : block-number ( bb -- n ) numbers get at ;
 
 : number-blocks ( bbs -- )
-    [ 2array ] map-index >hashtable numbers set ;
+    H{ } zip-index-as numbers set ;
+
+: cfg>insns ( cfg -- insns )
+    linearization-order [ instructions>> ] map concat ;