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 9c3a0068bc94fd7a0f36f87fcae43344ce3423dc..998bcdfd09dcea21226e7a3b4cc9ca46b4c464ac 100644 (file)
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,74 +1,78 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals layouts hashtables
-cpu.architecture generalizations
-compiler.cfg
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
+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
-
-SYMBOL: numbers
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
 
-: block-number ( bb -- n ) numbers get at ;
+<PRIVATE
 
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
+SYMBOLS: loop-heads visited ;
 
-GENERIC: linearize-insn ( basic-block insn -- )
+: visited? ( bb -- ? ) visited get in? ;
 
-M: insn linearize-insn , drop ;
+: predecessors-ready? ( bb -- ? )
+    [ predecessors>> ] keep '[
+        _ 2dup back-edge?
+        [ 2drop t ] [ drop visited? ] if
+    ] all? ;
 
-: useless-branch? ( basic-block successor -- ? )
-    ! If our successor immediately follows us in linearization
-    ! order then we don't need to branch.
-    [ block-number ] bi@ 1 - = ; inline
+: (find-alternate-loop-head) ( bb -- bb' )
+    dup {
+        [ predecessor visited? not ]
+        [ predecessors>> length 1 = ]
+        [ predecessor successors>> length 1 = ]
+        [ [ number>> ] [ predecessor number>> ] bi > ]
+    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
 
-: emit-branch ( bb successor -- )
-    2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
+: find-back-edge ( bb -- pred )
+    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
 
-M: ##branch linearize-insn
-    drop dup successors>> first emit-branch ;
+: find-alternate-loop-head ( bb -- bb' )
+    dup find-back-edge dup visited? [ drop ] [
+        nip (find-alternate-loop-head)
+    ] if ;
 
-GENERIC: negate-insn-cc ( insn -- )
+: sorted-successors ( bb -- seq )
+    successors>> <reversed> [ loop-nesting-at ] sort-with ;
 
-M: conditional-branch-insn negate-insn-cc
-    [ negate-cc ] change-cc drop ;
+: 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 ;
 
-M: ##test-vector-branch negate-insn-cc
-    [ negate-vcc ] change-vcc drop ;
+: (linearization-order) ( cfg -- bbs )
+    HS{ } clone visited set
+    entry>> <dlist> [ push-back ] keep
+    [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
 
-M:: conditional-branch-insn linearize-insn ( bb insn -- )
-    bb successors>> first2 :> ( first second )
-    bb second useless-branch?
-    [ bb second first ]
-    [ bb first second insn negate-insn-cc ] if
-    block-number insn _conditional-branch
-    emit-branch ;
+PRIVATE>
 
-M: ##dispatch linearize-insn
-    , successors>> [ block-number _dispatch-label ] each ;
+: linearization-order ( cfg -- bbs )
+    {
+        [ needs-post-order ]
+        [ needs-loops ]
+        [ needs-predecessors ]
+        [
+            dup linear-order>> [ ] [
+                dup (linearization-order)
+                >>linear-order linear-order>>
+            ] ?if
+        ]
+    } cleave ;
 
-: linearize-basic-block ( bb -- )
-    [ block-number _label ]
-    [ dup instructions>> [ linearize-insn ] with each ]
-    bi ;
+SYMBOL: numbers
 
-: linearize-basic-blocks ( cfg -- insns )
-    [
-        [
-            linearization-order
-            [ number-blocks ]
-            [ [ linearize-basic-block ] each ] bi
-        ] [ spill-area-size>> _spill-area-size ] bi
-    ] { } make ;
+: block-number ( bb -- n ) numbers get at ;
 
-PRIVATE>
+: number-blocks ( bbs -- )
+    H{ } zip-index-as numbers set ;
 
-: flatten-cfg ( cfg -- mr )
-    [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
-    <mr> ;
+: cfg>insns ( cfg -- insns )
+    linearization-order [ instructions>> ] map concat ;