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

basis/heaps/heaps.factor

@@ -190,3 +190,8 @@ M: heap heap-pop ( heap -- value key )
     [ dup heap-empty? not ]
     [ dup heap-pop swap 2array ]
     [ ] produce nip ;
+
+: slurp-heap ( heap quot: ( elt -- ) -- )
+    over heap-empty? [ 2drop ] [
+        [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
+    ] if ; inline recursive

unfinished/compiler/backend/x86/32/32.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.registers compiler.backend ;
+USING: system cpu.x86.assembler compiler.cfg.registers
+compiler.backend ;
 IN: compiler.backend.x86.32
 
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
-        { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+        { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
     } ;

unfinished/compiler/backend/x86/64/64.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system cpu.x86.assembler compiler.cfg.registers
+compiler.backend ;
+IN: compiler.backend.x86.64
+
+M: x86.64 machine-registers
+    {
+        { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+        { double-float-regs {
+            XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+            XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
+        } }
+    } ;

unfinished/compiler/cfg/builder/builder.factor

@@ -10,9 +10,9 @@ compiler.cfg
 compiler.cfg.stacks
 compiler.cfg.templates
 compiler.cfg.iterator
-compiler.alien
+compiler.cfg.instructions
-compiler.instructions
+compiler.cfg.registers
-compiler.registers ;
+compiler.alien ;
 IN: compiler.cfg.builder
 
 ! Convert tree SSA IR to CFG (not quite SSA yet) IR.

unfinished/compiler/cfg/instructions/instructions.factor

@@ -1,20 +1,21 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces
-math compiler.instructions.syntax ;
+math compiler.cfg.registers compiler.cfg.instructions.syntax ;
-IN: compiler.instructions
+IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-INSN: %cond-branch vreg ;
+TUPLE: %cond-branch < insn src ;
-INSN: %unary dst src ;
+TUPLE: %unary < insn dst src ;
+TUPLE: %nullary < insn dst ;
 
 ! Stack operations
-INSN: %peek vreg loc ;
+INSN: %load-literal < %nullary obj ;
-INSN: %replace vreg loc ;
+INSN: %peek < %nullary loc ;
+INSN: %replace src loc ;
 INSN: %inc-d n ;
 INSN: %inc-r n ;
-INSN: %load-literal obj vreg ;
 
 ! Calling convention
 INSN: %return ;
@@ -22,7 +23,7 @@ INSN: %return ;
 ! Subroutine calls
 INSN: %call word ;
 INSN: %jump word ;
-INSN: %intrinsic quot vregs ;
+INSN: %intrinsic quot regs ;
 
 ! Jump tables
 INSN: %dispatch-label label ;
@@ -46,14 +47,18 @@ INSN: %alien-invoke params ;
 INSN: %alien-indirect params ;
 INSN: %alien-callback params ;
 
+GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
+M: %nullary defs-vregs dst>> >vreg 1array ;
+M: %unary defs-vregs dst>> >vreg 1array ;
+M: insn defs-vregs drop f ;
+
+M: %replace uses-vregs src>> >vreg 1array ;
+M: %unary uses-vregs src>> >vreg 1array ;
 M: insn uses-vregs drop f ;
-M: %peek uses-vregs vreg>> 1array ;
+
-M: %replace uses-vregs vreg>> 1array ;
+! M: %intrinsic uses-vregs vregs>> values ;
-M: %load-literal uses-vregs vreg>> 1array ;
-M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
-M: %intrinsic uses-vregs vregs>> values ;
 
 ! Instructions used by CFG IR only.
 INSN: %prologue ;
@@ -64,12 +69,16 @@ INSN: %branch ;
 INSN: %branch-f < %cond-branch ;
 INSN: %branch-t < %cond-branch ;
 INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs out ;
+INSN: %boolean-intrinsic quot vregs dst ;
 
-M: %cond-branch uses-vregs vreg>> 1array ;
+M: %cond-branch uses-vregs src>> 1array ;
-M: %if-intrinsic uses-vregs vregs>> values ;
+
-M: %boolean-intrinsic uses-vregs
+! M: %if-intrinsic uses-vregs vregs>> values ;
-    [ vregs>> values ] [ out>> ] bi suffix ;
+
+M: %boolean-intrinsic defs-vregs dst>> 1array ;
+
+! M: %boolean-intrinsic uses-vregs
+!     [ vregs>> values ] [ out>> ] bi suffix ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue n ;
@@ -85,12 +94,15 @@ INSN: _label label ;
 : resolve-label ( label/name -- )
     dup label? [ get ] unless _label ;
 
-TUPLE: _cond-branch vreg label ;
+TUPLE: _cond-branch < insn src label ;
 
 INSN: _branch label ;
 INSN: _branch-f < _cond-branch ;
 INSN: _branch-t < _cond-branch ;
 INSN: _if-intrinsic label quot vregs ;
 
-M: _cond-branch uses-vregs vreg>> 1array ;
+M: _cond-branch uses-vregs src>> >vreg 1array ;
-M: _if-intrinsic uses-vregs vregs>> values ;
+! M: _if-intrinsic uses-vregs vregs>> values ;
+
+INSN: _spill src n ;
+INSN: _reload dst n ;

unfinished/compiler/cfg/instructions/syntax/syntax.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
-make parser ;
+make fry sequences parser ;
-IN: compiler.instructions.syntax
+IN: compiler.cfg.instructions.syntax
 
 TUPLE: insn ;
 
 : INSN:
-    parse-tuple-definition
+    parse-tuple-definition "regs" suffix
     [ dup tuple eq? [ drop insn ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop dup [ boa , ] curry define-inline ]
+    [ 2drop dup '[ f _ boa , ] define-inline ]
     3tri ; parsing

unfinished/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -1,18 +1,21 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry
+accessors vectors fry heaps
 compiler.cfg.linear-scan.live-intervals
 compiler.backend ;
 IN: compiler.cfg.linear-scan.allocation
 
-! Mapping from vregs to machine registers
+! Mapping from register classes to sequences of machine registers
-SYMBOL: register-allocation
+SYMBOL: free-registers
 
-! Mapping from vregs to spill locations
+: free-registers-for ( vreg -- seq )
-SYMBOL: spill-locations
+    reg-class>> free-registers get at ;
 
-! Vector of active live intervals, in order of increasing end point
+: deallocate-register ( live-interval -- )
+    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
 SYMBOL: active-intervals
 
 : add-active ( live-interval -- )
@@ -21,70 +24,136 @@ SYMBOL: active-intervals
 : delete-active ( live-interval -- )
     active-intervals get delete ;
 
-! Mapping from register classes to sequences of machine registers
+: expire-old-intervals ( n -- )
-SYMBOL: free-registers
+    active-intervals get
+    swap '[ end>> _ < ] partition
+    active-intervals set
+    [ deallocate-register ] each ;
 
-! Counter of spill locations
+: expire-old-uses ( n -- )
+    active-intervals get
+    swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
+
+: update-state ( live-interval -- )
+    start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+    start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+    [ check-progress ]
+    [ dup start>> unhandled-intervals get heap-push ]
+    bi ;
+
+: init-unhandled ( live-intervals -- )
+    [ [ start>> ] keep ] { } map>assoc
+    unhandled-intervals get heap-push-all ;
+
+: assign-free-register ( live-interval registers -- )
+    #! If the live interval does not have any uses, it means it
+    #! will be spilled immediately, so it still needs a register
+    #! to compute the new value, but we don't add the interval
+    #! to the active set and we don't remove the register from
+    #! the free list.
+    over uses>> empty?
+    [ peek >>reg drop ] [ pop >>reg add-active ] if ;
+
+! Spilling
 SYMBOL: spill-counter
 
 : next-spill-location ( -- n )
     spill-counter [ dup 1+ ] change ;
 
-: assign-spill ( live-interval -- )
-    next-spill-location swap vreg>> spill-locations get set-at ;
-
-: free-registers-for ( vreg -- seq )
-    reg-class>> free-registers get at ;
-
-: free-register ( vreg -- )
-    #! Free machine register currently assigned to vreg.
-    [ register-allocation get at ] [ free-registers-for ] bi push ;
-
-: expire-old-intervals ( live-interval -- )
-    active-intervals get
-    swap '[ end>> _ start>> < ] partition
-    active-intervals set
-    [ vreg>> free-register ] each ;
-
 : interval-to-spill ( -- live-interval )
-    #! We spill the interval with the longest remaining range.
+    #! We spill the interval with the most distant use location.
     active-intervals get unclip-slice [
-        [ [ end>> ] bi@ > ] most
+        [ [ uses>> peek ] bi@ > ] most
     ] reduce ;
 
-: reuse-register ( live-interval to-spill -- )
+: check-split ( live-interval -- )
-    vreg>> swap vreg>>
+    [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
-    register-allocation get
-    tuck [ at ] [ set-at ] 2bi* ;
 
-: spill-at-interval ( live-interval -- )
+: split-interval ( live-interval -- before after )
+    #! Split the live interval at the location of its first use.
+    #! 'Before' now starts and ends on the same instruction.
+    [ check-split ]
+    [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
+    [ clone f >>reg dup uses>> peek >>start ]
+    tri ;
+
+: record-split ( live-interval before after -- )
+    [ >>split-before ] [ >>split-after ] bi* drop ;
+
+: assign-spill ( before after -- before after )
+    #! If it has been spilled already, reuse spill location.
+    over reload-from>> [ next-spill-location ] unless*
+    tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
+
+: split-and-spill ( live-interval -- before after )
+    dup split-interval [ record-split ] [ assign-spill ] 2bi ;
+
+: reuse-register ( new existing -- )
+    reg>> >>reg
+    dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
+
+: spill-existing ( new existing -- )
+    #! Our new interval will be used before the active interval
+    #! with the most distant use location. Spill the existing
+    #! interval, then process the new interval and the tail end
+    #! of the existing interval again.
+    [ reuse-register ]
+    [ delete-active ]
+    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
+
+: spill-new ( new existing -- )
+    #! Our new interval will be used after the active interval
+    #! with the most distant use location. Split the new
+    #! interval, then process both parts of the new interval
+    #! again.
+    [ split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+    over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
+
+: assign-blocked-register ( live-interval -- )
     interval-to-spill
-    2dup [ end>> ] bi@ > [
+    2dup spill-existing?
-        [ reuse-register ]
+    [ spill-existing ] [ spill-new ] if ;
-        [ nip assign-spill ]
-        [ [ add-active ] [ delete-active ] bi* ]
-        2tri
-    ] [ drop assign-spill ] if ;
 
-: init-allocator ( -- )
+: assign-register ( live-interval -- )
-    H{ } clone register-allocation set
-    H{ } clone spill-locations set
-    V{ } clone active-intervals set
-    machine-registers [ >vector ] assoc-map free-registers set
-    0 spill-counter set ;
-
-: assign-register ( live-interval register -- )
-    swap vreg>> register-allocation get set-at ;
-
-: allocate-register ( live-interval -- )
     dup vreg>> free-registers-for [
-        spill-at-interval
+        assign-blocked-register
     ] [
-        [ pop assign-register ]
+        assign-free-register
-        [ drop add-active ]
-        2bi
     ] if-empty ;
 
-: allocate-registers ( live-intervals -- )
+! Main loop
-    init-allocator
+: init-allocator ( registers -- )
-    [ [ expire-old-intervals ] [ allocate-register ] bi ] each ;
+    V{ } clone active-intervals set
+    <min-heap> unhandled-intervals set
+    [ reverse >vector ] assoc-map free-registers set
+    0 spill-counter set
+    -1 progress set ;
+
+: handle-interval ( live-interval -- )
+    [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
+
+: (allocate-registers) ( -- )
+    unhandled-intervals get [ handle-interval ] slurp-heap ;
+
+: allocate-registers ( live-intervals machine-registers -- live-intervals )
+    #! This modifies the input live-intervals.
+    [
+        init-allocator
+        dup init-unhandled
+        (allocate-registers)
+    ] with-scope ;

unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor

@@ -0,0 +1,4 @@
+USING: compiler.cfg.linear-scan.assignment tools.test ;
+IN: compiler.cfg.linear-scan.assignment.tests
+
+\ assign-registers must-infer

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

@@ -0,0 +1,79 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math assocs namespaces sequences heaps
+fry make
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.assignment
+
+! A vector of live intervals. There is linear searching involved
+! but since we never have too many machine registers (around 30
+! at most) and we probably won't have that many live at any one
+! time anyway, it is not a problem to check each element.
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+    active-intervals get push ;
+
+: lookup-register ( vreg -- reg )
+    active-intervals get [ vreg>> = ] with find nip reg>> ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+: add-unhandled ( live-interval -- )
+    dup split-before>> [
+        [ split-before>> ] [ split-after>> ] bi
+        [ add-unhandled ] bi@
+    ] [
+        dup start>> unhandled-intervals get heap-push
+    ] if ;
+
+: init-unhandled ( live-intervals -- )
+    [ add-unhandled ] each ;
+
+: insert-spill ( live-interval -- )
+    [ reg>> ] [ spill-to>> ] bi dup [ _spill ] [ 2drop ] if ;
+
+: expire-old-intervals ( n -- )
+    active-intervals get
+    swap '[ end>> _ = ] partition
+    active-intervals set
+    [ insert-spill ] each ;
+
+: insert-reload ( live-interval -- )
+    [ reg>> ] [ reload-from>> ] bi dup [ _reload ] [ 2drop ] if ;
+
+: activate-new-intervals ( n -- )
+    #! Any live intervals which start on the current instruction
+    #! are added to the active set.
+    unhandled-intervals get dup heap-empty? [ 2drop ] [
+        2dup heap-peek drop start>> = [
+            heap-pop drop [ add-active ] [ insert-reload ] bi
+            activate-new-intervals
+        ] [ 2drop ] if
+    ] if ;
+
+: (assign-registers) ( insn -- )
+    dup
+    [ defs-vregs ] [ uses-vregs ] bi append
+    active-intervals get swap '[ vreg>> _ member? ] filter
+    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+    >>regs drop ;
+
+: init-assignment ( live-intervals -- )
+    V{ } clone active-intervals set
+    <min-heap> unhandled-intervals set
+    init-unhandled ;
+
+: assign-registers ( insns live-intervals -- insns' )
+    [
+        init-assignment
+        [
+            [ activate-new-intervals ]
+            [ drop [ (assign-registers) ] [ , ] bi ]
+            [ expire-old-intervals ]
+            tri
+        ] each-index
+    ] { } make ;

unfinished/compiler/cfg/linear-scan/debugger/debugger.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences sets arrays
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation ;
+IN: compiler.cfg.linear-scan.debugger
+
+: check-assigned ( live-intervals -- )
+    [
+        reg>>
+        [ "Not all intervals have registers" throw ] unless
+    ] each ;
+
+: split-children ( live-interval -- seq )
+    dup split-before>> [
+        [ split-before>> ] [ split-after>> ] bi
+        [ split-children ] bi@
+        append
+    ] [ 1array ] if ;
+
+: check-linear-scan ( live-intervals machine-registers -- )
+    [ [ clone ] map ] dip allocate-registers
+    [ split-children ] map concat check-assigned ;

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

@@ -0,0 +1,100 @@
+IN: compiler.cfg.linear-scan.tests
+USING: tools.test random sorting sequences sets hashtables assocs
+kernel fry arrays splitting namespaces math accessors vectors
+math.order
+compiler.cfg.registers
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.debugger ;
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+    }
+    H{ { f { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
+    }
+    H{ { f { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
+    }
+    H{ { f { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
+    }
+    H{ { f { "A" } } }
+    check-linear-scan
+] unit-test
+
+[
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
+    }
+    H{ { f { "A" } } }
+    check-linear-scan
+] must-fail
+
+SYMBOL: available
+
+SYMBOL: taken
+
+SYMBOL: max-registers
+
+SYMBOL: max-insns
+
+SYMBOL: max-uses
+
+: not-taken ( -- n )
+    available get keys dup empty? [ "Oops" throw ] when
+    random
+    dup taken get nth 1 + max-registers get = [
+        dup available get delete-at
+    ] [
+        dup taken get [ 1 + ] change-nth
+    ] if ;
+
+: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
+    [
+        max-insns set
+        max-registers set
+        max-uses set
+        max-insns get [ 0 ] replicate taken set
+        max-insns get [ dup ] H{ } map>assoc available set
+        [
+            live-interval new
+                swap f swap vreg boa >>vreg
+                max-uses get random 2 max [ not-taken ] replicate natural-sort
+                unclip [ >vector >>uses ] [ >>start ] bi*
+                dup uses>> first >>end
+        ] map
+    ] with-scope ;
+
+: random-test ( num-intervals max-uses max-registers max-insns -- )
+    over >r random-live-intervals r> f associate check-linear-scan ;
+
+[ ] [ 30 2 1 60 random-test ] unit-test
+[ ] [ 60 2 2 60 random-test ] unit-test
+[ ] [ 80 2 3 200 random-test ] unit-test
+[ ] [ 70 2 5 30 random-test ] unit-test
+[ ] [ 60 2 6 30 random-test ] unit-test
+[ ] [ 1 2 10 10 random-test ] unit-test
+
+[ ] [ 10 4 2 60 random-test ] unit-test
+[ ] [ 10 20 2 400 random-test ] unit-test
+[ ] [ 10 20 4 300 random-test ] unit-test

unfinished/compiler/cfg/linear-scan/linear-scan.factor

@@ -1,6 +1,19 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors
+compiler.backend
+compiler.cfg
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.assignment ;
 IN: compiler.cfg.linear-scan
 
 ! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
 
+: linear-scan ( mr -- mr' )
+    [
+        dup compute-live-intervals
+        machine-registers allocate-registers
+        assign-registers
+    ] change-instructions ;

unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -1,32 +1,49 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math
+USING: namespaces kernel assocs accessors sequences math fry
-math.order sorting compiler.instructions compiler.registers ;
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.linear-scan.live-intervals
 
-TUPLE: live-interval < identity-tuple vreg start end ;
+TUPLE: live-interval < identity-tuple
+vreg
+reg spill-to reload-from split-before split-after
+start end uses ;
 
-M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ;
+: <live-interval> ( start vreg -- live-interval )
+    live-interval new
+        swap >>vreg
+        swap >>start
+        V{ } clone >>uses ;
+
+M: live-interval hashcode*
+    nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+M: live-interval clone
+    call-next-method [ clone ] change-uses ;
 
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
-: update-live-interval ( n vreg -- )
+: add-use ( n vreg live-intervals -- )
-    >vreg
+    at [ (>>end) ] [ uses>> push ] 2bi ;
+
+: new-live-interval ( n vreg live-intervals -- )
+    2dup key? [ "Multiple defs" throw ] when
+    [ [ <live-interval> ] keep ] dip set-at ;
+
+: compute-live-intervals* ( insn n -- )
     live-intervals get
-    [ over f live-interval boa ] cache
+    [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
-    (>>end) ;
+    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    3bi ;
 
-: compute-live-intervals* ( n insn -- )
+: finalize-live-intervals ( assoc -- seq' )
-    uses-vregs [ update-live-interval ] with each ;
+    #! Reverse uses lists so that we can pop values off.
-
+    values dup [ uses>> reverse-here ] each ;
-: sort-live-intervals ( assoc -- seq' )
-    #! Sort by increasing start location.
-    values [ [ start>> ] compare ] sort ;
 
 : compute-live-intervals ( instructions -- live-intervals )
     H{ } clone [
         live-intervals [
-            [ swap compute-live-intervals* ] each-index
+            [ compute-live-intervals* ] each-index
         ] with-variable
-    ] keep sort-live-intervals ;
+    ] keep finalize-live-intervals ;

unfinished/compiler/cfg/linearization/linearization.factor

@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators compiler.cfg compiler.cfg.rpo compiler.instructions
+combinators
-compiler.instructions.syntax ;
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
@@ -53,7 +56,7 @@ M: %branch linearize-insn
     dup successors>> first2 swap label>> ; inline
 
 : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
-    [ conditional ] [ vreg>> ] bi* swap ; inline
+    [ conditional ] [ src>> ] bi* swap ; inline
 
 M: %branch-f linearize-insn
     boolean-conditional _branch-f emit-branch ;
@@ -70,10 +73,10 @@ M: %boolean-intrinsic linearize-insn
         "false" define-label
         "end" define-label
         "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
-        t over out>> %load-literal
+        dup dst>> t %load-literal
         "end" get _branch
         "false" resolve-label
-        f over out>> %load-literal
+        dup dst>> f %load-literal
         "end" resolve-label
     ] with-scope
     2drop ;

unfinished/compiler/cfg/registers/registers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces math kernel ;
-IN: compiler.registers
+IN: compiler.cfg.registers
 
 ! Virtual CPU registers, used by CFG and machine IRs
 

unfinished/compiler/cfg/rpo/rpo.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make math sequences
-compiler.instructions ;
+compiler.cfg.instructions ;
 IN: compiler.cfg.rpo
 
 : post-order-traversal ( basic-block -- )

unfinished/compiler/cfg/stacks/stacks.factor

@@ -3,8 +3,8 @@
 USING: arrays assocs classes classes.private classes.algebra
 combinators hashtables kernel layouts math fry namespaces
 quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order compiler.instructions
+byte-arrays accessors sets math.order compiler.cfg.instructions
-compiler.registers ;
+compiler.cfg.registers ;
 IN: compiler.cfg.stacks
 
 ! Converting stack operations into register operations, while
@@ -127,7 +127,7 @@ M: constant move-spec class ;
         { { f unboxed-c-ptr } [ %move-bug ] }
         { { f unboxed-byte-array } [ %move-bug ] }
 
-        { { f constant } [ value>> swap %load-literal ] }
+        { { f constant } [ value>> %load-literal ] }
 
         { { f float } [ %box-float ] }
         { { f unboxed-alien } [ %box-alien ] }

unfinished/compiler/cfg/templates/templates.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.instructions
+quotations combinators classes.algebra compiler.cfg.instructions
-compiler.registers compiler.cfg.stacks ;
+compiler.cfg.registers compiler.cfg.stacks ;
 IN: compiler.cfg.templates
 
 USE: qualified