[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
+ [ ##fixnum-add-tail? ]
+ [ ##fixnum-sub-tail? ]
+ [ ##fixnum-mul-tail? ]
[ ##call? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
-: next-intersection ( new inactive -- n )
- 2drop 0 ;
+: relevant-ranges ( new inactive -- new' inactive' )
+ ! Slice off all ranges of 'inactive' that precede the start of 'new'
+ [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+ 2dup [ from>> ] bi@ > [ swap ] when
+ 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+ {
+ { [ over empty? ] [ 2drop 1/0. ] }
+ { [ dup empty? ] [ 2drop 1/0. ] }
+ [
+ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+ drop
+ 2dup [ first from>> ] bi@ <
+ [ [ rest-slice ] dip ] [ rest-slice ] if
+ intersect-live-ranges
+ ] if
+ ]
+ } cond ;
+
+: intersect-inactive ( new inactive -- n )
+ relevant-ranges intersect-live-ranges ;
: intersecting-inactive ( new -- live-intervals )
dup vreg>> inactive-intervals-for
- [ tuck next-intersection ] with { } map>assoc ;
+ [ tuck intersect-inactive ] with { } map>assoc ;
: fits-in-hole ( new pair -- )
first reuse-register ;
: split-before-use ( new pair -- before after )
! Find optimal split position
+ ! Insert move instruction
second split-interval ;
: assign-inactive-register ( new live-intervals -- )
] if ;
! Main loop
-: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
+CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators
+fry make combinators sets
cpu.architecture
compiler.cfg.def-use
compiler.cfg.registers
compiler.cfg.instructions
+compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
+! Mapping spill slots to vregs
+SYMBOL: spill-slots
+
+: spill-slots-for ( vreg -- assoc )
+ reg-class>> spill-slots get at ;
+
+: record-spill ( live-interval -- )
+ [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
+ 2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ;
+
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
- dup [ _spill ] [ 3drop ] if ;
+ [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+
+: handle-spill ( live-interval -- )
+ dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: expire-old-intervals ( n -- )
active-intervals get
[ swap '[ end>> _ = ] partition ] change-seq drop
- [ insert-spill ] each ;
+ [ handle-spill ] each ;
+
+: record-reload ( live-interval -- )
+ [ reload-from>> ] [ vreg>> spill-slots-for ] bi
+ 2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
- dup [ _reload ] [ 3drop ] if ;
+ [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+
+: handle-reload ( live-interval -- )
+ dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] 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
+ heap-pop drop
+ [ add-active ] [ handle-reload ] bi
activate-new-intervals
] [ 2drop ] if
] if ;
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-spill-slots ( -- spill-slots )
- unhandled-intervals get
- heap-values [ reload-from>> ] filter
+ spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after
: init-assignment ( live-intervals -- )
<active-intervals> active-intervals set
<min-heap> unhandled-intervals set
+ [ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
: assign-registers-in-block ( bb -- )
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
+
+! Spill slot liveness was computed incorrectly, leading to a FEP
+! early in bootstrap on x86-32
+[ t ] [
+ T{ basic-block
+ { instructions
+ V{
+ T{ ##gc f V int-regs 6 V int-regs 7 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 4 }
+ T{ ##peek f V int-regs 5 D 5 }
+ T{ ##replace f V int-regs 0 D 1 }
+ T{ ##replace f V int-regs 1 D 2 }
+ T{ ##replace f V int-regs 2 D 3 }
+ T{ ##replace f V int-regs 3 D 4 }
+ T{ ##replace f V int-regs 4 D 5 }
+ T{ ##replace f V int-regs 5 D 0 }
+ }
+ }
+ } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+ instructions>> first live-spill-slots>> empty?
+] unit-test
+
+[ f ] [
+ T{ live-range f 0 10 }
+ T{ live-range f 20 30 }
+ intersect-live-range
+] unit-test
+
+[ 10 ] [
+ T{ live-range f 0 10 }
+ T{ live-range f 10 30 }
+ intersect-live-range
+] unit-test
+
+[ 5 ] [
+ T{ live-range f 0 10 }
+ T{ live-range f 5 30 }
+ intersect-live-range
+] unit-test
+
+[ 5 ] [
+ T{ live-range f 5 30 }
+ T{ live-range f 0 10 }
+ intersect-live-range
+] unit-test
+
+[ 5 ] [
+ T{ live-range f 5 10 }
+ T{ live-range f 0 15 }
+ intersect-live-range
+] unit-test
+
+[ 50 ] [
+ {
+ T{ live-range f 0 10 }
+ T{ live-range f 20 30 }
+ T{ live-range f 40 50 }
+ }
+ {
+ T{ live-range f 11 15 }
+ T{ live-range f 31 35 }
+ T{ live-range f 50 55 }
+ }
+ intersect-live-ranges
+] unit-test
+
+[ 5 ] [
+ T{ live-interval
+ { start 0 }
+ { end 10 }
+ { uses { 0 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ }
+ T{ live-interval
+ { start 5 }
+ { end 10 }
+ { uses { 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
+ }
+ intersect-inactive
+] unit-test
\ No newline at end of file
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-: (linear-scan) ( rpo -- )
- dup number-instructions
- dup compute-live-intervals
- machine-registers allocate-registers assign-registers ;
+: (linear-scan) ( rpo machine-registers -- )
+ [
+ dup number-instructions
+ dup compute-live-intervals
+ ] dip
+ allocate-registers assign-registers ;
: linear-scan ( cfg -- cfg' )
[
- dup reverse-post-order (linear-scan)
+ dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] with-scope ;
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
-compiler.cfg.phi-elimination ;
+compiler.cfg.phi-elimination
+compiler.cfg.checker ;
IN: compiler.cfg.optimizer
+SYMBOL: check-optimizer?
+
+: ?check ( cfg -- cfg' )
+ check-optimizer? get [
+ dup check-cfg
+ ] when ;
+
: optimize-cfg ( cfg -- cfg' )
[
compute-predecessors
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
+ ?check
] with-scope ;
] each
compile-queue get compile-loop
compiled get >alist
- ] with-scope ;
+ ] with-scope
+ "trace-compilation" get [ "--- compile done" print flush ] when ;
: with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
] [ drop ] if ;
: only-use-vocabs ( vocabs -- )
- clear-manifest [ vocab ] filter [ use-vocab ] each ;
+ clear-manifest
+ [ vocab ] filter
+ [ vocab source-loaded?>> +done+ eq? ] filter
+ [ use-vocab ] each ;
TUPLE: qualified vocab prefix words ;