steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing register allocator prspilling

db4
Slava Pestov 2008-10-19 01:10:21 -05:00
parent b3f30fb807
commit c0d89b061e
17 changed files with 519 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/compiler/cfg/builder/builder.factor
View File

@ -329,8 +329,7 @@ M: #terminate emit-node
stack-frame new stack-frame new
swap swap
[ return>> return-size >>return ] [ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi [ alien-parameters parameter-sizes drop >>params ] bi ;
dup [ params>> ] [ return>> ] bi + >>size ;
: alien-stack-frame ( params -- ) : alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ; <alien-stack-frame> ##stack-frame ;

4
basis/compiler/cfg/cfg.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ; USING: kernel arrays accessors namespaces assocs sequences sets fry ;
IN: compiler.cfg IN: compiler.cfg
TUPLE: cfg entry word label ; TUPLE: cfg entry word label ;
@ -19,7 +19,7 @@ successors ;
V{ } clone >>instructions V{ } clone >>instructions
V{ } clone >>successors ; V{ } clone >>successors ;
TUPLE: mr instructions word label ; TUPLE: mr { instructions array } word label spill-counts ;
: <mr> ( instructions word label -- mr ) : <mr> ( instructions word label -- mr )
mr new mr new

4
basis/compiler/cfg/debugger/debugger.factor
View File

@ -4,7 +4,7 @@ USING: kernel words sequences quotations namespaces io
accessors prettyprint prettyprint.config accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame ; compiler.cfg.stack-frame compiler.cfg.linear-scan ;
IN: compiler.cfg.debugger IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs ) GENERIC: test-cfg ( quot -- cfgs )
@ -16,7 +16,7 @@ M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ; [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) : test-mr ( quot -- mrs )
test-cfg [ build-mr build-stack-frame ] map ; test-cfg [ build-mr ] map ;
: mr. ( mrs -- ) : mr. ( mrs -- )
[ [

14
basis/compiler/cfg/instructions/instructions.factor
View File

@ -19,10 +19,10 @@ INSN: ##inc-r { n integer } ;
! Subroutine calls ! Subroutine calls
TUPLE: stack-frame TUPLE: stack-frame
{ size integer }
{ params integer } { params integer }
{ return integer } { return integer }
{ total-size integer } ; { total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ; INSN: ##stack-frame stack-frame ;
: ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ; : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
@ -125,8 +125,8 @@ M: _cond-branch uses-vregs src>> 1array ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ; M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ; M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
INSN: _spill-integer { src vreg } n ; ! These instructions operate on machine registers and not
INSN: _reload-integer { dst vreg } n ; ! virtual registers
INSN: _spill src class n ;
INSN: _spill-float { src vreg } n ; INSN: _reload dst class n ;
INSN: _reload-float { dst vreg } n ; INSN: _spill-counts counts ;

103
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps cpu.architecture accessors vectors fry heaps cpu.architecture combinators
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
@ -24,25 +24,11 @@ SYMBOL: active-intervals
: delete-active ( live-interval -- ) : delete-active ( live-interval -- )
active-intervals get delete ; active-intervals get delete ;
: expired-interval? ( n interval -- ? )
[ end>> ] [ start>> ] bi or > ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get active-intervals get
[ expired-interval? ] with partition [ end>> > ] with partition
[ [ deallocate-register ] each ] [ active-intervals set ] bi* ; [ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
: expire-old-uses ( n -- )
active-intervals get
swap '[
uses>> [
dup peek _ < [ pop* ] [ drop ] if
] unless-empty
] each ;
: update-state ( live-interval -- )
start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
@ -64,8 +50,25 @@ SYMBOL: progress
[ [ start>> ] keep ] { } map>assoc [ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ; unhandled-intervals get heap-push-all ;
: assign-free-register ( live-interval registers -- ) ! Splitting
pop >>reg add-active ; : find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: split-before ( live-interval i -- before )
[ clone dup uses>> ] dip
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-after ( live-interval i -- after )
[ clone dup uses>> ] dip
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg ;
: split-interval ( live-interval n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi
[ split-before ] [ split-after ] 2bi ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
! Spilling ! Spilling
SYMBOL: spill-counts SYMBOL: spill-counts
@ -73,37 +76,20 @@ SYMBOL: spill-counts
: next-spill-location ( reg-class -- n ) : next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ; spill-counts get [ dup 1+ ] change-at ;
: interval-to-spill ( -- live-interval ) : interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location. #! We spill the interval with the most distant use location.
active-intervals get start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
[ uses>> empty? not ] filter unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
unclip-slice [
[ [ uses>> peek ] bi@ > ] most
] reduce ;
: check-split ( live-interval -- )
[ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
: 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 ) : assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location. #! If it has been spilled already, reuse spill location.
USE: cpu.architecture ! XXX
over reload-from>> over reload-from>>
[ int-regs next-spill-location ] unless* [ over vreg>> reg-class>> next-spill-location ] unless*
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ; tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
: split-and-spill ( live-interval -- before after ) : split-and-spill ( new existing -- before after )
dup split-interval [ record-split ] [ assign-spill ] 2bi ; dup rot start>> split-interval
[ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- ) : reuse-register ( new existing -- )
reg>> >>reg add-active ; reg>> >>reg add-active ;
@ -114,30 +100,30 @@ SYMBOL: spill-counts
#! interval, then process the new interval and the tail end #! interval, then process the new interval and the tail end
#! of the existing interval again. #! of the existing interval again.
[ reuse-register ] [ reuse-register ]
[ delete-active ] [ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ; [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- ) : spill-new ( new existing -- )
#! Our new interval will be used after the active interval #! Our new interval will be used after the active interval
#! with the most distant use location. Split the new #! with the most distant use location. Split the new
#! interval, then process both parts of the new interval #! interval, then process both parts of the new interval
#! again. #! again.
[ split-and-spill add-unhandled ] dip spill-existing ; [ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? ) : spill-existing? ( new existing -- ? )
over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ; #! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( live-interval -- ) : assign-blocked-register ( new -- )
interval-to-spill [ active-intervals get ] keep interval-to-spill
2dup spill-existing? 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
[ spill-existing ] [ spill-new ] if ;
: assign-register ( live-interval -- ) : assign-free-register ( new registers -- )
dup vreg>> free-registers-for [ pop >>reg add-active ;
assign-blocked-register
] [ : assign-register ( new -- )
assign-free-register dup vreg>> free-registers-for
] if-empty ; [ assign-blocked-register ] [ assign-free-register ] if-empty ;
! Main loop ! Main loop
: init-allocator ( registers -- ) : init-allocator ( registers -- )
@ -148,7 +134,10 @@ SYMBOL: spill-counts
-1 progress set ; -1 progress set ;
: handle-interval ( live-interval -- ) : handle-interval ( live-interval -- )
[ start>> progress set ] [ update-state ] [ assign-register ] tri ; [ start>> progress set ]
[ start>> expire-old-intervals ]
[ assign-register ]
tri ;
: (allocate-registers) ( -- ) : (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ; unhandled-intervals get [ handle-interval ] slurp-heap ;

18
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -35,13 +35,8 @@ SYMBOL: unhandled-intervals
[ add-unhandled ] each ; [ add-unhandled ] each ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
[ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
over [ dup [ _spill ] [ 3drop ] if ;
{
{ int-regs [ _spill-integer ] }
{ double-float-regs [ _spill-float ] }
} case
] [ 3drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get active-intervals get
@ -50,13 +45,8 @@ SYMBOL: unhandled-intervals
[ insert-spill ] each ; [ insert-spill ] each ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
[ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
over [ dup [ _reload ] [ 3drop ] if ;
{
{ int-regs [ _reload-integer ] }
{ double-float-regs [ _reload-float ] }
} case
] [ 3drop ] if ;
: activate-new-intervals ( n -- ) : activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction #! Any live intervals which start on the current instruction

222
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -7,49 +7,209 @@ compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.debugger ; compiler.cfg.linear-scan.debugger ;
[ 7 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 7 10 } }
}
4 [ >= ] find-use nip
] unit-test
[ 4 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
4 [ >= ] find-use nip
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
100 [ >= ] find-use nip
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
} 2 split-interval
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 0 }
{ uses V{ 0 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
} 0 split-interval
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
interval-to-spill
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 20 } }
}
spill-existing?
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
} }
H{ { f { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
] unit-test ] unit-test
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } } T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } } T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
} }
H{ { f { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
] unit-test ] unit-test
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } } T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
} }
H{ { f { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
] unit-test ] unit-test
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } } T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
} }
H{ { f { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
] unit-test ] unit-test
[ [
{ {
T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } } T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
} }
H{ { f { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
] must-fail ] must-fail
@ -81,15 +241,15 @@ SYMBOL: max-uses
max-insns get [ dup ] H{ } map>assoc available set max-insns get [ dup ] H{ } map>assoc available set
[ [
live-interval new live-interval new
swap f swap vreg boa >>vreg swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort max-uses get random 2 max [ not-taken ] replicate natural-sort
unclip [ >vector >>uses ] [ >>start ] bi* [ >>uses ] [ first >>start ] bi
dup uses>> first >>end dup uses>> peek >>end
] map ] map
] with-scope ; ] with-scope ;
: random-test ( num-intervals max-uses max-registers max-insns -- ) : random-test ( num-intervals max-uses max-registers max-insns -- )
over >r random-live-intervals r> f associate check-linear-scan ; over >r random-live-intervals r> int-regs associate check-linear-scan ;
[ ] [ 30 2 1 60 random-test ] unit-test [ ] [ 30 2 1 60 random-test ] unit-test
[ ] [ 60 2 2 60 random-test ] unit-test [ ] [ 60 2 2 60 random-test ] unit-test
@ -118,3 +278,29 @@ USING: math.private compiler.cfg.debugger ;
} clone } clone
1array (linear-scan) first regs>> values all-equal? 1array (linear-scan) first regs>> values all-equal?
] unit-test ] unit-test
[ 0 1 ] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 3 }
{ end 4 }
{ uses V{ 3 4 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 2 }
{ end 6 }
{ uses V{ 2 4 6 } }
}
} [ clone ] map
H{ { int-regs { "A" "B" } } }
allocate-registers
first split-before>> [ start>> ] [ end>> ] bi
] unit-test

