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

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index bf2a56adbdfd1ab1bed6a90081de60d3c6bb1ecd..e55f42e77476545a591b90acf36d57793b2e2a40 100644 (file)
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -40,16 +40,23 @@ ERROR: already-spilled ;
     2dup key? [ already-spilled ] [ set-at ] if ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+    {
+        [ reg>> ]
+        [ vreg>> reg-class>> ]
+        [ spill-to>> ]
+        [ end>> ]
+    } cleave f swap \ _spill boa , ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
 
 : insert-copy ( live-interval -- )
-    [ split-next>> reg>> ]
-    [ reg>> ]
-    [ vreg>> reg-class>> ]
-    tri _copy ;
+    {
+        [ split-next>> reg>> ]
+        [ reg>> ]
+        [ vreg>> reg-class>> ]
+        [ end>> ]
+    } cleave f swap \ _copy boa , ;
 
 : handle-copy ( live-interval -- )
     dup [ spill-to>> not ] [ split-next>> ] bi and
@@ -68,7 +75,12 @@ ERROR: already-reloaded ;
     2dup key? [ delete-at ] [ already-reloaded ] if ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+    {
+        [ reg>> ]
+        [ vreg>> reg-class>> ]
+        [ reload-from>> ]
+        [ end>> ]
+    } cleave f swap \ _reload boa , ;
 
 : handle-reload ( live-interval -- )
     dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
@@ -141,6 +153,6 @@ M: insn assign-registers-in-insn drop ;
         ] V{ } make
     ] change-instructions drop ;
 
-: assign-registers ( rpo live-intervals -- )
-    init-assignment
+: assign-registers ( live-intervals rpo -- )
+    [ init-assignment ] dip
     [ assign-registers-in-block ] each ;

diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index dad87b62ae39534f865afbc7c6613c82d5caadbb..401241722fe74f9296c6753e03cc6a4df8c1a5bb 100644 (file)
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences sets arrays math strings fry
-prettyprint compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation ;
+namespaces prettyprint compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation compiler.cfg ;
 IN: compiler.cfg.linear-scan.debugger
 
 : check-assigned ( live-intervals -- )
@@ -34,3 +34,6 @@ IN: compiler.cfg.linear-scan.debugger
 
 : live-intervals. ( seq -- )
     [ interval-picture ] map simple-table. ;
+
+: test-bb ( insns n -- )
+    [ <basic-block> swap >>number swap >>instructions ] keep set ;
\ No newline at end of file

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index b43294818b5dea09a633a25de3fc2bf1661d9286..1f8112a8939d3f6bb44cc4b2b5f8976cb54148e9 100644 (file)
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -10,6 +10,8 @@ compiler.cfg.registers
 compiler.cfg.liveness
 compiler.cfg.predecessors
 compiler.cfg.rpo
+compiler.cfg.linearization
+compiler.cfg.debugger
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
@@ -410,7 +412,7 @@ SYMBOL: max-uses
 [ ] [ 10 20 2 400 random-test ] unit-test
 [ ] [ 10 20 4 300 random-test ] unit-test
 
-USING: math.private compiler.cfg.debugger ;
+USING: math.private ;
 
 [ ] [
     [ float+ float>fixnum 3 fixnum*fast ]
@@ -1417,194 +1419,149 @@ USING: math.private compiler.cfg.debugger ;
 
 ! Bug in live spill slots calculation
 
-T{ basic-block
-   { id 205651 }
-   { number 0 }
-   { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
 
-T{ basic-block
-   { id 205652 }
-   { number 1 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 703128 }
-            { loc D 1 }
-         }
-         T{ ##peek
-            { dst V int-regs 703129 }
-            { loc D 0 }
-         }
-         T{ ##copy
-            { dst V int-regs 703134 }
-            { src V int-regs 703128 }
-         }
-         T{ ##copy
-            { dst V int-regs 703135 }
-            { src V int-regs 703129 }
-         }
-         T{ ##compare-imm-branch
-            { src1 V int-regs 703128 }
-            { src2 5 }
-            { cc cc/= }
-         }
-     }
-   }
-} 1 set
+V{
+    T{ ##peek
+       { dst V int-regs 703128 }
+       { loc D 1 }
+    }
+    T{ ##peek
+       { dst V int-regs 703129 }
+       { loc D 0 }
+    }
+    T{ ##copy
+       { dst V int-regs 703134 }
+       { src V int-regs 703128 }
+    }
+    T{ ##copy
+       { dst V int-regs 703135 }
+       { src V int-regs 703129 }
+    }
+    T{ ##compare-imm-branch
+       { src1 V int-regs 703128 }
+       { src2 5 }
+       { cc cc/= }
+    }
+} 1 test-bb
 
