_ add-use-position
] each ;
-: compute-free-pos ( new -- free-pos )
+: register-status ( new -- free-pos )
dup free-positions
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
>alist alist-max ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
- dup compute-free-pos {
+ dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ register-partially-available ]
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting compiler.utilities
+math sequences sets sorting splitting compiler.utilities namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
: find-use ( live-interval n quot -- elt )
[ uses>> ] 2dip curry find nip ; inline
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
-
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use ] { } map>assoc
+ #! If an active interval has no more use positions, find-use
+ #! returns f. This occurs if the interval is a split. In
+ #! this case, we prefer to spill this interval always.
+ start>> '[ dup _ [ >= ] find-use 1/0. or ] { } map>assoc
alist-max first ;
+ERROR: bad-live-ranges interval ;
+
+: check-ranges ( live-interval -- )
+ check-allocation? get [
+ dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
+ [ drop ] [ bad-live-ranges ] if
+ ] [ drop ] if ;
+
+: trim-before-ranges ( live-interval n -- )
+ [ ranges>> ] [ uses>> last ] bi
+ [ '[ from>> _ <= ] filter-here ]
+ [ swap last (>>to) ]
+ 2bi ;
+
+: trim-after-ranges ( live-interval n -- )
+ [ ranges>> ] [ uses>> first ] bi
+ [ '[ to>> _ >= ] filter-here ]
+ [ swap first (>>from) ]
+ 2bi ;
+
: split-for-spill ( live-interval n -- before after )
split-interval
- [
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
- ]
- [ [ compute-start/end ] bi@ ]
- [ ]
- 2tri ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
+ {
+ [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
+ [ [ compute-start/end ] bi@ ]
+ [ [ check-ranges ] bi@ ]
+ [ ]
+ } 2cleave ;
+
+: assign-spill ( live-interval -- live-interval )
+ dup reload-from>>
+ [ dup vreg>> reg-class>> next-spill-location ] unless*
+ >>spill-to ;
+
+: assign-reload ( before after -- before after )
+ over spill-to>> >>reload-from ;
: split-and-spill ( new existing -- before after )
- swap start>> split-for-spill assign-spill ;
+ swap start>> split-for-spill assign-spill assign-reload ;
+
+: reuse-register ( new existing -- )
+ [ nip delete-active ]
+ [ reg>> >>reg add-active ] 2bi ;
+
+: spill-existing? ( new existing -- ? )
+ #! Test if 'new' will be used before 'existing'.
+ over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
: 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.
- [ nip delete-active ]
- [ reg>> >>reg add-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
+ [ reuse-register ]
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2bi ;
+
+: spill-live-out? ( new existing -- ? )
+ [ start>> ] [ uses>> last ] bi* > ;
+
+: spill-live-out ( new existing -- )
+ #! The existing interval is never used again. Spill it and
+ #! re-use the register.
+ assign-spill
+ [ reuse-register ]
+ [ nip add-handled ] 2bi ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+ [ dup vreg>> active-intervals-for ] keep interval-to-spill {
+ { [ 2dup spill-live-out? ] [ spill-live-out ] }
+ { [ 2dup spill-existing? ] [ spill-existing ] }
+ [ spill-new ]
+ } cond ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+: first-split ( live-interval -- live-interval' )
+ dup split-before>> [ first-split ] [ ] ?if ;
+
: next-interval ( live-interval -- live-interval' )
- split-next>> dup split-before>> [ next-interval ] [ ] ?if ;
+ split-next>> first-split ;
: insert-copy ( live-interval -- )
{
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 0 }
+ { uses V{ 0 } }
+ { ranges V{ T{ live-range f 0 0 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 20 }
+ { end 30 }
+ { uses V{ 20 30 } }
+ { ranges V{ T{ live-range f 20 30 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 30 }
+ { uses V{ 0 20 30 } }
+ { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+ } 10 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
relevant-ranges intersect-live-ranges
] unit-test
-! compute-free-pos had problems because it used map>assoc where the sequence
+! register-status had problems because it used map>assoc where the sequence
! had multiple keys
[ { 0 10 } ] [
H{ { int-regs { 0 1 } } } registers set
{ ranges V{ T{ live-range f 8 10 } } }
{ uses V{ 8 10 } }
}
- compute-free-pos
+ register-status
] unit-test
! Bug in live spill slots calculation
SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- )
- [ ] [
- cfg new 0 get >>entry
- compute-predecessors
- compute-liveness
- dup reverse-post-order
- { { int-regs regs } } (linear-scan)
- flatten-cfg 1array mr.
- ] unit-test ;
+ cfg new 0 get >>entry
+ compute-predecessors
+ compute-liveness
+ dup reverse-post-order
+ { { int-regs regs } } (linear-scan)
+ flatten-cfg 1array mr. ;
! This test has a critical edge -- do we care about these?
-! { 1 2 } test-linear-scan-on-cfg
+! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Similar to the above
! [ swap dup [ rot ] when ]
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
USING: classes ;
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
[ _spill ] [ 2 get instructions>> first class ] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
-binary-search combinators compiler.cfg.instructions compiler.cfg.registers
+combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
}
[ f ] [
- 0 get test-live-interval-1 spill-to
+ test-live-interval-1 0 get spill-to
] unit-test
[ 0 ] [
- 1 get test-live-interval-1 spill-to
+ test-live-interval-1 1 get spill-to
] unit-test
CONSTANT: test-live-interval-2
}
[ 0 ] [
- 0 get test-live-interval-2 reload-from
+ test-live-interval-2 0 get reload-from
] unit-test
[ f ] [
- 1 get test-live-interval-2 reload-from
+ test-live-interval-2 1 get reload-from
] unit-test
[
] unit-test
[
- { T{ _spill { src 4 } { class int-regs } { n spill-temp } } }
+ {
+ T{ _spill { src 3 } { class int-regs } { n 4 } }
+ T{ _reload { dst 2 } { class int-regs } { n 1 } }
+ }
] [
{
- T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+ T{ register->memory { from 3 } { to 4 } { reg-class int-regs } }
+ T{ memory->register { from 1 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
>>
-: reload-from ( bb live-interval -- n/f )
- 2dup [ block-from ] [ start>> ] bi* =
- [ nip reload-from>> ] [ 2drop f ] if ;
+: insn-in-block? ( insn# bb -- ? )
+ [ block-from ] [ block-to ] bi between? ;
-: spill-to ( bb live-interval -- n/f )
- 2dup [ block-to ] [ end>> ] bi* =
- [ nip spill-to>> ] [ 2drop f ] if ;
+: reload-from ( live-interval bb -- n/f )
+ 2dup [ start>> ] dip insn-in-block?
+ [ drop reload-from>> ] [ 2drop f ] if ;
+
+: spill-to ( live-interval bb -- n/f )
+ 2dup [ end>> ] dip insn-in-block?
+ [ drop spill-to>> ] [ 2drop f ] if ;
OPERATION: memory->memory spill-to>> reload-from>>
OPERATION: register->memory reg>> reload-from>>
OPERATION: register->register reg>> reg>>
:: add-mapping ( bb1 bb2 li1 li2 -- )
- bb2 li2 reload-from [
- bb1 li1 spill-to
+ li2 bb2 reload-from [
+ li1 bb1 spill-to
[ li1 li2 memory->memory ]
[ li1 li2 register->memory ] if
] [
- bb1 li1 spill-to
+ li1 bb1 spill-to
[ li1 li2 memory->register ]
[ li1 li2 register->register ] if
] if ;
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
M: register->memory >insn
- [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
+ [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
M: memory->register >insn
- [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
+ [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
M: register->memory >collision-table
- [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
+ [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
M: memory->register >collision-table
- [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
+ [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
M: register->register >collision-table
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
projects / factor.git / commitdiff