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

basis/compiler/cfg/debugger/debugger.factor

@@ -26,7 +26,7 @@ M: word test-cfg
     ] map ;
 
 : insn. ( insn -- )
-    tuple>array [ pprint bl ] each nl ;
+    tuple>array but-last [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [

basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences
+USING: accessors kernel sequences namespaces assocs fry
 combinators.short-circuit
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.state ;
@@ -20,9 +20,16 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
         [ avoids-inactive-intervals? ]
     } 1&& ;
 
+: reuse-spill-slot ( old new -- )
+    [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
+
+: reuse-register ( old new -- )
+    reg>> >>reg drop ;
+
+: (coalesce) ( old new -- )
+    [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
+
 : coalesce ( live-interval -- )
     dup copy-from>> active-interval
-    [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
-    [ reg>> >>reg drop ]
-    2bi ;
+    [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
  

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

@@ -17,7 +17,7 @@ ERROR: bad-live-ranges interval ;
     ] [ drop ] if ;
 
 : trim-before-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> last ] bi
+    [ ranges>> ] [ uses>> last 1 + ] bi
     [ '[ from>> _ <= ] filter-here ]
     [ swap last (>>to) ]
     2bi ;
@@ -38,10 +38,10 @@ ERROR: bad-live-ranges interval ;
     } 2cleave ;
 
 : assign-spill ( live-interval -- )
-    dup assign-spill-slot >>spill-to f >>split-next drop ;
+    dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
 
 : assign-reload ( live-interval -- )
-    dup assign-spill-slot >>reload-from drop ;
+    dup vreg>> assign-spill-slot >>reload-from drop ;
 
 : split-and-spill ( live-interval n -- before after )
     split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;

basis/compiler/cfg/linear-scan/allocation/state/state.factor

@@ -126,18 +126,8 @@ SYMBOL: spill-counts
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
-DEFER: assign-spill-slot
-
-: compute-spill-slot ( live-interval -- n )
-    dup copy-from>>
-    [ assign-spill-slot ]
-    [ vreg>> reg-class>> next-spill-slot ] ?if ;
-
-: assign-spill-slot ( live-interval -- n )
-    dup vreg>> spill-slots get at [ ] [
-        [ compute-spill-slot dup ] keep
-        vreg>> spill-slots get set-at
-    ] ?if ;
+: assign-spill-slot ( vreg -- n )
+    spill-slots get [ reg-class>> next-spill-slot ] cache ;
 
 : init-allocator ( registers -- )
     registers set

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

@@ -107,7 +107,7 @@ SYMBOL: check-assignment?
 ERROR: overlapping-registers intervals ;
 
 : check-assignment ( intervals -- )
-    dup [ copy-from>> ] map sift [ vreg>> ] map '[ vreg>> _ member? not ] filter
+    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 
 : active-intervals ( n -- intervals )
@@ -150,7 +150,7 @@ ERROR: bad-live-values live-values ;
 
 : begin-block ( bb -- )
     dup basic-block set
-    dup block-from prepare-insn
+    dup block-from activate-new-intervals
     [ [ live-in ] [ block-from ] bi compute-live-values ] keep
     register-live-ins get set-at ;
 

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

@@ -82,9 +82,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 1 }
+       { end 2 }
        { uses V{ 0 1 } }
-       { ranges V{ T{ live-range f 0 1 } } }
+       { ranges V{ T{ live-range f 0 2 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -107,9 +107,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 0 }
+       { end 1 }
        { uses V{ 0 } }
-       { ranges V{ T{ live-range f 0 0 } } }
+       { ranges V{ T{ live-range f 0 1 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -132,9 +132,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 0 }
+       { end 1 }
        { uses V{ 0 } }
-       { ranges V{ T{ live-range f 0 0 } } }
+       { ranges V{ T{ live-range f 0 1 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -1317,38 +1317,6 @@ USING: math.private ;
     allocate-registers drop
 ] unit-test
 
-! Spill slot liveness was computed incorrectly, leading to a FEP
-! early in bootstrap on x86-32
-[ t ] [
-    [
-        H{ } clone live-ins set
-        H{ } clone live-outs set
-        H{ } clone phi-live-ins set
-        T{ basic-block
-           { id 12345 }
-           { instructions
-             V{
-                 T{ ##gc f V int-regs 6 V int-regs 7 }
-                 T{ ##peek f V int-regs 0 D 0 }
-                 T{ ##peek f V int-regs 1 D 1 }
-                 T{ ##peek f V int-regs 2 D 2 }
-                 T{ ##peek f V int-regs 3 D 3 }
-                 T{ ##peek f V int-regs 4 D 4 }
-                 T{ ##peek f V int-regs 5 D 5 }
-                 T{ ##replace f V int-regs 0 D 1 }
-                 T{ ##replace f V int-regs 1 D 2 }
-                 T{ ##replace f V int-regs 2 D 3 }
-                 T{ ##replace f V int-regs 3 D 4 }
-                 T{ ##replace f V int-regs 4 D 5 }
-                 T{ ##replace f V int-regs 5 D 0 }
-             }
-           }
-        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
-        instructions>> first
-        live-values>> assoc-empty?
-    ] with-scope
-] unit-test
-
 [ f ] [
     T{ live-range f 0 10 }
     T{ live-range f 20 30 }
@@ -2483,3 +2451,160 @@ V{
 8 get 9 get 1vector >>successors drop
 
 [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! Another test case for fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
+
+[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+
+[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! GC check tests
+
+! Spill slot liveness was computed incorrectly, leading to a FEP
+! early in bootstrap on x86-32
+[ t ] [
+    [
+        H{ } clone live-ins set
+        H{ } clone live-outs set
+        H{ } clone phi-live-ins set
+        T{ basic-block
+           { id 12345 }
+           { instructions
+             V{
+                 T{ ##gc f V int-regs 6 V int-regs 7 }
+                 T{ ##peek f V int-regs 0 D 0 }
+                 T{ ##peek f V int-regs 1 D 1 }
+                 T{ ##peek f V int-regs 2 D 2 }
+                 T{ ##peek f V int-regs 3 D 3 }
+                 T{ ##peek f V int-regs 4 D 4 }
+                 T{ ##peek f V int-regs 5 D 5 }
+                 T{ ##replace f V int-regs 0 D 1 }
+                 T{ ##replace f V int-regs 1 D 2 }
+                 T{ ##replace f V int-regs 2 D 3 }
+                 T{ ##replace f V int-regs 3 D 4 }
+                 T{ ##replace f V int-regs 4 D 5 }
+                 T{ ##replace f V int-regs 5 D 0 }
+             }
+           }
+        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+        instructions>> first
+        live-values>> assoc-empty?
+    ] with-scope
+] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##gc f V int-regs 2 V int-regs 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
+
+
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 0 test-bb
+
+V{
+    T{ ##gc f V int-regs 2 V int-regs 3 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 1 test-bb
+
+V{
+    T{ ##return }
+} 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test