Live interval splitting and spilling

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

@@ -1,6 +1,7 @@
 ! 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

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 } }
+        { 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,8 +1,8 @@
 ! 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.instructions.syntax ;
-IN: compiler.instructions
+IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
@@ -46,14 +46,22 @@ INSN: %alien-invoke params ;
 INSN: %alien-indirect params ;
 INSN: %alien-callback params ;
 
+GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
+M: insn defs-vregs drop f ;
 M: insn uses-vregs drop f ;
-M: %peek uses-vregs vreg>> 1array ;
+
+M: %peek defs-vregs vreg>> 1array ;
+
 M: %replace uses-vregs vreg>> 1array ;
-M: %load-literal uses-vregs vreg>> 1array ;
+
-M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
+M: %load-literal defs-vregs vreg>> 1array ;
-M: %intrinsic uses-vregs vregs>> values ;
+
+M: %unary defs-vregs dst>> 1array ;
+M: %unary uses-vregs src>> 1array ;
+
+! M: %intrinsic uses-vregs vregs>> values ;
 
 ! Instructions used by CFG IR only.
 INSN: %prologue ;
@@ -67,9 +75,13 @@ INSN: %if-intrinsic quot vregs ;
 INSN: %boolean-intrinsic quot vregs out ;
 
 M: %cond-branch uses-vregs vreg>> 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 out>> 1array ;
+
+! M: %boolean-intrinsic uses-vregs
+!     [ vregs>> values ] [ out>> ] bi suffix ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue n ;
@@ -93,4 +105,4 @@ INSN: _branch-t < _cond-branch ;
 INSN: _if-intrinsic label quot vregs ;
 
 M: _cond-branch uses-vregs vreg>> 1array ;
-M: _if-intrinsic uses-vregs vregs>> values ;
+! M: _if-intrinsic uses-vregs vregs>> values ;

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

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
 make parser ;
-IN: compiler.instructions.syntax
+IN: compiler.cfg.instructions.syntax
 
 TUPLE: insn ;
 

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

@@ -1,18 +1,30 @@
 ! 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
+! Vector of live intervals we have already processed
-SYMBOL: register-allocation
+SYMBOL: retired-intervals
 
-! Mapping from vregs to spill locations
+: retire-interval ( live-interval -- )
-SYMBOL: spill-locations
+    retired-intervals get push ;
 
-! Vector of active live intervals, in order of increasing end point
+: retire-intervals ( live-intervals -- )
+    retired-intervals get push-all ;
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+    reg-class>> free-registers get at ;
+
+: 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 +33,156 @@ 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
+    [ [ retire-interval ] [ deallocate-register ] bi ] 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 )
-    interval-to-spill
+    #! Split the live interval at the location of its first use.
-    2dup [ end>> ] bi@ > [
+    #! '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? [
+        [ retire-interval ] [ deallocate-register ] bi
+    ] [ 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 ]
-        [ nip assign-spill ]
+    [ delete-active ]
-        [ [ add-active ] [ delete-active ] bi* ]
+    [
-        2tri
+        split-and-spill
-    ] [ drop assign-spill ] if ;
+        [ retire-interval ]
+        [ add-unhandled ]
+        bi*
+    ] tri ;
 
-: init-allocator ( -- )
+: spill-new ( new existing -- )
-    H{ } clone register-allocation set
+    #! Our new interval will be used after the active interval
-    H{ } clone spill-locations set
+    #! with the most distant use location. Split the new
-    V{ } clone active-intervals set
+    #! interval, then process both parts of the new interval
-    machine-registers [ >vector ] assoc-map free-registers set
+    #! again.
-    0 spill-counter set ;
+    [ split-and-spill add-unhandled ] dip spill-existing ;
 
-: assign-register ( live-interval register -- )
+: spill-existing? ( new existing -- ? )
-    swap vreg>> register-allocation get set-at ;
+    over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
 
-: allocate-register ( live-interval -- )
+: assign-blocked-register ( live-interval -- )
+    interval-to-spill
+    2dup spill-existing?
+    [ spill-existing ] [ spill-new ] if ;
+
+: assign-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
+: slurp-heap ( heap quot: ( elt -- ) -- )
+    over heap-empty? [ 2drop ] [
+        [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
+    ] if ; inline recursive
+
+: init-allocator ( registers -- )
+    V{ } clone retired-intervals set
+    V{ } clone active-intervals set
+    <min-heap> unhandled-intervals set
+    [ >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 ;
+
+: finish-allocator ( -- live-intervals )
+    #! After register allocation is done, we retire all
+    #! live intervals which are still active.
+    active-intervals get retire-intervals
+    retired-intervals get ;
+
+: allocate-registers ( live-intervals machine-registers -- live-intervals' )
+    #! This destroys the input live-intervals.
+    [
         init-allocator
-    [ [ expire-old-intervals ] [ allocate-register ] bi ] each ;
+        init-unhandled
+        (allocate-registers)
+        finish-allocator
+    ] with-scope ;

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

@@ -0,0 +1,38 @@
+! 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 ;
+
+: check-split ( live-intervals -- )
+    [
+        split-before>>
+        [ "Split intervals returned" throw ] when
+    ] each ;
+
+: split-children ( live-interval -- seq )
+    dup split-before>> [
+        [ split-before>> ] [ split-after>> ] bi
+        [ split-children ] bi@
+        append
+    ] [
+        1array
+    ] if ;
+
+: check-retired ( original live-intervals -- )
+    #! All original live intervals should have either been
+    #! split, or ended up in the output set.
+    [ [ split-children ] map concat ] dip
+    2dup subset? [ "We lost some intervals" throw ] unless
+    swap subset? [ "We didn't record all splits" throw ] unless ;
+
+: check-linear-scan ( live-intervals machine-registers -- )
+    [ [ clone ] map dup ] dip allocate-registers
+    [ check-assigned ] [ check-split ] [ check-retired ] tri ;

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/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 >vreg _ add-use ] each ]
-    (>>end) ;
+    [ [ defs-vregs ] 2dip '[ _ swap >vreg _ 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.

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

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