11
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces USING: kernel accessors namespaces make
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ; compiler.cfg.linear-scan.assignment ;
@ -28,6 +29,10 @@ IN: compiler.cfg.linear-scan
: linear-scan ( mr -- mr' ) : linear-scan ( mr -- mr' )
[ [
[ (linear-scan) ] change-instructions [
! spill-counts get >>spill-counts [
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
] with-scope ; ] with-scope ;

21
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -4,16 +4,20 @@ USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers ; compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.linear-scan.live-intervals IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval < identity-tuple TUPLE: live-interval
vreg vreg
reg spill-to reload-from split-before split-after reg spill-to reload-from split-before split-after
start end uses ; start end uses ;
: add-use ( n live-interval -- )
[ (>>end) ] [ uses>> push ] 2bi ;
: <live-interval> ( start vreg -- live-interval ) : <live-interval> ( start vreg -- live-interval )
live-interval new live-interval new
V{ } clone >>uses
swap >>vreg swap >>vreg
swap >>start over >>start
V{ } clone >>uses ; [ add-use ] keep ;
M: live-interval hashcode* M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ; nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -24,25 +28,18 @@ M: live-interval clone
! Mapping from vreg to live-interval ! Mapping from vreg to live-interval
SYMBOL: live-intervals SYMBOL: live-intervals
: add-use ( n vreg live-intervals -- )
at [ (>>end) ] [ uses>> push ] 2bi ;
: new-live-interval ( n vreg live-intervals -- ) : new-live-interval ( n vreg live-intervals -- )
2dup key? [ "Multiple defs" throw ] when 2dup key? [ "Multiple defs" throw ] when
[ [ <live-interval> ] keep ] dip set-at ; [ [ <live-interval> ] keep ] dip set-at ;
: compute-live-intervals* ( insn n -- ) : compute-live-intervals* ( insn n -- )
live-intervals get live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ] [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3bi ; 3bi ;
: finalize-live-intervals ( assoc -- seq' )
#! Reverse uses lists so that we can pop values off.
values dup [ uses>> reverse-here ] each ;
: compute-live-intervals ( instructions -- live-intervals ) : compute-live-intervals ( instructions -- live-intervals )
H{ } clone [ H{ } clone [
live-intervals set live-intervals set
[ compute-live-intervals* ] each-index [ compute-live-intervals* ] each-index
] keep finalize-live-intervals ; ] keep values ;

29
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences USING: namespaces accessors math.order assocs kernel sequences
combinators make compiler.cfg.instructions combinators make cpu.architecture compiler.cfg.instructions
compiler.cfg.instructions.syntax compiler.cfg.registers ; compiler.cfg.instructions.syntax compiler.cfg.registers ;
IN: compiler.cfg.stack-frame IN: compiler.cfg.stack-frame
@ -9,35 +9,31 @@ SYMBOL: frame-required?
SYMBOL: spill-counts SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
T{ stack-frame } clone stack-frame set ;
GENERIC: compute-stack-frame* ( insn -- ) GENERIC: compute-stack-frame* ( insn -- )
: max-stack-frame ( frame1 frame2 -- frame3 ) : max-stack-frame ( frame1 frame2 -- frame3 )
{ [ stack-frame new ] 2dip
[ [ size>> ] bi@ max ] [ [ params>> ] bi@ max >>params ]
[ [ params>> ] bi@ max ] [ [ return>> ] bi@ max >>return ]
[ [ return>> ] bi@ max ] 2bi ;
[ [ total-size>> ] bi@ max ]
} 2cleave
stack-frame boa ;
M: ##stack-frame compute-stack-frame* M: ##stack-frame compute-stack-frame*
frame-required? on frame-required? on
stack-frame>> stack-frame [ max-stack-frame ] change ; stack-frame>> stack-frame [ max-stack-frame ] change ;
M: _spill-integer compute-stack-frame* M: _spill compute-stack-frame*
drop frame-required? on ; drop frame-required? on ;
M: _spill-float compute-stack-frame* M: _spill-counts compute-stack-frame*
drop frame-required? on ; counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame* drop ; M: insn compute-stack-frame* drop ;
: compute-stack-frame ( insns -- ) : compute-stack-frame ( insns -- )
[ compute-stack-frame* ] each ; frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- ) GENERIC: insert-pro/epilogues* ( insn -- )
@ -56,7 +52,6 @@ M: insn insert-pro/epilogues* , ;
: build-stack-frame ( mr -- mr ) : build-stack-frame ( mr -- mr )
[ [
init-stack-frame-builder
[ [
[ compute-stack-frame ] [ compute-stack-frame ]
[ insert-pro/epilogues ] [ insert-pro/epilogues ]

23
basis/compiler/cfg/value-numbering/expressions/expressions.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions.
TUPLE: expr op ;
! op is always %peek
TUPLE: peek-expr < expr loc ;
TUPLE: unary-expr < expr in ;
TUPLE: load-literal-expr < expr obj ;
GENERIC: >expr ( insn -- expr )
M: ##peek >expr
[ class ] [ loc>> ] bi peek-expr boa ;
M: ##load-literal >expr
[ class ] [ obj>> ] bi load-literal-expr boa ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;

32
basis/compiler/cfg/value-numbering/graph/graph.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.cfg.value-numbering.graph
SYMBOL: vn-counter
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
: vn>expr ( vn -- expr ) exprs>vns get value-at ;
! biassoc mapping vregs to value numbers
SYMBOL: vregs>vns
: vreg>vn ( vreg -- vn ) vregs>vns get at ;
: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
: set-vn ( vn vreg -- ) vregs>vns get set-at ;
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;
: reset-value-graph ( -- )
exprs>vns get clear-assoc
vregs>vns get clear-assoc ;

38
basis/compiler/cfg/value-numbering/liveness/liveness.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.cfg.value-numbering.liveness
! A set of VNs which are (transitively) used by side-effecting
! instructions.
SYMBOL: live-vns
GENERIC: live-expr ( expr -- )
: live-vn ( vn -- )
#! Mark a VN and all VNs used in its computation as live.
dup live-vns get key? [ drop ] [
[ live-vns get conjoin ] [ vn>expr live-expr ] bi
] if ;
M: peek-expr live-expr drop ;
M: unary-expr live-expr in>> live-vn ;
M: load-literal-expr live-expr in>> live-vn ;
: live-vreg ( vreg -- ) vreg>vn live-vn ;
: live? ( vreg -- ? )
dup vreg>vn tuck vn>vreg =
[ live-vns get key? ] [ drop f ] if ;
: init-liveness ( -- )
H{ } clone live-vns set ;
GENERIC: eliminate ( insn -- insn/f )
: (eliminate) ( insn -- insn/f )
dup dst>> >vreg live? [ drop f ] unless ;
M: ##peek eliminate (eliminate) ;
M: ##unary eliminate (eliminate) ;
M: ##load-literal eliminate (eliminate) ;
M: insn eliminate ;

58
basis/compiler/cfg/value-numbering/propagate/propagate.factor Normal file
View File

@ -0,0 +1,58 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.cfg.value-numbering.propagate
! If two vregs compute the same value, replace references to
! the latter with the former.
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
GENERIC: propogate ( insn -- insn )
M: ##cond-branch propagate [ resolve ] change-src ;
M: ##unary propogate [ resolve ] change-src ;
M: ##nullary propagate ;
M: ##replace propagate [ resolve ] change-src ;
M: ##inc-d propagate ;
M: ##inc-r propagate ;
M: ##stack-frame propagate ;
M: ##call propagate ;
M: ##jump propagate ;
M: ##return propagate ;
M: ##intrinsic propagate
[ [ resolve ] assoc-map ] change-defs-vregs
[ [ resolve ] assoc-map ] change-uses-vregs ;
M: ##dispatch propagate [ resolve ] change-src ;
M: ##dispatch-label propagate ;
M: ##write-barrier propagate [ resolve ] change-src ;
M: ##alien-invoke propagate ;
M: ##alien-indirect propagate ;
M: ##alien-callback propagate ;
M: ##callback-return propagate ;
M: ##prologue propagate ;
M: ##epilogue propagate ;
M: ##branch propagate ;
M: ##if-intrinsic propagate
[ [ resolve ] assoc-map ] change-defs-vregs
[ [ resolve ] assoc-map ] change-uses-vregs ;

46
basis/compiler/cfg/value-numbering/value-numbering.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.cfg.value-numbering
: insn>vn ( insn -- vn ) >expr simplify ; inline
GENERIC: make-value-node ( insn -- )
M: ##cond-branch make-value-node src>> live-vreg ;
M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
M: ##nullary make-value-node drop ;
M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
M: ##replace make-value-node reset-value-graph ;
M: ##inc-d make-value-node reset-value-graph ;
M: ##inc-r make-value-node reset-value-graph ;
M: ##stack-frame make-value-node reset-value-graph ;
M: ##call make-value-node reset-value-graph ;
M: ##jump make-value-node reset-value-graph ;
M: ##return make-value-node reset-value-graph ;
M: ##intrinsic make-value-node uses-vregs [ live-vreg ] each ;
M: ##dispatch make-value-node reset-value-graph ;
M: ##dispatch-label make-value-node reset-value-graph ;
M: ##allot make-value-node drop ;
M: ##write-barrier make-value-node drop ;
M: ##gc make-value-node reset-value-graph ;
M: ##replace make-value-node reset-value-graph ;
M: ##alien-invoke make-value-node reset-value-graph ;
M: ##alien-indirect make-value-node reset-value-graph ;
M: ##alien-callback make-value-node reset-value-graph ;
M: ##callback-return make-value-node reset-value-graph ;
M: ##prologue make-value-node reset-value-graph ;
M: ##epilogue make-value-node reset-value-graph ;
M: ##branch make-value-node reset-value-graph ;
M: ##if-intrinsic make-value-node uses-vregs [ live-vreg ] each ;
: init-value-numbering ( -- )
init-value-graph
init-expressions
init-liveness ;
: value-numbering ( instructions -- instructions )
init-value-numbering
[ [ make-value-node ] [ propagate ] bi ] map
[ eliminate ] map
sift ;

20
basis/compiler/codegen/codegen.factor
View File

@ -72,11 +72,7 @@ M: _label generate-insn
id>> lookup-label , ; id>> lookup-label , ;
M: _prologue generate-insn M: _prologue generate-insn
stack-frame>> stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
[ stack-frame set ]
[ dup size>> stack-frame-size >>total-size drop ]
[ total-size>> %prologue ]
tri ;
M: _epilogue generate-insn M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ; stack-frame>> total-size>> %epilogue ;
@ -439,3 +435,17 @@ M: ##alien-callback generate-insn
[ wrap-callback-quot %alien-callback ] [ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ] [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ; tri ;
M: _spill generate-insn
[ src>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %spill-integer ] }
{ double-float-regs [ %spill-float ] }
} case ;
M: _reload generate-insn
[ dst>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %reload-integer ] }
{ double-float-regs [ %reload-float ] }
} case ;
M: _spill-counts generate-insn drop ;

24
basis/compiler/compiler.factor
View File

@ -61,18 +61,6 @@ SYMBOL: +failed+
: frontend ( word -- effect nodes ) : frontend ( word -- effect nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ; [ build-tree-from-word ] [ fail ] recover optimize-tree ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
compiled-xref
] [ drop ] if
] tri ;
! Only switch this off for debugging. ! Only switch this off for debugging.
SYMBOL: compile-dependencies? SYMBOL: compile-dependencies?
@ -92,6 +80,18 @@ t compile-dependencies? set-global
save-asm save-asm
] each ; ] each ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
compiled-xref
] [ drop ] if
] tri ;
: (compile) ( word -- ) : (compile) ( word -- )
'[ '[
_ { _ {