compiler.cfg.linearization: rotate loops. 2x speedup with empty times loop, 1.5x speedup on benchmark.dawes

basis/compiler/cfg/block-joining/block-joining.factor

@@ -8,9 +8,6 @@ IN: compiler.cfg.block-joining
 ! Joining blocks that are not calls and are connected by a single CFG edge.
 ! Predecessors must be recomputed after this. Also this pass does not
 ! update ##phi nodes and should therefore only run before stack analysis.
-: predecessor ( bb -- pred )
-    predecessors>> first ; inline
-
 : join-block? ( bb -- ? )
     {
         [ kill-block? not ]

basis/compiler/cfg/linearization/linearization.factor

@@ -3,34 +3,30 @@
 USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals cpu.architecture
 compiler.cfg
-compiler.cfg.rpo
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities
+compiler.cfg.linearization.order ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
 : linearize-basic-block ( bb -- )
-    [ number>> _label ]
+    [ block-number _label ]
     [ dup instructions>> [ linearize-insn ] with each ]
     bi ;
 
 M: insn linearize-insn , drop ;
 
 : useless-branch? ( basic-block successor -- ? )
-    #! If our successor immediately follows us in RPO, then we
-    #! don't need to branch.
-    [ number>> ] bi@ 1 - = ; inline
-
-: emit-loop-entry? ( bb successor -- ? )
-    [ back-edge? not ] [ nip loop-entry? ] 2bi and ;
+    ! If our successor immediately follows us in linearization
+    ! order then we don't need to branch.
+    [ block-number ] bi@ 1 - = ; inline
 
 : emit-branch ( bb successor -- )
-    2dup emit-loop-entry? [ _loop-entry ] when
-    2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
+    2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
 
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
@@ -44,7 +40,7 @@ M: ##branch linearize-insn
 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
     [ (binary-conditional) ]
     [ drop dup successors>> second useless-branch? ] 2bi
-    [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
+    [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
 
 : with-regs ( insn quot -- )
     over regs>> [ call ] dip building get last (>>regs) ; inline
@@ -59,7 +55,7 @@ M: ##compare-float-branch linearize-insn
     [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
-    [ dup successors number>> ]
+    [ dup successors block-number ]
     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
 
 M: ##fixnum-add linearize-insn
@@ -74,7 +70,7 @@ M: ##fixnum-mul linearize-insn
 M: ##dispatch linearize-insn
     swap
     [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
-    [ successors>> [ number>> _dispatch-label ] each ]
+    [ successors>> [ block-number _dispatch-label ] each ]
     bi* ;
 
 : (compute-gc-roots) ( n live-values -- n )
@@ -120,7 +116,7 @@ M: ##gc linearize-insn
 
 : linearize-basic-blocks ( cfg -- insns )
     [
-        [ [ linearize-basic-block ] each-basic-block ]
+        [ linearization-order [ linearize-basic-block ] each ]
         [ spill-counts>> _spill-counts ]
         bi
     ] { } make ;

basis/compiler/cfg/linearization/order/order.factor

@@ -0,0 +1,70 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel make
+namespaces sequences combinators combinators.short-circuit
+fry math sets compiler.cfg.utilities ;
+IN: compiler.cfg.linearization.order
+
+! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+
+<PRIVATE
+
+SYMBOLS: work-list loop-heads visited numbers next-number ;
+
+: visited? ( bb -- ? ) visited get key? ;
+
+: add-to-work-list ( bb -- )
+    dup visited get key? [ drop ] [
+        work-list get push-back
+    ] if ;
+
+: (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 ;
+
+: find-back-edge ( bb -- pred )
+    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+    dup find-back-edge dup visited? [ drop ] [
+        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 ;
+
+: assign-number ( bb -- )
+    next-number [ get ] [ inc ] bi swap numbers get set-at ;
+
+: process-block ( bb -- )
+    {
+        [ , ]
+        [ assign-number ]
+        [ visited get conjoin ]
+        [ successors>> <reversed> [ process-successor ] each ]
+    } cleave ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+    <dlist> work-list set
+    H{ } clone visited set
+    H{ } clone numbers set
+    0 next-number set
+    entry>> add-to-work-list
+    [ work-list get [ process-block ] slurp-deque ] { } make ;
+
+: block-number ( bb -- n ) numbers get at ;

basis/compiler/cfg/utilities/utilities.factor

@@ -57,3 +57,7 @@ SYMBOL: visited
 
 : if-has-phis ( bb quot: ( bb -- ) -- )
     [ dup has-phis? ] dip [ drop ] if ; inline
+
+: predecessor ( bb -- pred )
+    predecessors>> first ; inline
+