! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
+INSN: _copy dst src class ;
INSN: _spill-counts counts ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps cpu.architecture sorting locals
-combinators compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals hints ;
+USING: accessors assocs heaps kernel namespaces sequences
+compiler.cfg.linear-scan.allocation.coalescing
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-! 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
-
-: active-intervals-for ( vreg -- seq )
- reg-class>> active-intervals get at ;
-
-: add-active ( live-interval -- )
- dup vreg>> active-intervals-for push ;
-
-: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for delq ;
-
-! Vector of inactive live intervals
-SYMBOL: inactive-intervals
-
-: inactive-intervals-for ( vreg -- seq )
- reg-class>> inactive-intervals get at ;
-
-: add-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for push ;
-
-! Vector of handled live intervals
-SYMBOL: handled-intervals
-
-: add-handled ( live-interval -- )
- handled-intervals get push ;
-
-: finished? ( n live-interval -- ? ) end>> swap < ;
-
-: finish ( n live-interval -- keep? )
- nip [ deallocate-register ] [ add-handled ] bi f ;
-
-: activate ( n live-interval -- keep? )
- nip add-active f ;
-
-: deactivate ( n live-interval -- keep? )
- nip add-inactive f ;
-
-: don't-change ( n live-interval -- keep? ) 2drop t ;
-
-! Moving intervals between active and inactive sets
-: process-intervals ( n symbol quots -- )
- ! symbol stores an alist mapping register classes to vectors
- [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
-
-: covers? ( insn# live-interval -- ? )
- ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
-
-: deactivate-intervals ( n -- )
- ! Any active intervals which have ended are moved to handled
- ! Any active intervals which cover the current position
- ! are moved to inactive
- active-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? not ] [ deactivate ] }
- [ don't-change ]
- } process-intervals ;
-
-: activate-intervals ( n -- )
- ! Any inactive intervals which have ended are moved to handled
- ! Any inactive intervals which do not cover the current position
- ! are moved to active
- inactive-intervals {
- { [ 2dup finished? ] [ finish ] }
- { [ 2dup covers? ] [ activate ] }
- [ don't-change ]
- } process-intervals ;
-
-! 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 ;
-
-! Coalescing
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: coalesce? ( live-interval -- ? )
- [ start>> ] [ copy-from>> active-interval ] bi
- dup [ end>> = ] [ 2drop f ] if ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
- [ reg>> >>reg drop ]
- 2bi ;
-
-! Splitting
-: split-range ( live-range n -- before after )
- [ [ from>> ] dip <live-range> ]
- [ 1 + swap to>> <live-range> ]
- 2bi ;
-
-: split-last-range? ( last n -- ? )
- swap to>> <= ;
-
-: split-last-range ( before after last n -- before' after' )
- split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-
-: split-ranges ( live-ranges n -- before after )
- [ '[ from>> _ <= ] partition ]
- [
- pick empty? [ drop ] [
- [ over last ] dip 2dup split-last-range?
- [ split-last-range ] [ 2drop ] if
- ] if
- ] bi ;
-
-: split-uses ( uses n -- before after )
- '[ _ <= ] partition ;
-
-: record-split ( live-interval before after -- )
- [ >>split-before ] [ >>split-after ] bi* drop ; inline
-
-: check-split ( live-interval -- )
- [ end>> ] [ start>> ] bi - 0 =
- [ "BUG: splitting atomic interval" throw ] when ; inline
-
-: split-before ( before -- before' )
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-: split-after ( after -- after' )
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
- [ compute-start/end ]
- [ ]
- tri ; inline
-
-:: split-interval ( live-interval n -- before after )
- live-interval check-split
- live-interval clone :> before
- live-interval clone f >>copy-from f >>reg :> after
- live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
- live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
- live-interval before after record-split
- before split-before
- after split-after ;
-
-HINTS: split-interval live-interval object ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
- spill-counts get [ dup 1+ ] change-at ;
-
-: find-use ( live-interval n quot -- i elt )
- [ uses>> ] 2dip curry find ; inline
-
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
-: 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* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-interval assign-spill ;
-
-: reuse-register ( new existing -- )
- reg>> >>reg add-active ;
-
-: 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 delete-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: 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.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
-
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
-
-: assign-free-register ( new registers -- )
- pop >>reg add-active ;
-
-: 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 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 there is an interval which is inactive for the entire lifetime
- ! if the new interval, reuse its vreg. Otherwise, split new so that
- ! the first half fits.
- sort-values last
- 2dup [ end>> ] [ second ] bi* < [
- fits-in-hole
- ] [
- [ split-before-use ] keep
- '[ _ fits-in-hole ] [ add-unhandled ] bi*
- ] if ;
-
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
if-empty
] if ;
-! Main loop
-CONSTANT: reg-classes { int-regs double-float-regs }
-
-: reg-class-assoc ( quot -- assoc )
- [ reg-classes ] dip { } map>assoc ; inline
-
-: init-allocator ( registers -- )
- [ reverse >vector ] assoc-map free-registers set
- [ 0 ] reg-class-assoc spill-counts set
- <min-heap> unhandled-intervals set
- [ V{ } clone ] reg-class-assoc active-intervals set
- [ V{ } clone ] reg-class-assoc inactive-intervals set
- V{ } clone handled-intervals set
- -1 progress set ;
-
: handle-interval ( live-interval -- )
[
start>>
unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- )
- ! Sanity check: all live intervals should've been processed
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals )
- #! This modifies the input live-intervals.
init-allocator
init-unhandled
(allocate-registers)
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences
+compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.allocation.coalescing
+
+: active-interval ( vreg -- live-interval )
+ dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+
+: coalesce? ( live-interval -- ? )
+ [ start>> ] [ copy-from>> active-interval ] bi
+ dup [ end>> = ] [ 2drop f ] if ;
+
+: coalesce ( live-interval -- )
+ dup copy-from>> active-interval
+ [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
+ [ reg>> >>reg drop ]
+ 2bi ;
--- /dev/null
+! 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.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.spilling
+
+: 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 ;
+
+: find-use ( live-interval n quot -- i elt )
+ [ uses>> ] 2dip curry find ; inline
+
+: interval-to-spill ( active-intervals current -- live-interval )
+ #! We spill the interval with the most distant use location.
+ start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
+
+: 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* ;
+
+: split-and-spill ( new existing -- before after )
+ swap start>> split-for-spill assign-spill ;
+
+: 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 delete-active ]
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
+
+: 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.
+ [ dup split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+ #! Test if 'new' will be used before 'existing'.
+ over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
+
+: assign-blocked-register ( new -- )
+ [ dup vreg>> active-intervals-for ] keep interval-to-spill
+ 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+
--- /dev/null
+! 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.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.splitting
+
+: split-range ( live-range n -- before after )
+ [ [ from>> ] dip <live-range> ]
+ [ 1 + swap to>> <live-range> ]
+ 2bi ;
+
+: split-last-range? ( last n -- ? )
+ swap to>> <= ;
+
+: split-last-range ( before after last n -- before' after' )
+ split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
+
+: split-ranges ( live-ranges n -- before after )
+ [ '[ from>> _ <= ] partition ]
+ [
+ pick empty? [ drop ] [
+ [ over last ] dip 2dup split-last-range?
+ [ split-last-range ] [ 2drop ] if
+ ] if
+ ] bi ;
+
+: split-uses ( uses n -- before after )
+ '[ _ <= ] partition ;
+
+: record-split ( live-interval before after -- )
+ [ >>split-next drop ]
+ [ [ >>split-before ] [ >>split-after ] bi* drop ]
+ 2bi ; inline
+
+ERROR: splitting-atomic-interval ;
+
+: check-split ( live-interval -- )
+ [ end>> ] [ start>> ] bi - 0 =
+ [ splitting-atomic-interval ] when ; inline
+
+: split-before ( before -- before' )
+ f >>spill-to ; inline
+
+: split-after ( after -- after' )
+ f >>copy-from f >>reg f >>reload-from ; inline
+
+:: split-interval ( live-interval n -- before after )
+ live-interval check-split
+ live-interval clone :> before
+ live-interval clone :> after
+ live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
+ live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
+ live-interval before after record-split
+ before split-before
+ after split-after ;
+
+HINTS: split-interval live-interval object ;
+
+: reuse-register ( new existing -- )
+ reg>> >>reg add-active ;
+
+: 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 active-regs -- n )
+ 2dup [ reg>> ] dip key? [
+ 2drop start>>
+ ] [
+ drop relevant-ranges intersect-live-ranges
+ ] if ;
+
+: intersecting-inactive ( new -- live-intervals )
+ dup vreg>>
+ [ inactive-intervals-for ]
+ [ active-intervals-for [ reg>> ] map unique ] bi
+ '[ tuck _ intersect-inactive ] with { } map>assoc ;
+
+: insert-use-for-copy ( seq n -- seq' )
+ [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+
+: split-before-use ( new n -- before after )
+ ! Find optimal split position
+ ! Insert move instruction
+ [ '[ _ insert-use-for-copy ] change-uses ] keep
+ 1 - split-interval
+ 2dup [ compute-start/end ] bi@ ;
+
+: assign-inactive-register ( new live-intervals -- )
+ ! If there is an interval which is inactive for the entire lifetime
+ ! if the new interval, reuse its vreg. Otherwise, split new so that
+ ! the first half fits.
+ sort-values last
+ 2dup [ end>> ] [ second ] bi* < [
+ first reuse-register
+ ] [
+ [ second split-before-use ] keep
+ '[ _ first reuse-register ] [ add-unhandled ] bi*
+ ] if ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators cpu.architecture fry heaps
+kernel math namespaces sequences vectors
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.state
+
+! 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
+
+: active-intervals-for ( vreg -- seq )
+ reg-class>> active-intervals get at ;
+
+: add-active ( live-interval -- )
+ dup vreg>> active-intervals-for push ;
+
+: delete-active ( live-interval -- )
+ dup vreg>> active-intervals-for delq ;
+
+: assign-free-register ( new registers -- )
+ pop >>reg add-active ;
+
+! Vector of inactive live intervals
+SYMBOL: inactive-intervals
+
+: inactive-intervals-for ( vreg -- seq )
+ reg-class>> inactive-intervals get at ;
+
+: add-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for push ;
+
+! Vector of handled live intervals
+SYMBOL: handled-intervals
+
+: add-handled ( live-interval -- )
+ handled-intervals get push ;
+
+: finished? ( n live-interval -- ? ) end>> swap < ;
+
+: finish ( n live-interval -- keep? )
+ nip [ deallocate-register ] [ add-handled ] bi f ;
+
+SYMBOL: check-allocation?
+
+ERROR: register-already-used live-interval ;
+
+: check-activate ( live-interval -- )
+ check-allocation? get [
+ dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+ [ register-already-used ] [ drop ] if
+ ] [ drop ] if ;
+
+: activate ( n live-interval -- keep? )
+ dup check-activate
+ nip add-active f ;
+
+: deactivate ( n live-interval -- keep? )
+ nip add-inactive f ;
+
+: don't-change ( n live-interval -- keep? ) 2drop t ;
+
+! Moving intervals between active and inactive sets
+: process-intervals ( n symbol quots -- )
+ ! symbol stores an alist mapping register classes to vectors
+ [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+
+: deactivate-intervals ( n -- )
+ ! Any active intervals which have ended are moved to handled
+ ! Any active intervals which cover the current position
+ ! are moved to inactive
+ active-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? not ] [ deactivate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+: activate-intervals ( n -- )
+ ! Any inactive intervals which have ended are moved to handled
+ ! Any inactive intervals which do not cover the current position
+ ! are moved to active
+ inactive-intervals {
+ { [ 2dup finished? ] [ finish ] }
+ { [ 2dup covers? ] [ activate ] }
+ [ don't-change ]
+ } process-intervals ;
+
+! 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 ;
+
+CONSTANT: reg-classes { int-regs double-float-regs }
+
+: reg-class-assoc ( quot -- assoc )
+ [ reg-classes ] dip { } map>assoc ; inline
+
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1 + ] change-at ;
+
+: init-allocator ( registers -- )
+ [ reverse >vector ] assoc-map free-registers set
+ [ 0 ] reg-class-assoc spill-counts set
+ <min-heap> unhandled-intervals set
+ [ V{ } clone ] reg-class-assoc active-intervals set
+ [ V{ } clone ] reg-class-assoc inactive-intervals set
+ V{ } clone handled-intervals set
+ -1 progress set ;
+
+: init-unhandled ( live-intervals -- )
+ [ [ start>> ] keep ] { } map>assoc
+ unhandled-intervals get heap-push-all ;
\ No newline at end of file
+++ /dev/null
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
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.
-TUPLE: active-intervals seq ;
+! This contains both active and inactive intervals; any interval
+! such that start <= insn# <= end is in this set.
+SYMBOL: pending-intervals
: add-active ( live-interval -- )
- active-intervals get seq>> push ;
-
-: lookup-register ( vreg -- reg )
- active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
+ pending-intervals get push ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
+ERROR: already-spilled ;
+
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ;
+ 2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+: insert-copy ( live-interval -- )
+ [ split-next>> reg>> ]
+ [ reg>> ]
+ [ vreg>> reg-class>> ]
+ tri _copy ;
+
+: handle-copy ( live-interval -- )
+ dup [ spill-to>> not ] [ split-next>> ] bi and
+ [ insert-copy ] [ drop ] if ;
+
: expire-old-intervals ( n -- )
- active-intervals get
- [ swap '[ end>> _ = ] partition ] change-seq drop
- [ handle-spill ] each ;
+ [ pending-intervals get ] dip '[
+ dup end>> _ <
+ [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
+ ] filter-here ;
+
+ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ;
+ 2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
] [ 2drop ] if
] if ;
-GENERIC: assign-before ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
-GENERIC: assign-after ( insn -- )
+: register-mapping ( live-intervals -- alist )
+ [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-M: vreg-insn assign-before
- active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
- >>regs drop ;
+: active-intervals ( insn -- intervals )
+ insn#>> pending-intervals get [ covers? ] with filter ;
-M: insn assign-before drop ;
+M: vreg-insn assign-registers-in-insn
+ dup [ active-intervals ] [ all-vregs ] bi
+ '[ vreg>> _ member? ] filter
+ register-mapping
+ >>regs drop ;
-: compute-live-registers ( -- regs )
- active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+: compute-live-registers ( insn -- regs )
+ active-intervals register-mapping ;
: compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
-M: ##gc assign-after
- compute-live-registers >>live-registers
+M: ##gc assign-registers-in-insn
+ dup call-next-method
+ dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
-M: insn assign-after drop ;
-
-: <active-intervals> ( -- obj )
- V{ } clone active-intervals boa ;
+M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- )
- <active-intervals> active-intervals set
+ V{ } clone pending-intervals set
<min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
[
[
[
- {
- [ insn#>> activate-new-intervals ]
- [ assign-before ]
- [ , ]
- [ insn#>> expire-old-intervals ]
- [ assign-after ]
- } cleave
+ [
+ insn#>>
+ [ activate-new-intervals ]
+ [ expire-old-intervals ]
+ bi
+ ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ tri
] each
] V{ } make
] change-instructions drop ;
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
-kernel fry arrays splitting namespaces math accessors vectors
+kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
+compiler.cfg.liveness
+compiler.cfg.predecessors
+compiler.cfg.rpo
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
+check-allocation? on
+
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
- } 2 split-interval
+ } 2 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 1 }
+ { end 5 }
+ { uses V{ 1 5 } }
+ { ranges V{ T{ live-range f 1 5 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
+ } 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 } } }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
+ { start 5 }
{ end 5 }
- { uses V{ 1 5 } }
- { ranges V{ T{ live-range f 1 5 } } }
+ { uses V{ 5 } }
+ { ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 0 }
- { end 5 }
- { uses V{ 0 1 5 } }
- { ranges V{ T{ live-range f 0 5 } } }
- } 0 split-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 5 }
+ { uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] 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?
+ [
+ H{ } clone live-ins set
+ H{ } clone live-outs set
+ H{ } clone phi-live-ins set
+ T{ basic-block
+ { id 12345 }
+ { 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?
+ ] with-scope
] unit-test
[ f ] [
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
+ H{ }
intersect-inactive
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Bug in live spill slots calculation
+
+T{ basic-block
+ { id 205651 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 205652 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 703128 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 703129 }
+ { loc D 0 }
+ }
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703128 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703129 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 703128 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 205653 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703129 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703128 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 205655 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 703134 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 703135 }
+ { loc D 1 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 3 set
+
+1 get 1vector 0 get (>>successors)
+2 get 3 get V{ } 2sequence 1 get (>>successors)
+3 get 1vector 2 get (>>successors)
+
+:: test-linear-scan-on-cfg ( regs -- )
+ [ ] [
+ cfg new 0 get >>entry
+ compute-predecessors
+ compute-liveness
+ reverse-post-order
+ { { int-regs regs } } (linear-scan)
+ ] unit-test ;
+
+{ 1 2 } test-linear-scan-on-cfg
+
+! Bug in inactive interval handling
+! [ rot dup [ -rot ] when ]
+T{ basic-block
+ { id 201486 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 201487 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689473 }
+ { loc D 2 }
+ }
+ T{ ##peek
+ { dst V int-regs 689474 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689475 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689473 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 201488 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689474 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689473 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 201489 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689473 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689474 }
+ }
+ T{ ##branch }
+ }
+ }
+} 3 set
+
+T{ basic-block
+ { id 201490 }
+ { number 4 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 689481 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689482 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689483 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 4 set
+
+: test-diamond ( -- )
+ 1 get 1vector 0 get (>>successors)
+ 2 get 3 get V{ } 2sequence 1 get (>>successors)
+ 4 get 1vector 2 get (>>successors)
+ 4 get 1vector 3 get (>>successors) ;
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! Similar to the above
+! [ swap dup [ rot ] when ]
+
+T{ basic-block
+ { id 201537 }
+ { number 0 }
+ { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+ { id 201538 }
+ { number 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689600 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689601 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689600 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 201539 }
+ { number 2 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689604 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689604 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689601 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 201540 }
+ { number 3 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 689609 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689601 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689609 }
+ }
+ T{ ##branch }
+ }
+ }
+} 3 set
+
+T{ basic-block
+ { id 201541 }
+ { number 4 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 689607 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689608 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689610 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+ }
+ }
+} 4 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! compute-live-registers was inaccurate since it didn't take
+! lifetime holes into account
+
+T{ basic-block
+ { id 0 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 0 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 0 }
+ { src2 5 }
+ { cc cc/= }
+ }
+ }
+ }
+} 0 set
+
+T{ basic-block
+ { id 1 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 1 }
+ { loc D 1 }
+ }
+ T{ ##copy
+ { dst V int-regs 2 }
+ { src V int-regs 1 }
+ }
+ T{ ##branch }
+ }
+ }
+} 1 set
+
+T{ basic-block
+ { id 2 }
+ { instructions
+ V{
+ T{ ##peek
+ { dst V int-regs 3 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 2 }
+ { src V int-regs 3 }
+ }
+ T{ ##branch }
+ }
+ }
+} 2 set
+
+T{ basic-block
+ { id 3 }
+ { instructions
+ V{
+ T{ ##replace
+ { src V int-regs 2 }
+ { loc D 0 }
+ }
+ T{ ##return }
+ }
+ }
+} 3 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
\ No newline at end of file
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
TUPLE: live-interval
vreg
-reg spill-to reload-from split-before split-after
+reg spill-to reload-from
+split-before split-after split-next
start end ranges uses
copy-from ;
+: covers? ( insn# live-interval -- ? )
+ ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
+
+: child-interval-at ( insn# interval -- interval' )
+ dup split-after>> [
+ 2dup split-after>> start>> <
+ [ split-before>> ] [ split-after>> ] if
+ child-interval-at
+ ] [ nip ] if ;
+
ERROR: dead-value-error vreg ;
: shorten-range ( n live-interval -- )
V{ } clone >>ranges
swap >>vreg ;
-: block-from ( -- n )
- basic-block get instructions>> first insn#>> ;
+: block-from ( bb -- n ) instructions>> first insn#>> ;
-: block-to ( -- n )
- basic-block get instructions>> last insn#>> ;
+: block-to ( bb -- n ) instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
: handle-input ( n vreg live-intervals -- )
live-interval
- [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
+ [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- )
live-interval
[ call-next-method ] [ record-copy ] bi ;
: handle-live-out ( bb -- )
- live-out keys block-from block-to live-intervals get '[
+ live-out keys
+ basic-block get [ block-from ] [ block-to ] bi
+ live-intervals get '[
[ _ _ ] dip _ live-interval add-range
] each ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math namespaces sequences
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
+IN: compiler.cfg.linear-scan.resolve
+
+: add-mapping ( from to -- )
+ 2drop
+ ;
+
+: resolve-value-data-flow ( bb to vreg -- )
+ live-intervals get at
+ [ [ block-to ] dip child-interval-at ]
+ [ [ block-from ] dip child-interval-at ]
+ bi-curry bi* 2dup = [ 2drop ] [
+ add-mapping
+ ] if ;
+
+: resolve-mappings ( bb to -- )
+ 2drop
+ ;
+
+: resolve-edge-data-flow ( bb to -- )
+ [ 2dup live-in [ resolve-value-data-flow ] with with each ]
+ [ resolve-mappings ]
+ 2bi ;
+
+: resolve-block-data-flow ( bb -- )
+ dup successors>> [
+ resolve-edge-data-flow
+ ] with each ;
+
+: resolve-data-flow ( rpo -- )
+ [ resolve-block-data-flow ] each ;
\ No newline at end of file
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' )
- dup [ predecessors-step ] each-basic-block ;
+ [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+ [ [ predecessors-step ] each-basic-block ]
+ [ ]
+ tri ;
{ double-float-regs [ %reload-float ] }
} case ;
+M: _copy generate-insn
+ [ dst>> ] [ src>> ] [ class>> ] tri {
+ { int-regs [ %copy ] }
+ { double-float-regs [ %copy-float ] }
+ } case ;
+
M: _spill-counts generate-insn drop ;
projects / factor.git / commitdiff