-T{ basic-block
-   { id 205653 }
-   { number 2 }
-   { instructions
-     V{
-         T{ ##copy
-            { dst V int-regs 703134 }
-            { src V int-regs 703129 }
-         }
-         T{ ##copy
-            { dst V int-regs 703135 }
-            { src V int-regs 703128 }
-         }
-         T{ ##branch }
-     }
-   }
-} 2 set
+V{
+    T{ ##copy
+       { dst V int-regs 703134 }
+       { src V int-regs 703129 }
+    }
+    T{ ##copy
+       { dst V int-regs 703135 }
+       { src V int-regs 703128 }
+    }
+    T{ ##branch }
+} 2 test-bb
 
-T{ basic-block
-   { id 205655 }
-   { number 3 }
-   { instructions
-     V{
-         T{ ##replace
-            { src V int-regs 703134 }
-            { loc D 0 }
-         }
-         T{ ##replace
-            { src V int-regs 703135 }
-            { loc D 1 }
-         }
-         T{ ##epilogue }
-         T{ ##return }
-     }
-   }
-} 3 set
+V{
+    T{ ##replace
+       { src V int-regs 703134 }
+       { loc D 0 }
+    }
+    T{ ##replace
+       { src V int-regs 703135 }
+       { loc D 1 }
+    }
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
 
 1 get 1vector 0 get (>>successors)
 2 get 3 get V{ } 2sequence 1 get (>>successors)
 3 get 1vector 2 get (>>successors)
 
+SYMBOL: linear-scan-result
+
 :: test-linear-scan-on-cfg ( regs -- )
     [ ] [
         cfg new 0 get >>entry
         compute-predecessors
         compute-liveness
-        reverse-post-order
+        dup reverse-post-order
         { { int-regs regs } } (linear-scan)
+        flatten-cfg 1array mr.
     ] unit-test ;
 
-{ 1 2 } test-linear-scan-on-cfg
+! This test has a critical edge -- do we care about these?
+
+! { 1 2 } test-linear-scan-on-cfg
 
 ! Bug in inactive interval handling
 ! [ rot dup [ -rot ] when ]
-T{ basic-block
-   { id 201486 }
-   { number 0 }
-   { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
     
-T{ basic-block
-   { id 201487 }
-   { number 1 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 689473 }
-            { loc D 2 }
-         }
-         T{ ##peek
-            { dst V int-regs 689474 }
-            { loc D 1 }
-         }
-         T{ ##peek
-            { dst V int-regs 689475 }
-            { loc D 0 }
-         }
-         T{ ##compare-imm-branch
-            { src1 V int-regs 689473 }
-            { src2 5 }
-            { cc cc/= }
-         }
-     }
-   }
-} 1 set
+V{
+    T{ ##peek
+       { dst V int-regs 689473 }
+       { loc D 2 }
+    }
+    T{ ##peek
+       { dst V int-regs 689474 }
+       { loc D 1 }
+    }
+    T{ ##peek
+       { dst V int-regs 689475 }
+       { loc D 0 }
+    }
+    T{ ##compare-imm-branch
+       { src1 V int-regs 689473 }
+       { src2 5 }
+       { cc cc/= }
+    }
+} 1 test-bb
 
-T{ basic-block
-   { id 201488 }
-   { number 2 }
-   { instructions
-     V{
-         T{ ##copy
-            { dst V int-regs 689481 }
-            { src V int-regs 689475 }
-         }
-         T{ ##copy
-            { dst V int-regs 689482 }
-            { src V int-regs 689474 }
-         }
-         T{ ##copy
-            { dst V int-regs 689483 }
-            { src V int-regs 689473 }
-         }
-         T{ ##branch }
-     }
-   }
-} 2 set
+V{
+    T{ ##copy
+       { dst V int-regs 689481 }
+       { src V int-regs 689475 }
+    }
+    T{ ##copy
+       { dst V int-regs 689482 }
+       { src V int-regs 689474 }
+    }
+    T{ ##copy
+       { dst V int-regs 689483 }
+       { src V int-regs 689473 }
+    }
+    T{ ##branch }
+} 2 test-bb
 
-T{ basic-block
-   { id 201489 }
-   { number 3 }
-   { instructions
-     V{
-         T{ ##copy
-            { dst V int-regs 689481 }
-            { src V int-regs 689473 }
-         }
-         T{ ##copy
-            { dst V int-regs 689482 }
-            { src V int-regs 689475 }
-         }
-         T{ ##copy
-            { dst V int-regs 689483 }
-            { src V int-regs 689474 }
-         }
-         T{ ##branch }
-     }
-   }
-} 3 set
+V{
+    T{ ##copy
+       { dst V int-regs 689481 }
+       { src V int-regs 689473 }
+    }
+    T{ ##copy
+       { dst V int-regs 689482 }
+       { src V int-regs 689475 }
+    }
+    T{ ##copy
+       { dst V int-regs 689483 }
+       { src V int-regs 689474 }
+    }
+    T{ ##branch }
+} 3 test-bb
 
-T{ basic-block
-   { id 201490 }
-   { number 4 }
-   { instructions
-     V{
-         T{ ##replace
-            { src V int-regs 689481 }
-            { loc D 0 }
-         }
-         T{ ##replace
-            { src V int-regs 689482 }
-            { loc D 1 }
-         }
-         T{ ##replace
-            { src V int-regs 689483 }
-            { loc D 2 }
-         }
-         T{ ##epilogue }
-         T{ ##return }
-     }
-   }
-} 4 set
+V{
+    T{ ##replace
+       { src V int-regs 689481 }
+       { loc D 0 }
+    }
+    T{ ##replace
+       { src V int-regs 689482 }
+       { loc D 1 }
+    }
+    T{ ##replace
+       { src V int-regs 689483 }
+       { loc D 2 }
+    }
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
 
 : test-diamond ( -- )
     1 get 1vector 0 get (>>successors)
@@ -1625,102 +1582,78 @@ T{ basic-block
    { instructions V{ T{ ##prologue } T{ ##branch } } }
 } 0 set
     
-T{ basic-block
-   { id 201538 }
-   { number 1 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 689600 }
-            { loc D 1 }
-         }
-         T{ ##peek
-            { dst V int-regs 689601 }
-            { loc D 0 }
-         }
-         T{ ##compare-imm-branch
-            { src1 V int-regs 689600 }
-            { src2 5 }
-            { cc cc/= }
-         }
-     }
-   }
-} 1 set
+V{
+    T{ ##peek
+       { dst V int-regs 689600 }
+       { loc D 1 }
+    }
+    T{ ##peek
+       { dst V int-regs 689601 }
+       { loc D 0 }
+    }
+    T{ ##compare-imm-branch
+       { src1 V int-regs 689600 }
+       { src2 5 }
+       { cc cc/= }
+    }
+} 1 test-bb
     
-T{ basic-block
-   { id 201539 }
-   { number 2 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 689604 }
-            { loc D 2 }
-         }
-         T{ ##copy
-            { dst V int-regs 689607 }
-            { src V int-regs 689604 }
-         }
-         T{ ##copy
-            { dst V int-regs 689608 }
-            { src V int-regs 689600 }
-         }
-         T{ ##copy
-            { dst V int-regs 689610 }
-            { src V int-regs 689601 }
-         }
-         T{ ##branch }
-     }
-   }
-} 2 set
+V{
+    T{ ##peek
+       { dst V int-regs 689604 }
+       { loc D 2 }
+    }
+    T{ ##copy
+       { dst V int-regs 689607 }
+       { src V int-regs 689604 }
+    }
+    T{ ##copy
+       { dst V int-regs 689608 }
+       { src V int-regs 689600 }
+    }
+    T{ ##copy
+       { dst V int-regs 689610 }
+       { src V int-regs 689601 }
+    }
+    T{ ##branch }
+} 2 test-bb
     
-T{ basic-block
-   { id 201540 }
-   { number 3 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 689609 }
-            { loc D 2 }
-         }
-         T{ ##copy
-            { dst V int-regs 689607 }
-            { src V int-regs 689600 }
-         }
-         T{ ##copy
-            { dst V int-regs 689608 }
-            { src V int-regs 689601 }
-         }
-         T{ ##copy
-            { dst V int-regs 689610 }
-            { src V int-regs 689609 }
-         }
-         T{ ##branch }
-     }
-   }
-} 3 set
+V{
+    T{ ##peek
+       { dst V int-regs 689609 }
+       { loc D 2 }
+    }
+    T{ ##copy
+       { dst V int-regs 689607 }
+       { src V int-regs 689600 }
+    }
+    T{ ##copy
+       { dst V int-regs 689608 }
+       { src V int-regs 689601 }
+    }
+    T{ ##copy
+       { dst V int-regs 689610 }
+       { src V int-regs 689609 }
+    }
+    T{ ##branch }
+} 3 test-bb
     
-T{ basic-block
-   { id 201541 }
-   { number 4 }
-   { instructions
-     V{
-         T{ ##replace
-            { src V int-regs 689607 }
-            { loc D 0 }
-         }
-         T{ ##replace
-            { src V int-regs 689608 }
-            { loc D 1 }
-         }
-         T{ ##replace
-            { src V int-regs 689610 }
-            { loc D 2 }
-         }
-         T{ ##epilogue }
-         T{ ##return }
-     }
-   }
-} 4 set
+V{
+    T{ ##replace
+       { src V int-regs 689607 }
+       { loc D 0 }
+    }
+    T{ ##replace
+       { src V int-regs 689608 }
+       { loc D 1 }
+    }
+    T{ ##replace
+       { src V int-regs 689610 }
+       { loc D 2 }
+    }
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
 
 test-diamond
 
@@ -1729,76 +1662,130 @@ test-diamond
 ! compute-live-registers was inaccurate since it didn't take
 ! lifetime holes into account
 
-T{ basic-block
-   { id 0 }
-   { number 0 }
-   { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
 
-T{ basic-block
-   { id 1 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 0 }
-            { loc D 0 }
-         }
-         T{ ##compare-imm-branch
-            { src1 V int-regs 0 }
-            { src2 5 }
-            { cc cc/= }
-         }
-     }
-   }
-} 1 set
+V{
+    T{ ##peek
+       { dst V int-regs 0 }
+       { loc D 0 }
+    }
+    T{ ##compare-imm-branch
+       { src1 V int-regs 0 }
+       { src2 5 }
+       { cc cc/= }
+    }
+} 1 test-bb
 
-T{ basic-block
-   { id 2 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 1 }
-            { loc D 1 }
-         }
-         T{ ##copy
-            { dst V int-regs 2 }
-            { src V int-regs 1 }
-         }
-         T{ ##branch }
-     }
-   }
-} 2 set
+V{
+    T{ ##peek
+       { dst V int-regs 1 }
+       { loc D 1 }
+    }
+    T{ ##copy
+       { dst V int-regs 2 }
+       { src V int-regs 1 }
+    }
+    T{ ##branch }
+} 2 test-bb
 
-T{ basic-block
-   { id 3 }
-   { instructions
-     V{
-         T{ ##peek
-            { dst V int-regs 3 }
-            { loc D 2 }
-         }
-         T{ ##copy
-            { dst V int-regs 2 }
-            { src V int-regs 3 }
-         }
-         T{ ##branch }
-     }
-   }
-} 3 set
+V{
+    T{ ##peek
+       { dst V int-regs 3 }
+       { loc D 2 }
+    }
+    T{ ##copy
+       { dst V int-regs 2 }
+       { src V int-regs 3 }
+    }
+    T{ ##branch }
+} 3 test-bb
 
-T{ basic-block
-   { id 4 }
-   { instructions
-     V{
-         T{ ##replace
-            { src V int-regs 2 }
-            { loc D 0 }
-         }
-         T{ ##return }
-     }
-   }
-} 4 set
+V{
+    T{ ##replace
+       { src V int-regs 2 }
+       { loc D 0 }
+    }
+    T{ ##return }
+} 4 test-bb
 
 test-diamond
 
-{ 1 2 3 4 } test-linear-scan-on-cfg
\ No newline at end of file
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! Inactive interval handling: splitting active interval
+! if it fits in lifetime hole only partially
+
+V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 2 R 0 }
+    T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 1 D 2 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 R 2 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+{ 1 2 } test-linear-scan-on-cfg
+
+USING: classes ;
+
+[ ] [
+    1 get instructions>> first regs>> V int-regs 0 swap at
+    2 get instructions>> first regs>> V int-regs 1 swap at assert=
+] unit-test
+
+[ _copy ] [ 3 get instructions>> second class ] unit-test
+
+! Resolve pass; make sure the spilling is done correctly
+V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 2 R 0 }
+    T{ ##compare-imm-branch f V int-regs 2 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 R 1 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 1 D 2 }
+    T{ ##replace f V int-regs 0 D 2 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 R 2 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+{ 1 2 } test-linear-scan-on-cfg
+
+[ _spill ] [ 2 get instructions>> first class ] unit-test
+
+[ _spill ] [ 3 get instructions>> second class ] unit-test
+
+[ _reload ] [ 4 get instructions>> first class ] unit-test
\ No newline at end of file

diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 3a0a7f877002d19ba3fc6d32e833ca928a368dab..2d3ad41b223f31c375a054ef84eef5047e2e6e49 100644 (file)
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make
+USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
@@ -9,7 +9,8 @@ compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
-compiler.cfg.linear-scan.assignment ;
+compiler.cfg.linear-scan.assignment
+compiler.cfg.linear-scan.resolve ;
 IN: compiler.cfg.linear-scan
 
 ! References:
@@ -26,12 +27,11 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
-: (linear-scan) ( rpo machine-registers -- )
-    [
-        dup number-instructions
-        dup compute-live-intervals
-    ] dip
-    allocate-registers assign-registers ;
+:: (linear-scan) ( rpo machine-registers -- )
+    rpo number-instructions
+    rpo compute-live-intervals machine-registers allocate-registers
+    rpo assign-registers
+    rpo resolve-data-flow ;
 
 : linear-scan ( cfg -- cfg' )
     [

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
new file mode 100644 (file)
index 0000000..3e98d6c
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -0,0 +1,65 @@
+USING: accessors arrays compiler.cfg compiler.cfg.instructions
+compiler.cfg.linear-scan.debugger
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.numbering
+compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
+compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
+namespaces tools.test vectors ;
+IN: compiler.cfg.linear-scan.resolve.tests
+
+[ { 1 2 3 4 5 6 } ] [
+    { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
+] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 1 }
+    T{ ##return }
+} 1 test-bb
+
+1 get 1vector 0 get (>>successors)
+
+cfg new 0 get >>entry
+compute-predecessors
+dup reverse-post-order number-instructions
+drop
+
+CONSTANT: test-live-interval-1
+T{ live-interval
+   { start 0 }
+   { end 6 }
+   { uses V{ 0 6 } }
+   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
+   { spill-to 0 }
+   { vreg V int-regs 0 }
+}
+
+[ f ] [
+    0 get test-live-interval-1 spill-to
+] unit-test
+
+[ 0 ] [
+    1 get test-live-interval-1 spill-to
+] unit-test
+
+CONSTANT: test-live-interval-2
+T{ live-interval
+   { start 0 }
+   { end 6 }
+   { uses V{ 0 6 } }
+   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
+   { reload-from 0 }
+   { vreg V int-regs 0 }
+}
+
+[ 0 ] [
+    0 get test-live-interval-2 reload-from
+] unit-test
+
+[ f ] [
+    1 get test-live-interval-2 reload-from
+] unit-test
\ No newline at end of file

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index df2dbb1198add417e12870a7d3283360fb332383..55a2eab41baadbabde374e8d66a6b1c770363a8d 100644 (file)
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,34 +1,118 @@
 ! Copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel math namespaces sequences
-compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
+classes.tuple classes.parser parser fry words make arrays
+locals combinators compiler.cfg.linear-scan.live-intervals
+compiler.cfg.liveness compiler.cfg.instructions ;
 IN: compiler.cfg.linear-scan.resolve
 
-: add-mapping ( from to -- )
-    2drop
-    ;
+<<
+
+TUPLE: operation from to reg-class ;
+
+SYNTAX: OPERATION:
+    CREATE-CLASS dup save-location
+    [ operation { } define-tuple-class ]
+    [
+        [ scan-word scan-word ] keep
+        '[
+            [ [ _ execute ] [ _ execute ] bi* ]
+            [ vreg>> reg-class>> ]
+            bi _ boa ,
+        ] (( from to -- )) define-declared
+    ] bi ;
+
+>>
+
+: reload-from ( bb live-interval -- n/f )
+    2dup [ block-from ] [ start>> ] bi* =
+    [ nip reload-from>> ] [ 2drop f ] if ;
+
+: spill-to ( bb live-interval -- n/f )
+    2dup [ block-to ] [ end>> ] bi* =
+    [ nip spill-to>> ] [ 2drop f ] if ;
+
+OPERATION: memory->memory spill-to>> reload-from>>
+OPERATION: register->memory reg>> reload-from>>
+OPERATION: memory->register spill-to>> reg>>
+OPERATION: register->register reg>> reg>>
+
+:: add-mapping ( bb1 bb2 li1 li2 -- )
+    bb2 li2 reload-from [
+        bb1 li1 spill-to
+        [ li1 li2 memory->memory ]
+        [ li1 li2 register->memory ] if
+    ] [
+        bb1 li1 spill-to
+        [ li1 li2 memory->register ]
+        [ li1 li2 register->register ] if
+    ] if ;
 
 : resolve-value-data-flow ( bb to vreg -- )
+    [ 2dup ] dip
     live-intervals get at
     [ [ block-to ] dip child-interval-at ]
     [ [ block-from ] dip child-interval-at ]
-    bi-curry bi* 2dup = [ 2drop ] [
-        add-mapping
-    ] if ;
+    bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
+
+: compute-mappings ( bb to -- mappings )
+    [
+        dup live-in keys
+        [ resolve-value-data-flow ] with with each
+    ] { } make ;
+
+GENERIC: >insn ( operation -- )
+
+M: memory->memory >insn
+    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
-: resolve-mappings ( bb to -- )
-    2drop
-    ;
+M: register->memory >insn
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+
+M: memory->register >insn
+    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+
+M: register->register >insn
+    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+: mapping-instructions ( mappings -- insns )
+    [ [ >insn ] each ] { } make ;
+
+: fork? ( from to -- ? )
+    [ successors>> length 1 >= ]
+    [ predecessors>> length 1 = ] bi* and ; inline
+
+: insert-position/fork ( from to -- before after )
+    nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
+
+: join? ( from to -- ? )
+    [ successors>> length 1 = ]
+    [ predecessors>> length 1 >= ] bi* and ; inline
+
+: insert-position/join ( from to -- before after )
+    drop instructions>> dup pop 1array ;
+
+: insert-position ( bb to -- before after )
+    {
+        { [ 2dup fork? ] [ insert-position/fork ] }
+        { [ 2dup join? ] [ insert-position/join ] }
+    } cond ;
+
+: 3append-here ( seq2 seq1 seq3 -- )
+    #! Mutate seq1
+    swap '[ _ push-all ] bi@ ;
+
+: perform-mappings ( mappings bb to -- )
+    pick empty? [ 3drop ] [
+        [ mapping-instructions ] 2dip
+        insert-position 3append-here
+    ] if ;
 
 : resolve-edge-data-flow ( bb to -- )
-    [ dup live-in [ resolve-value-data-flow ] with with each ]
-    [ resolve-mappings ]
-    2bi ; 
+    [ compute-mappings ] [ perform-mappings ] 2bi ;
 
 : resolve-block-data-flow ( bb -- )
-    dup successors>> [
-        resolve-edge-data-flow
-    ] with each ;
+    dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
     [ resolve-block-data-flow ] each ;
\ No newline at end of file

diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index 7d18482bff8edc07451a51ec3fbc68f10546cf7f..afdaccc8963ef0985ac26fbaa1af575b1f9c11f3 100644 (file)
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -74,7 +74,7 @@ $nl
 "Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
 { $heading "Input quotation declaration" }
 "Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
-{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
+{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
 "The following is correct:"
 { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
 "The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."