compiler.cfg.branch-splitting: split blocks with successors

basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor

@@ -0,0 +1,85 @@
+USING: accessors assocs compiler.cfg
+compiler.cfg.branch-splitting compiler.cfg.debugger
+compiler.cfg.predecessors compiler.cfg.rpo fry kernel
+tools.test namespaces sequences vectors ;
+IN: compiler.cfg.branch-splitting.tests
+
+: get-predecessors ( cfg -- assoc )
+    H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
+
+: check-predecessors ( cfg -- )
+    [ get-predecessors ]
+    [ compute-predecessors drop ]
+    [ get-predecessors ] tri assert= ;
+
+: check-branch-splitting ( cfg -- )
+    compute-predecessors
+    split-branches
+    check-predecessors ;
+
+: test-branch-splitting ( -- )
+    cfg new 0 get >>entry check-branch-splitting ;
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+test-diamond
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+V{ } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 3 get 4 get V{ } 2sequence >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 4 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -1,37 +1,79 @@
 ! Copyright (C) 2009 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit kernel math sequences
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
+USING: accessors combinators.short-circuit kernel math math.order
+sequences assocs namespaces vectors fry arrays splitting
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
-! Predecessors must be recomputed after this
+: clone-renamings ( insns -- assoc )
+    [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
 
-: split-branch-for ( bb predecessor -- )
-    [
+: clone-instructions ( insns -- insns' )
+    dup clone-renamings renamings [
         [
-            <basic-block>
-                swap
-                [ instructions>> [ clone ] map >>instructions ]
-                [ successors>> clone >>successors ]
-                bi
-        ] keep
-    ] dip
-    [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
-    drop ;
+            clone
+            dup rename-insn-defs
+            dup rename-insn-uses
+            dup fresh-insn-temps
+        ] map
+    ] with-variable ;
+
+: clone-basic-block ( bb -- bb' )
+    ! The new block gets the same RPO number as the old one.
+    ! This is just to make 'back-edge?' work.
+    <basic-block>
+        swap
+        [ instructions>> clone-instructions >>instructions ]
+        [ successors>> clone >>successors ]
+        [ number>> >>number ]
+        tri ;
+
+: new-blocks ( bb -- copies )
+    dup predecessors>> [
+        [ clone-basic-block ] dip
+        1vector >>predecessors
+    ] with map ;
+
+: update-predecessor-successor ( pred copy old-bb -- )
+    '[
+        [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
+    ] change-successors drop ;
+
+: update-predecessor-successors ( copies old-bb -- )
+    [ predecessors>> swap ] keep
+    '[ _ update-predecessor-successor ] 2each ;
+
+: update-successor-predecessor ( copies old-bb succ -- )
+    [
+        swap 1array split swap join V{ } like
+    ] change-predecessors drop ;
+
+: update-successor-predecessors ( copies old-bb -- )
+    dup successors>> [
+        update-successor-predecessor
+    ] with with each ;
 
 : split-branch ( bb -- )
-    dup predecessors>> [ split-branch-for ] with each ;
+    [ new-blocks ] keep
+    [ update-predecessor-successors ]
+    [ update-successor-predecessors ]
+    2bi ;
+
+UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
+
+: split-instructions? ( insns -- ? )
+    [ irrelevant? not ] count 5 <= ;
 
 : split-branches? ( bb -- ? )
     {
-        [ successors>> empty? ]
-        [ predecessors>> length 1 > ]
-        [ instructions>> [ defs-vregs ] any? not ]
-        [ instructions>> [ temp-vregs ] any? not ]
+        [ dup successors>> [ back-edge? ] with any? not ]
+        [ predecessors>> length 1 4 between? ]
+        [ instructions>> split-instructions? ]
     } 1&& ;
 
 : split-branches ( cfg -- cfg' )
     dup [
         dup split-branches? [ split-branch ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
+    cfg-changed ;

basis/compiler/cfg/optimizer/optimizer-tests.factor

@@ -2,7 +2,7 @@ USING: accessors arrays compiler.cfg.checker
 compiler.cfg.debugger compiler.cfg.def-use
 compiler.cfg.instructions fry kernel kernel.private math
 math.partial-dispatch math.private sbufs sequences sequences.private sets
-slots.private strings tools.test vectors layouts ;
+slots.private strings strings.private tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
@@ -40,6 +40,10 @@ IN: compiler.cfg.optimizer.tests
             ] [ 2drop f ] if
         ] [ 2drop f ] if
     ]
+    [
+        pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
+        set-string-nth-fast
+    ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each

basis/compiler/cfg/optimizer/optimizer.factor

@@ -29,10 +29,9 @@ SYMBOL: check-optimizer?
     ! The passes that need this document it.
     [
         optimize-tail-calls
-        compute-predecessors
         delete-useless-conditionals
-        split-branches
         compute-predecessors
+        split-branches
         stack-analysis
         compute-liveness
         alias-analysis

basis/compiler/cfg/renaming/renaming.factor

@@ -55,6 +55,12 @@ M: ##string-nth rename-insn-uses
     [ rename-value ] change-index
     drop ;
 
+M: ##set-string-nth-fast rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-obj
+    [ rename-value ] change-index
+    drop ;
+
 M: ##set-slot-imm rename-insn-uses
     dup call-next-method
     [ rename-value ] change-obj

basis/compiler/cfg/stack-analysis/merge/merge-tests.factor

@@ -1,8 +1,8 @@
 IN: compiler.cfg.stack-analysis.merge.tests
 USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
-compiler.cfg.instructions compiler.cfg.stack-analysis.state
-compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture make assocs namespaces
+ compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.utilities compiler.cfg compiler.cfg.registers
+compiler.cfg.debugger cpu.architecture make assocs namespaces
 sequences kernel classes ;
 
 [