Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/compiler/compiler.factor

@@ -94,6 +94,7 @@ nl
 {
     memq? split harvest sift cut cut-slice start index clone
     set-at reverse push-all class number>string string>number
+    like clone-like
 } compile-unoptimized
 
 "." write flush

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

@@ -46,11 +46,11 @@ V{ T{ ##branch } } 4 test-bb
 
 V{ T{ ##branch } } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
 
-2 get 3 get 4 get V{ } 2sequence >>successors drop
+2 { 3 4 } edges
 
 [ ] [ test-branch-splitting ] unit-test
 
@@ -64,11 +64,11 @@ V{ T{ ##branch } } 3 test-bb
 
 V{ T{ ##branch } } 4 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
 
-2 get 4 get 1vector >>successors drop
+2 4 edge
 
 [ ] [ test-branch-splitting ] unit-test
 
@@ -78,8 +78,8 @@ V{ T{ ##branch } } 1 test-bb
 
 V{ T{ ##branch } } 2 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 2 get 1vector >>successors drop
+1 2 edge
 
 [ ] [ test-branch-splitting ] unit-test

basis/compiler/cfg/critical-edges/critical-edges-tests.factor

@@ -0,0 +1,37 @@
+USING: accessors assocs compiler.cfg
+compiler.cfg.critical-edges compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.registers cpu.architecture kernel namespaces
+sequences tools.test compiler.cfg.utilities ;
+IN: compiler.cfg.critical-edges.tests
+
+! Make sure we update phi nodes when splitting critical edges
+
+: test-critical-edges ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    split-critical-edges ;
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
+    T{ ##return }
+} 2 test-bb
+
+0 { 1 2 } edges
+1 2 edge
+
+[ ] [ test-critical-edges ] unit-test
+
+[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
+
+[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test

basis/compiler/cfg/critical-edges/critical-edges.factor

@@ -1,14 +1,22 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences
+USING: kernel math accessors sequences locals assocs fry
 compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
 IN: compiler.cfg.critical-edges
 
 : critical-edge? ( from to -- ? )
     [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
 
+: new-key ( new-key old-key assoc -- )
+    [ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
+
+:: update-phis ( from to bb -- )
+    ! Any phi nodes in 'to' which reference 'from'
+    ! should now reference 'bb'.
+    to [ [ bb from ] dip inputs>> new-key ] each-phi ;
+
 : split-critical-edge ( from to -- )
-    f <simple-block> insert-basic-block ;
+    f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ; 
 
 : split-critical-edges ( cfg -- )
     dup [

basis/compiler/cfg/debugger/debugger.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config
+classes.tuple accessors prettyprint prettyprint.config assocs
 prettyprint.backend prettyprint.custom prettyprint.sections
 parser compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer
+compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.mr compiler.cfg ;
+compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -52,11 +52,23 @@ M: ds-loc pprint* \ D pprint-loc ;
 
 M: rs-loc pprint* \ R pprint-loc ;
 
+: resolve-phis ( bb -- )
+    [
+        [ [ [ get ] dip ] assoc-map ] change-inputs drop
+    ] each-phi ;
+
 : test-bb ( insns n -- )
-    [ <basic-block> swap >>number swap >>instructions ] keep set ;
+    [ <basic-block> swap >>number swap >>instructions dup ] keep set
+    resolve-phis ;
+
+: edge ( from to -- )
+    [ get ] bi@ 1vector >>successors drop ;
+
+: edges ( from tos -- )
+    [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
 
 : test-diamond ( -- )
-    1 get 1vector 0 get (>>successors)
+    0 1 edge
-    2 get 3 get V{ } 2sequence 1 get (>>successors)
+    1 { 2 3 } edges
-    4 get 1vector 2 get (>>successors)
+    2 4 edge
-    4 get 1vector 3 get (>>successors) ;
+    3 4 edge ;

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

@@ -16,11 +16,11 @@ V{ } 3 test-bb
 V{ } 4 test-bb
 V{ } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
 
 [ ] [ test-dominance ] unit-test
 
@@ -46,11 +46,11 @@ V{ } 2 test-bb
 V{ } 3 test-bb
 V{ } 4 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 3 get 1vector >>successors drop
+4 3 edge
 
 [ ] [ test-dominance ] unit-test
 
@@ -64,12 +64,12 @@ V{ } 3 test-bb
 V{ } 4 test-bb
 V{ } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 5 get 1vector >>successors drop
+1 5 edge
-2 get 4 get 3 get V{ } 2sequence >>successors drop
+2 { 4 3 } edges
-5 get 4 get 1vector >>successors drop
+5 4 edge
-4 get 5 get 3 get V{ } 2sequence >>successors drop
+4 { 5 3 } edges
-3 get 4 get 1vector >>successors drop
+3 4 edge
 
 [ ] [ test-dominance ] unit-test
 

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -19,7 +19,7 @@ V{
     T{ ##box-float f V int-regs 0 V int-regs 1 }
 } 1 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
 
 [ ] [ test-gc-checks ] unit-test
 

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1549,9 +1549,9 @@ V{
     T{ ##return }
 } 3 test-bb
 
-1 get 1vector 0 get (>>successors)
+0 1 edge
-2 get 3 get V{ } 2sequence 1 get (>>successors)
+1 { 2 3 } edges
-3 get 1vector 2 get (>>successors)
+2 3 edge
 
 SYMBOL: linear-scan-result
 
@@ -1564,9 +1564,7 @@ SYMBOL: linear-scan-result
         flatten-cfg 1array mr.
     ] with-scope ;
 
-! This test has a critical edge -- do we care about these?
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
 ! Bug in inactive interval handling
 ! [ rot dup [ -rot ] when ]
@@ -1896,11 +1894,11 @@ V{
     T{ ##return }
 } 6 test-bb
 
-0 get 1 get V{ } 1sequence >>successors drop
+0 1 edge
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
-2 get 4 get V{ } 1sequence >>successors drop
+2 4 edge
-3 get 4 get V{ } 1sequence >>successors drop
+3 4 edge
-4 get 5 get 6 get V{ } 2sequence >>successors drop
+4 { 5 6 } edges
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
@@ -1956,14 +1954,14 @@ V{
     T{ ##return }
 } 9 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 7 get V{ } 2sequence >>successors drop
+1 { 2 7 } edges
-7 get 8 get 1vector >>successors drop
+7 8 edge
-8 get 9 get 1vector >>successors drop
+8 9 edge
-2 get 3 get 5 get V{ } 2sequence >>successors drop
+2 { 3 5 } edges
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 9 get 1vector >>successors drop
+4 9 edge
-5 get 6 get 1vector >>successors drop
+5 6 edge
 
 [ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
 
@@ -2139,11 +2137,11 @@ V{
     T{ ##return }
 } 5 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 4 get V{ } 2sequence >>successors drop
+1 { 2 4 } edges
-2 get 3 get 1vector >>successors drop
+2 3 edge
-3 get 5 get 1vector >>successors drop
+3 5 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
 
 [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
 
@@ -2286,12 +2284,12 @@ V{
     T{ ##return }
 } 6 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 5 get V{ } 2sequence >>successors drop
+1 { 2 5 } edges
-2 get 3 get 1vector >>successors drop
+2 3 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 6 get 1vector >>successors drop
+4 6 edge
-5 get 6 get 1vector >>successors drop
+5 6 edge
 
 [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
 
@@ -2419,8 +2417,8 @@ V{
     T{ ##return }
 } 2 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 1vector >>successors drop
+1 2 edge
 
 [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
 
@@ -2444,7 +2442,7 @@ V{
     T{ ##return }
 } 2 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
 [ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
 

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -26,10 +26,9 @@ SYMBOL: spill-temps
     2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
 
 : compute-mappings ( bb to -- mappings )
-    [
+    dup live-in dup assoc-empty? [ 3drop f ] [
-        dup live-in keys
+        [ keys [ resolve-value-data-flow ] with with each ] { } make
-        [ resolve-value-data-flow ] with with each
+    ] if ;
-    ] { } make ;
 
 : memory->register ( from to -- )
     swap [ first2 ] [ first n>> ] bi* _reload ;

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

@@ -29,7 +29,7 @@ V{
     T{ ##return }
 } 3 test-bb
 
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
 
 test-liveness
 
@@ -55,7 +55,7 @@ V{
     T{ ##return }
 } 2 test-bb
 
-1 get 2 get 1vector >>successors drop
+1 2 edge
 
 test-liveness
 

basis/compiler/cfg/liveness/ssa/ssa.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces deques accessors sets sequences assocs fry
 hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.rpo compiler.cfg.liveness ;
+compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities ;
 IN: compiler.cfg.liveness.ssa
 
 ! TODO: merge with compiler.cfg.liveness
@@ -22,11 +22,9 @@ SYMBOL: work-list
     [ live-out ] keep instructions>> transfer-liveness ;
 
 : compute-phi-live-in ( basic-block -- phi-live-in )
-    instructions>> [ ##phi? ] filter [ f ] [
+    H{ } clone [
-        H{ } clone [
+        '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
-            '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
+    ] keep ;
-        ] keep
-    ] if-empty ;
 
 : update-live-in ( basic-block -- changed? )
     [ [ compute-live-in ] keep live-ins get maybe-set-at ]

basis/compiler/cfg/predecessors/predecessors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.predecessors
 
 : update-predecessors ( bb -- )
@@ -14,9 +14,7 @@ IN: compiler.cfg.predecessors
     ] change-inputs drop ;
 
 : update-phis ( bb -- )
-    dup instructions>> [
+    dup [ update-phi ] with each-phi ;
-        dup ##phi? [ update-phi ] [ 2drop ] if
-    ] with each ;
 
 : compute-predecessors ( cfg -- cfg' )
     {

basis/compiler/cfg/ssa/construction/construction-tests.factor

@@ -34,9 +34,9 @@ V{
     T{ ##return }
 } 3 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 3 get 1vector >>successors drop
+2 3 edge
 
 : test-ssa ( -- )
     cfg new 0 get >>entry
@@ -93,12 +93,12 @@ V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
 V{ } 5 test-bb
 V{ } 6 test-bb
 
-0 get 1 get 5 get V{ } 2sequence >>successors drop
+0 { 1 5 } edges
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 6 get 1vector >>successors drop
+4 6 edge
-5 get 6 get 1vector >>successors drop
+5 6 edge
 
 [ ] [ test-ssa ] unit-test
 

basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor

@@ -17,11 +17,11 @@ V{ } 3 test-bb
 V{ } 4 test-bb
 V{ } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
 
 [ ] [ test-tdmsc ] unit-test
 
@@ -38,12 +38,12 @@ V{ } 4 test-bb
 V{ } 5 test-bb
 V{ } 6 test-bb
 
-0 get 1 get 5 get V{ } 2sequence >>successors drop
+0 { 1 5 } edges
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 6 get 1vector >>successors drop
+4 6 edge
-5 get 6 get 1vector >>successors drop
+5 6 edge
 
 [ ] [ test-tdmsc ] unit-test
 
@@ -61,13 +61,13 @@ V{ } 5 test-bb
 V{ } 6 test-bb
 V{ } 7 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 1vector >>successors drop
+1 2 edge
-2 get 3 get 6 get V{ } 2sequence >>successors drop
+2 { 3 6 } edges
-3 get 4 get 1vector >>successors drop
+3 4 edge
-6 get 7 get 1vector >>successors drop
+6 7 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
-5 get 2 get 1vector >>successors drop
+5 2 edge
 
 [ ] [ test-tdmsc ] unit-test
 

basis/compiler/cfg/ssa/cssa/cssa.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.utilities
+compiler.cfg.instructions ;
+IN: compiler.cfg.ssa.cssa
+
+! Convert SSA to conventional SSA.
+
+:: insert-copy ( bb src -- bb dst )
+    i :> dst
+    bb [ dst src ##copy ] add-instructions
+    bb dst ;
+
+: convert-phi ( ##phi -- )
+    [ [ insert-copy ] assoc-map ] change-inputs drop ;
+
+: construct-cssa ( cfg -- )
+    [ [ convert-phi ] each-phi ] each-basic-block ;

basis/compiler/cfg/ssa/destruction/copies/copies.factor

@@ -1,28 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables fry kernel make namespaces sets
-sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
-IN: compiler.cfg.ssa.destruction.copies
-
-ERROR: bad-copy ;
-
-: compute-copies ( assoc -- assoc' )
-    dup assoc-size <hashtable> [
-        '[
-            prune [
-                2dup eq? [ 2drop ] [
-                    _ 2dup key?
-                    [ bad-copy ] [ set-at ] if
-                ] if
-            ] with each
-        ] assoc-each
-    ] keep ;
-
-: insert-copies ( -- )
-    waiting get [
-        [ instructions>> building ] dip '[
-            building get pop
-            _ compute-copies parallel-copy
-            ,
-        ] with-variable
-    ] assoc-each ;

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -1,63 +1,104 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel locals math math.order
+USING: accessors arrays assocs fry kernel namespaces
-sequences namespaces sets
+sequences sequences.deep
+sets vectors
 compiler.cfg.rpo
 compiler.cfg.def-use
-compiler.cfg.utilities
+compiler.cfg.renaming
 compiler.cfg.dominance
 compiler.cfg.instructions
 compiler.cfg.liveness.ssa
-compiler.cfg.critical-edges
+compiler.cfg.ssa.cssa
-compiler.cfg.ssa.destruction.state
+compiler.cfg.ssa.interference
-compiler.cfg.ssa.destruction.forest
+compiler.cfg.ssa.interference.live-ranges
-compiler.cfg.ssa.destruction.copies
+compiler.utilities ;
-compiler.cfg.ssa.destruction.renaming
-compiler.cfg.ssa.destruction.live-ranges
-compiler.cfg.ssa.destruction.process-blocks ;
 IN: compiler.cfg.ssa.destruction
 
-! Based on "Fast Copy Coalescing and Live-Range Identification"
+! Maps vregs to leaders.
-! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
+SYMBOL: leader-map
 
-! Dominance, liveness and def-use need to be computed
+: leader ( vreg -- vreg' ) leader-map get compress-path ;
 
-: process-blocks ( cfg -- )
+! Maps leaders to equivalence class elements.
-    [ [ process-block ] if-has-phis ] each-basic-block ;
+SYMBOL: class-element-map
 
-SYMBOL: seen
+: class-elements ( vreg -- elts ) class-element-map get at ;
 
-:: visit-renaming ( dst assoc src bb -- )
+! Sequence of vreg pairs
-    src seen get key? [
+SYMBOL: copies
-        src dst bb add-waiting
-        src assoc delete-at
-    ] [ src seen get conjoin ] if ;
 
-:: break-interferences ( -- )
+: init-coalescing ( -- )
-    V{ } clone seen set
+    H{ } clone leader-map set
-    renaming-sets get [| dst assoc |
+    H{ } clone class-element-map set
-        assoc [| src bb |
+    V{ } clone copies set ;
-            dst assoc src bb visit-renaming
+
-        ] assoc-each
+: classes-interfere? ( vreg1 vreg2 -- ? )
+    [ leader ] bi@ 2dup eq? [ 2drop f ] [
+        [ class-elements flatten ] bi@ sets-interfere?
+    ] if ;
+
+: update-leaders ( vreg1 vreg2 -- )
+    swap leader-map get set-at ;
+
+: merge-classes ( vreg1 vreg2 -- )
+    [ [ class-elements ] bi@ push ]
+    [ drop class-element-map get delete-at ] 2bi ;
+
+: eliminate-copy ( vreg1 vreg2 -- )
+    [ leader ] bi@
+    2dup eq? [ 2drop ] [
+        [ update-leaders ] [ merge-classes ] 2bi
+    ] if ;
+
+: introduce-vreg ( vreg -- )
+    [ leader-map get conjoin ]
+    [ [ 1vector ] keep class-element-map get set-at ] bi ;
+
+GENERIC: prepare-insn ( insn -- )
+
+M: ##copy prepare-insn
+    [ dst>> ] [ src>> ] bi 2array copies get push ;
+
+M: ##phi prepare-insn
+    [ dst>> ] [ inputs>> values ] bi
+    [ eliminate-copy ] with each ;
+
+M: insn prepare-insn drop ;
+
+: prepare-block ( bb -- )
+    instructions>> [ prepare-insn ] each ;
+
+: prepare-coalescing ( cfg -- )
+    init-coalescing
+    defs get keys [ introduce-vreg ] each
+    [ prepare-block ] each-basic-block ;
+
+: process-copies ( -- )
+    copies get [
+        2dup classes-interfere?
+        [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-: remove-phis-from-block ( bb -- )
+: useless-copy? ( ##copy -- ? )
-    instructions>> [ ##phi? not ] filter-here ;
+    dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
 
-: remove-phis ( cfg -- )
+: perform-renaming ( cfg -- )
-    [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
+    leader-map get keys [ dup leader ] H{ } map>assoc renamings set
+    [
+        instructions>> [
+            [ rename-insn-defs ]
+            [ rename-insn-uses ]
+            [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
+        ] filter-here
+    ] each-basic-block ;
 
 : destruct-ssa ( cfg -- cfg' )
-    dup cfg-has-phis? [
+    dup construct-cssa
-        init-coalescing
+    compute-ssa-live-sets
-        compute-ssa-live-sets
+    dup compute-defs
-        dup split-critical-edges
+    dup compute-dominance
-        dup compute-def-use
+    dup compute-live-ranges
-        dup compute-dominance
+    dup prepare-coalescing
-        dup compute-live-ranges
+    process-copies
-        dup process-blocks
+    dup perform-renaming ;
-        break-interferences
-        dup perform-renaming
-        insert-copies
-        dup remove-phis
-    ] when ;

basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor

@@ -1,86 +0,0 @@
-USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
-compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
-compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
-cpu.architecture kernel namespaces sequences tools.test vectors sorting
-math.order ;
-IN: compiler.cfg.ssa.destruction.forest.tests
-
-V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
-V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
-V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
-V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
-V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
-V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
-V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
-
-0 get 1 get 2 get V{ } 2sequence >>successors drop
-2 get 3 get 4 get V{ } 2sequence >>successors drop
-3 get 5 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-1 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
-
-: clean-up-forest ( forest -- forest' )
-    [ [ vreg>> n>> ] compare ] sort
-    [
-        [ clean-up-forest ] change-children
-        [ number>> ] change-bb
-    ] V{ } map-as ;
-
-: test-dom-forest ( vregs -- forest )
-    cfg new 0 get >>entry
-    compute-predecessors
-    dup compute-dominance
-    compute-def-use
-    compute-dom-forest
-    clean-up-forest ;
-
-[ V{ } ] [ { } test-dom-forest ] unit-test
-
-[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
-[ { V int-regs 0 } test-dom-forest ]
-unit-test
-
-[
-    V{
-        T{ dom-forest-node
-           f
-           V int-regs 0
-           0
-           V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
-        }
-    }
-]
-[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
-unit-test
-
-[
-    V{
-        T{ dom-forest-node
-           f
-           V int-regs 1
-           1
-           V{ }
-        }
-        T{ dom-forest-node
-           f
-           V int-regs 2
-           2
-           V{
-               T{ dom-forest-node f V int-regs 3 3 V{ } }
-               T{ dom-forest-node f V int-regs 4 4 V{ } }
-               T{ dom-forest-node f V int-regs 5 5 V{ } }
-           }
-        }
-        T{ dom-forest-node
-           f
-           V int-regs 6
-           6
-           V{ }
-        }
-    }
-]
-[
-    { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
-    test-dom-forest
-] unit-test

basis/compiler/cfg/ssa/destruction/forest/forest.factor

@@ -1,38 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel math math.order
-namespaces sequences sorting vectors compiler.cfg.def-use
-compiler.cfg.dominance compiler.cfg.registers ;
-IN: compiler.cfg.ssa.destruction.forest
-
-TUPLE: dom-forest-node vreg bb children ;
-
-<PRIVATE
-
-: sort-vregs-by-bb ( vregs -- alist )
-    defs get
-    '[ dup _ at ] { } map>assoc
-    [ [ second pre-of ] compare ] sort ;
-
-: <dom-forest-node> ( vreg bb parent -- node )
-    [ V{ } clone dom-forest-node boa dup ] dip children>> push ;
-
-: <virtual-root> ( -- node )
-    f f V{ } clone dom-forest-node boa ;
-
-: find-parent ( pre stack -- parent )
-    2dup last vreg>> def-of maxpre-of > [
-        dup pop* find-parent
-    ] [ nip last ] if ;
-
-: (compute-dom-forest) ( vreg bb stack -- )
-    [ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
-
-PRIVATE>
-
-: compute-dom-forest ( vregs -- forest )
-    <virtual-root> [
-        1vector
-        [ sort-vregs-by-bb ] dip
-        '[ _ (compute-dom-forest) ] assoc-each
-    ] keep children>> ;

basis/compiler/cfg/ssa/destruction/interference/interference.factor

@@ -1,44 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators combinators.short-circuit
-kernel math namespaces sequences locals compiler.cfg.def-use
-compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ;
-IN: compiler.cfg.ssa.destruction.interference
-
-<PRIVATE
-
-: kill-after-def? ( vreg1 vreg2 bb -- ? )
-    ! If first register is used after second one is defined, they interfere.
-    ! If they are used in the same instruction, no interference. If the
-    ! instruction is a def-is-use-insn, then there will be a use at +1
-    ! (instructions are 2 apart) and so outputs will interfere with
-    ! inputs.
-    [ kill-index ] [ def-index ] bi-curry bi* > ;
-
-: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
-    ! If both are defined in the same basic block, they interfere if their
-    ! local live ranges intersect.
-    drop
-    { [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ;
-
-: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
-    ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
-    ! occurs before vreg1 is killed.
-    nip
-    kill-after-def? ;
-
-: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
-    ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
-    ! occurs before vreg2 is killed.
-    drop
-    swapd kill-after-def? ;
-
-PRIVATE>
-
-: interferes? ( vreg1 vreg2 -- ? )
-    2dup [ def-of ] bi@ {
-        { [ 2dup eq? ] [ interferes-same-block? ] }
-        { [ 2dup dominates? ] [ interferes-first-dominates? ] }
-        { [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
-        [ 2drop 2drop f ]
-    } cond ;

basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor

@@ -1,138 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel locals math math.order arrays
-namespaces sequences sorting sets combinators combinators.short-circuit make
-compiler.cfg.def-use
-compiler.cfg.instructions
-compiler.cfg.liveness.ssa
-compiler.cfg.dominance
-compiler.cfg.ssa.destruction.state
-compiler.cfg.ssa.destruction.forest
-compiler.cfg.ssa.destruction.interference ;
-IN: compiler.cfg.ssa.destruction.process-blocks
-
-! phi-union maps a vreg to the predecessor block
-! that carries it to the phi node's block
-
-! unioned-blocks is a set of bb's which defined
-! the source vregs above
-SYMBOLS: phi-union unioned-blocks ;
-
-: operand-live-into-phi-node's-block? ( src dst -- ? )
-    def-of live-in? ;
-
-: phi-node-is-live-out-of-operand's-block? ( src dst -- ? )
-    swap def-of live-out? ;
-
-: operand-is-phi-node-and-live-into-operand's-block? ( src dst -- ? )
-    drop { [ insn-of ##phi? ] [ dup def-of live-in? ] } 1&& ;
-
-: operand-being-renamed? ( src dst -- ? )
-    drop processed-names get key? ;
-
-: two-operands-in-same-block? ( src dst -- ? )
-    drop def-of unioned-blocks get key? ;
-
-: trivial-interference? ( src dst -- ? )
-    {
-        [ operand-live-into-phi-node's-block? ]
-        [ phi-node-is-live-out-of-operand's-block? ]
-        [ operand-is-phi-node-and-live-into-operand's-block? ]
-        [ operand-being-renamed? ]
-        [ two-operands-in-same-block? ]
-    } 2|| ;
-
-: don't-coalesce ( bb src dst -- )
-    2nip processed-name ;
-
-:: trivial-interference ( bb src dst -- )
-    dst src bb add-waiting
-    src used-by-another get push ;
-
-:: add-to-renaming-set ( bb src dst -- )
-    bb src phi-union get set-at
-    src def-of unioned-blocks get conjoin ;
-
-: process-phi-operand ( bb src dst -- )
-    {
-        { [ 2dup eq? ] [ don't-coalesce ] }
-        { [ 2dup trivial-interference? ] [ trivial-interference ] }
-        [ add-to-renaming-set ]
-    } cond ;
-
-: node-is-live-in-of-child? ( node child -- ? )
-    [ vreg>> ] [ bb>> ] bi* live-in? ;
-
-: node-is-live-out-of-child? ( node child -- ? )
-    [ vreg>> ] [ bb>> ] bi* live-out? ;
-
-:: insert-copy ( bb src dst -- )
-    bb src dst trivial-interference
-    src phi-union get delete-at ;
-
-:: insert-copy-for-parent ( bb src dst node -- )
-    src node vreg>> eq? [ bb src dst insert-copy ] when ;
-
-: insert-copies-for-parent ( ##phi node child -- )
-    drop
-    [ [ inputs>> ] [ dst>> ] bi ] dip
-    '[ _ _ insert-copy-for-parent ] assoc-each ;
-
-: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
-
-: add-interference ( ##phi node child -- )
-    [ vreg>> ] bi@ 2array , drop ;
-
-: process-df-child ( ##phi node child -- )
-    {
-        { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
-        { [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
-        { [ 2dup defined-in-same-block? ] [ add-interference ] }
-        [ 3drop ]
-    } cond ;
-
-: process-df-node ( ##phi node -- )
-    dup children>>
-    [ [ process-df-child ] with with each ]
-    [ nip [ process-df-node ] with each ]
-    3bi ;
-
-: process-phi-union ( ##phi dom-forest -- )
-    [ process-df-node ] with each ;
-
-: add-local-interferences ( ##phi -- )
-    [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
-
-: compute-local-interferences ( ##phi -- pairs )
-    [
-        [ phi-union get keys compute-dom-forest process-phi-union ]
-        [ add-local-interferences ]
-        bi
-    ] { } make ;
-
-:: insert-copies-for-interference ( ##phi src -- )
-    ##phi inputs>> [| bb src' |
-        src src' eq? [ bb src ##phi dst>> insert-copy ] when
-    ] assoc-each ;
-
-: process-local-interferences ( ##phi pairs -- )
-    [
-        first2 2dup interferes?
-        [ drop insert-copies-for-interference ] [ 3drop ] if
-    ] with each ;
-
-: add-renaming-set ( ##phi -- )
-    [ phi-union get ] dip dst>> renaming-sets get set-at
-    phi-union get [ drop processed-name ] assoc-each ;
-
-: process-phi ( ##phi -- )
-    H{ } clone phi-union set
-    H{ } clone unioned-blocks set
-    [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
-    [ dup compute-local-interferences process-local-interferences ]
-    [ add-renaming-set ]
-    tri ;
-
-: process-block ( bb -- )
-    instructions>>
-    [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;

basis/compiler/cfg/ssa/destruction/renaming/renaming.factor

@@ -1,47 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel namespaces sequences
-compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
-disjoint-sets ;
-IN: compiler.cfg.ssa.destruction.renaming
-
-: build-disjoint-set ( assoc -- disjoint-set )
-    <disjoint-set> dup [
-        '[
-            [ _ add-atom ]
-            [ [ drop _ add-atom ] assoc-each ]
-            bi*
-        ] assoc-each
-    ] keep ;
-
-: update-congruence-class ( dst assoc disjoint-set -- )
-    [ keys swap ] dip equate-all-with ;
-        
-: build-congruence-classes ( -- disjoint-set )
-    renaming-sets get
-    dup build-disjoint-set
-    [ '[ _ update-congruence-class ] assoc-each ] keep ;
-
-: compute-renaming ( disjoint-set -- assoc )
-    [ parents>> ] keep
-    '[ drop dup _ representative ] assoc-map ;
-
-: rename-blocks ( cfg -- )
-    [
-        instructions>> [
-            [ rename-insn-defs ]
-            [ rename-insn-uses ] bi
-        ] each
-    ] each-basic-block ;
-
-: rename-copies ( -- )
-    waiting renamings get '[
-        [
-            [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
-        ] assoc-map
-    ] change ;
-
-: perform-renaming ( cfg -- )
-    build-congruence-classes compute-renaming renamings set
-    rename-blocks
-    rename-copies ;

basis/compiler/cfg/ssa/destruction/state/state.factor

@@ -1,18 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sets kernel assocs ;
-IN: compiler.cfg.ssa.destruction.state
-
-SYMBOLS: processed-names waiting used-by-another renaming-sets ;
-
-: init-coalescing ( -- )
-    H{ } clone renaming-sets set
-    H{ } clone processed-names set
-    H{ } clone waiting set
-    V{ } clone used-by-another set ;
-
-: processed-name ( vreg -- ) processed-names get conjoin ;
-
-: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
-
-: add-waiting ( dst src bb -- ) waiting-for push-at ;

basis/compiler/cfg/ssa/interference/interference-tests.factor

@@ -0,0 +1,52 @@
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.def-use compiler.cfg.dominance
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.registers compiler.cfg.predecessors
+compiler.cfg.ssa.interference
+compiler.cfg.ssa.interference.live-ranges cpu.architecture
+kernel namespaces tools.test ;
+IN: compiler.cfg.ssa.interference.tests
+
+: test-interference ( -- )
+    cfg new 0 get >>entry
+    compute-ssa-live-sets
+    compute-predecessors
+    dup compute-defs
+    dup compute-dominance
+    compute-live-ranges ;
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##copy f V int-regs 1 V int-regs 0 }
+    T{ ##copy f V int-regs 3 V int-regs 2 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 4 D 0 }
+    T{ ##peek f V int-regs 5 D 0 }
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##peek f V int-regs 6 D 0 }
+    T{ ##replace f V int-regs 5 D 0 }
+    T{ ##return }
+} 1 test-bb
+
+0 1 edge
+
+[ ] [ test-interference ] unit-test
+
+[ f ] [ V int-regs 0 V int-regs 1 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 1 V int-regs 0 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 2 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 2 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 0 V int-regs 2 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 2 V int-regs 0 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 1 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 1 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 3 V int-regs 4 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 4 V int-regs 3 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 3 V int-regs 5 vregs-interfere? ] unit-test
+[ t ] [ V int-regs 5 V int-regs 3 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 3 V int-regs 6 vregs-interfere? ] unit-test
+[ f ] [ V int-regs 6 V int-regs 3 vregs-interfere? ] unit-test

basis/compiler/cfg/ssa/interference/interference.factor

@@ -0,0 +1,86 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.short-circuit fry
+kernel math math.order sorting namespaces sequences locals
+compiler.cfg.def-use compiler.cfg.dominance
+compiler.cfg.ssa.interference.live-ranges ;
+IN: compiler.cfg.ssa.interference
+
+<PRIVATE
+
+:: kill-after-def? ( vreg1 vreg2 bb -- ? )
+    ! If first register is used after second one is defined, they interfere.
+    ! If they are used in the same instruction, no interference. If the
+    ! instruction is a def-is-use-insn, then there will be a use at +1
+    ! (instructions are 2 apart) and so outputs will interfere with
+    ! inputs.
+    vreg1 bb kill-index
+    vreg2 bb def-index > ;
+
+:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
+    ! If both are defined in the same basic block, they interfere if their
+    ! local live ranges intersect.
+    vreg1 bb1 def-index
+    vreg2 bb1 def-index <
+    [ vreg1 vreg2 ] [ vreg2 vreg1 ] if
+    bb1 kill-after-def? ;
+
+: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+    ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
+    ! occurs before vreg1 is killed.
+    nip
+    kill-after-def? ;
+
+: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+    ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
+    ! occurs before vreg2 is killed.
+    drop
+    swapd kill-after-def? ;
+
+PRIVATE>
+
+: vregs-interfere? ( vreg1 vreg2 -- ? )
+    2dup [ def-of ] bi@ {
+        { [ 2dup eq? ] [ interferes-same-block? ] }
+        { [ 2dup dominates? ] [ interferes-first-dominates? ] }
+        { [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
+        [ 2drop 2drop f ]
+    } cond ;
+
+! Debug this stuff later
+<PRIVATE
+
+: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
+
+: quadratic-test ( seq1 seq2 -- ? )
+    '[ _ [ vregs-interfere? ] with any? ] any? ;
+
+: sort-vregs-by-bb ( vregs -- alist )
+    defs get
+    '[ dup _ at ] { } map>assoc
+    [ [ second pre-of ] compare ] sort ;
+
+: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
+
+: find-parent ( dom current -- parent )
+    over empty? [ 2drop f ] [
+        over last over dominates? [ drop last ] [
+            over pop* find-parent
+        ] if
+    ] if ;
+
+:: linear-test ( seq1 seq2 -- ? )
+    ! Instead of sorting, SSA destruction should keep equivalence
+    ! classes sorted by merging them on append
+    V{ } clone :> dom
+    seq1 seq2 append sort-vregs-by-bb [| pair |
+        pair first :> current
+        dom current find-parent
+        dup [ current vregs-interfere? ] when
+        [ t ] [ current dom push f ] if
+    ] any? ;
+
+PRIVATE>
+
+: sets-interfere? ( seq1 seq2 -- ? )
+    quadratic-test ;

basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs fry kernel namespaces sequences math
 arrays compiler.cfg.def-use compiler.cfg.instructions
 compiler.cfg.liveness.ssa compiler.cfg.rpo ;
-IN: compiler.cfg.ssa.destruction.live-ranges
+IN: compiler.cfg.ssa.interference.live-ranges
 
 ! Live ranges for interference testing
 

basis/compiler/cfg/ssa/liveness/liveness-tests.factor

@@ -31,7 +31,7 @@ V{
     T{ ##replace f V int-regs 3 D 0 }
 } 3 test-bb
 
-1 get 2 get 3 get V{ } 2sequence >>successors drop
+1 { 2 3 } edges
 
 cfg new 1 get >>entry 4 set
 
@@ -132,35 +132,35 @@ cfg new 1 get >>entry 5 set
 ! This is the CFG in Figure 3 from the paper
 V{ } 1 test-bb
 V{ } 2 test-bb
-1 get 2 get 1vector >>successors drop
+1 2 edge
 V{
     T{ ##peek f V int-regs 0 D 0 }
     T{ ##peek f V int-regs 1 D 0 }
     T{ ##peek f V int-regs 2 D 0 }
 } 3 test-bb
 V{ } 11 test-bb
-2 get 3 get 11 get V{ } 2sequence >>successors drop
+2 { 3 11 } edges
 V{
     T{ ##replace f V int-regs 0 D 0 }
 } 4 test-bb
 V{ } 8 test-bb
-3 get 8 get 4 get V{ } 2sequence >>successors drop
+3 { 8 4 } edges
 V{
     T{ ##replace f V int-regs 1 D 0 }
 } 9 test-bb
-8 get 9 get 1vector >>successors drop
+8 9 edge
 V{
     T{ ##replace f V int-regs 2 D 0 }
 } 5 test-bb
-4 get 5 get 1vector >>successors drop
+4 5 edge
 V{ } 10 test-bb
 V{ } 6 test-bb
-5 get 6 get 1vector >>successors drop
+5 6 edge
-9 get 6 get 10 get V{ } 2sequence >>successors drop
+9 { 6 10 } edges
 V{ } 7 test-bb
-6 get 5 get 7 get V{ } 2sequence >>successors drop
+6 { 5 7 } edges
-10 get 8 get 1vector >>successors drop
+10 8 edge
-7 get 2 get 1vector >>successors drop
+7 2 edge
 
 cfg new 1 get >>entry 0 set
 [ ] [ 0 get compute-predecessors drop ] unit-test

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -30,8 +30,12 @@ ERROR: bad-peek dst loc ;
     [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
 
 : visit-edge ( from to -- )
-    2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
+    ! If both blocks are subroutine calls, don't bother
-    [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
+    ! computing anything.
+    2dup [ kill-block? ] both? [ 2drop ] [
+        2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
+        [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+    ] if ;
 
 : visit-block ( bb -- )
     [ predecessors>> ] keep '[ _ visit-edge ] each ;

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -25,8 +25,8 @@ V{
     T{ ##inc-d f 1 }
 } 2 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 1vector >>successors drop
+1 2 edge
 
 [ ] [ test-uninitialized ] unit-test
 
@@ -52,9 +52,9 @@ V{
     T{ ##return }
 } 3 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 3 get 1vector >>successors drop
+2 3 edge
 
 [ ] [ test-uninitialized ] unit-test
 

basis/compiler/cfg/two-operand/two-operand-tests.factor

@@ -27,19 +27,12 @@ compiler.cfg.registers cpu.architecture namespaces tools.test ;
 
 [
     V{
-        T{ ##copy f V int-regs 4 V int-regs 2 }
+        T{ ##copy f V int-regs 4 V int-regs 1 }
-        T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 }
+        T{ ##copy f V int-regs 1 V int-regs 2 }
-        T{ ##copy f V int-regs 1 V int-regs 4 }
+        T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 }
     }
 ] [
     {
         T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
     } (convert-two-operand)
 ] unit-test
-
-! This should never come up after coalescing
-[
-    V{
-        T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 }
-    } (convert-two-operand)
-] must-fail

basis/compiler/cfg/two-operand/two-operand.factor

@@ -65,15 +65,11 @@ GENERIC: convert-two-operand* ( insn -- )
 
 : case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
 
-ERROR: bad-case-2 insn ;
-
 : case-2 ( insn -- )
-    ! This can't work with a ##fixnum-overflow since it branches
-    dup ##fixnum-overflow? [ bad-case-2 ] when
     dup dst>> reg-class>> next-vreg
-    [ swap src1>> emit-copy ]
+    [ swap src2>> emit-copy ]
-    [ [ >>src1 ] [ >>dst ] bi , ]
+    [ drop [ src2>> ] [ src1>> ] bi emit-copy ]
-    [ [ src2>> ] dip emit-copy ]
+    [ >>src2 dup dst>> >>src1 , ]
     2tri ; inline
 
 : case-3 ( insn -- )
@@ -97,8 +93,10 @@ M: ##not convert-two-operand*
 
 M: insn convert-two-operand* , ;
 
-: (convert-two-operand) ( cfg -- cfg' )
+: (convert-two-operand) ( insns -- insns' )
-    [ [ convert-two-operand* ] each ] V{ } make ;
+    dup first kill-vreg-insn? [
+        [ [ convert-two-operand* ] each ] V{ } make
+    ] unless ;
 
 : convert-two-operand ( cfg -- cfg' )
     two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;

basis/compiler/cfg/utilities/utilities.factor

@@ -43,6 +43,13 @@ SYMBOL: visited
     to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
     from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
 
+: add-instructions ( bb quot -- )
+    [ instructions>> building ] dip '[
+        building get pop
+        @
+        ,
+    ] with-variable ; inline
+
 : <simple-block> ( insns -- bb )
     <basic-block>
     swap >vector
@@ -58,6 +65,10 @@ SYMBOL: visited
 : if-has-phis ( bb quot: ( bb -- ) -- )
     [ dup has-phis? ] dip [ drop ] if ; inline
 
+: each-phi ( bb quot: ( ##phi -- ) -- )
+    [ instructions>> ] dip
+    '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
+
 : predecessor ( bb -- pred )
     predecessors>> first ; inline
 

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -1175,16 +1175,11 @@ V{
 } 3 test-bb
 
 V{
-    T{ ##phi f V int-regs 3 { } }
+    T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
     T{ ##replace f V int-regs 3 D 0 }
     T{ ##return }
 } 4 test-bb
 
-4 get instructions>> first
-2 get V int-regs 1 2array
-3 get V int-regs 2 2array 2array
->>inputs drop
-
 test-diamond
 
 [ ] [
@@ -1296,10 +1291,10 @@ V{
     T{ ##return }
 } 5 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
-1 get 2 get 4 get V{ } 2sequence >>successors drop
+1 { 2 4 } edges
-2 get 3 get 1vector >>successors drop
+2 3 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
 
 [ ] [
     cfg new 0 get >>entry

basis/compiler/tests/codegen.factor

@@ -2,7 +2,8 @@ USING: generalizations accessors arrays compiler kernel kernel.private
 math hashtables.private math.private namespaces sequences tools.test
 namespaces.private slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make alien.c-types combinators.short-circuit ;
+combinators vectors grouping make alien.c-types combinators.short-circuit
+math.order ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
 
@@ -366,4 +367,29 @@ cell 4 = [
     fixnum+fast 2 fixnum*fast 2 fixnum-fast 2 fixnum*fast 2 fixnum+fast ;
 
 [ 10 ] [ 1 coalescing-bug-2 ] unit-test
-[ 86 ] [ 11 coalescing-bug-2 ] unit-test
+[ 86 ] [ 11 coalescing-bug-2 ] unit-test
+
+! Regression in suffix-arrays code
+: coalescing-bug-3 ( from/f to/f seq -- slice )
+    [
+        [ drop 0 or ] [ length or ] bi-curry bi*
+        [ min ] keep
+    ] keep <slice> ;
+
+[ T{ slice f 0 5 "hello" } ] [ f f "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 1 5 "hello" } ] [ 1 f "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 0 3 "hello" } ] [ f 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 1 3 "hello" } ] [ 1 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 3 3 "hello" } ] [ 4 3 "hello" coalescing-bug-3 ] unit-test
+[ T{ slice f 5 5 "hello" } ] [ 6 f "hello" coalescing-bug-3 ] unit-test
+
+! Reduction
+: coalescing-bug-4 ( a b c -- a b c )
+     [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
+
+ [ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
+ [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+ [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+ [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test

basis/compiler/tests/low-level-ir.factor

@@ -27,8 +27,8 @@ IN: compiler.tests.low-level-ir
         T{ ##epilogue }
         T{ ##return }
     } [ clone ] map 2 test-bb
-    0 get 1 get 1vector >>successors drop
+    0 1 edge
-    1 get 2 get 1vector >>successors drop
+    1 2 edge
     compile-test-cfg
     execute( -- result ) ;
 

basis/compiler/tree/propagation/copy/copy.factor

@@ -5,7 +5,8 @@ combinators sets locals columns grouping
 stack-checker.branches
 compiler.tree
 compiler.tree.def-use
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.utilities ;
 IN: compiler.tree.propagation.copy
 
 ! Two values are copy-equivalent if they are always identical
@@ -15,18 +16,6 @@ IN: compiler.tree.propagation.copy
 ! Mapping from values to their canonical leader
 SYMBOL: copies
 
-:: compress-path ( source assoc -- destination )
-    [let | destination [ source assoc at ] |
-        source destination = [ source ] [
-            [let | destination' [ destination assoc compress-path ] |
-                destination' destination = [
-                    destination' source assoc set-at
-                ] unless
-                destination'
-            ]
-        ] if
-    ] ;
-
 : resolve-copy ( copy -- val ) copies get compress-path ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;

basis/compiler/utilities/utilities.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private arrays vectors fry
-math math.order namespaces assocs ;
+math math.order namespaces assocs locals ;
 IN: compiler.utilities
 
 : flattener ( seq quot -- seq vector quot' )
@@ -30,3 +30,15 @@ yield-hook [ [ ] ] initialize
     [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
 
 : penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
+
+:: compress-path ( source assoc -- destination )
+    [let | destination [ source assoc at ] |
+        source destination = [ source ] [
+            [let | destination' [ destination assoc compress-path ] |
+                destination' destination = [
+                    destination' source assoc set-at
+                ] unless
+                destination'
+            ]
+        ] if
+    ] ;

core/combinators/combinators-docs.factor

@@ -354,6 +354,22 @@ HELP: spread
 
 { bi* tri* spread } related-words
 
+HELP: to-fixed-point
+{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } }
+{ $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." }
+{ $examples
+    { $example
+        "USING: combinators kernel math prettyprint sequences ;"
+        "IN: scratchpad"
+        ": flatten ( sequence -- sequence' )"
+        "    \"flatten\" over index"
+        "    [ [ 1 + swap nth ] [ nip dup 2 + ] [ drop ] 2tri replace-slice ] when* ;"
+        ""
+        "{ \"flatten\" { 1 { 2 3 } \"flatten\" { 4 5 } { 6 } } } [ flatten ] to-fixed-point ."
+        "{ 1 { 2 3 } 4 5 { 6 } }"
+    }
+} ;
+
 HELP: alist>quot
 { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
 { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }

core/combinators/combinators.factor

@@ -180,3 +180,6 @@ M: hashtable hashcode*
         dup assoc-size 1 eq?
         [ assoc-hashcode ] [ nip assoc-size ] if
     ] recursive-hashcode ;
+
+: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
+    [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive

core/make/make.factor

@@ -8,7 +8,7 @@ SYMBOL: building
 : make ( quot exemplar -- seq )
     [
         [
-            1024 swap new-resizable [
+            100 swap new-resizable [
                 building set call
             ] keep
         ] keep like