-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals arrays
-cpu.architecture
-compiler.cfg
-compiler.cfg.def-use
-compiler.cfg.liveness
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.renaming.functor
-compiler.cfg.linearization.order
-compiler.cfg.linear-scan.allocation
-compiler.cfg.linear-scan.allocation.state
-compiler.cfg.linear-scan.live-intervals ;
+USING: accessors arrays assocs combinators compiler.cfg
+compiler.cfg.linearization compiler.cfg.liveness compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.live-intervals compiler.cfg.renaming.functor
+compiler.cfg.ssa.destruction.leaders cpu.architecture
+fry heaps kernel make math namespaces sequences sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.assignment
! This contains both active and inactive intervals; any interval
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
-: (vreg>reg) ( vreg pending -- reg )
- ! If a live vreg is not in the pending set, then it must
- ! have been spilled.
- ?at [ spill-slots get at <spill-slot> ] unless ;
+: vreg>reg ( vreg -- reg/spill-slot )
+ dup leader dup pending-interval-assoc get at
+ [ 2nip ] [ swap rep-of lookup-spill-slot ] if* ;
-: vreg>reg ( vreg -- reg )
- pending-interval-assoc get (vreg>reg) ;
+ERROR: not-spilled-error vreg ;
+
+: vreg>spill-slot ( vreg -- spill-slot )
+ dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
: vregs>regs ( vregs -- assoc )
- dup assoc-empty? [
- pending-interval-assoc get
- '[ _ (vreg>reg) ] assoc-map
- ] unless ;
+ [ dup vreg>reg ] H{ } map>assoc ;
-! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
-: add-unhandled ( live-interval -- )
- dup start>> unhandled-intervals get heap-push ;
+SYMBOL: machine-live-ins
-: init-unhandled ( live-intervals -- )
- [ add-unhandled ] each ;
+: machine-live-in ( bb -- assoc )
+ machine-live-ins get at ;
-! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+: compute-live-in ( bb -- )
+ [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
-! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-edge-live-ins
-: init-assignment ( live-intervals -- )
- <min-heap> pending-interval-heap set
- H{ } clone pending-interval-assoc set
- <min-heap> unhandled-intervals set
- H{ } clone register-live-ins set
- H{ } clone register-live-outs set
- init-unhandled ;
+: machine-edge-live-in ( predecessor bb -- assoc )
+ machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+ [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+ machine-edge-live-ins get set-at ;
+
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+ machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+ [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
+
+: heap-pop-while ( heap quot: ( key -- ? ) -- values )
+ '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
+ [ over heap-pop* ] produce 2nip ; inline
: insert-spill ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
+ [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
: expire-interval ( live-interval -- )
[ remove-pending ] [ handle-spill ] bi ;
-: (expire-old-intervals) ( n heap -- )
- dup heap-empty? [ 2drop ] [
- 2dup heap-peek nip <= [ 2drop ] [
- dup heap-pop drop expire-interval
- (expire-old-intervals)
- ] if
- ] if ;
-
: expire-old-intervals ( n -- )
- pending-interval-heap get (expire-old-intervals) ;
+ pending-interval-heap get swap '[ _ < ] heap-pop-while
+ [ expire-interval ] each ;
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
+ [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-interval ( live-interval -- )
[ add-pending ] [ handle-reload ] bi ;
-: (activate-new-intervals) ( n heap -- )
- dup heap-empty? [ 2drop ] [
- 2dup heap-peek nip = [
- dup heap-pop drop activate-interval
- (activate-new-intervals)
- ] [ 2drop ] if
- ] if ;
-
: activate-new-intervals ( n -- )
- unhandled-intervals get (activate-new-intervals) ;
+ unhandled-intervals get swap '[ _ = ] heap-pop-while
+ [ activate-interval ] each ;
: prepare-insn ( n -- )
[ expire-old-intervals ] [ activate-new-intervals ] bi ;
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-! TODO: needs tagged-rep
-
-: trace-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain tagged data
- ! are traced by the GC. Outputs a sequence physical registers.
- [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
+: assign-gc-roots ( gc-map -- )
+ [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
-: spill-on-gc? ( vreg reg -- ? )
- [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
+: assign-derived-roots ( gc-map -- )
+ [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
-: spill-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain untagged data,
- ! and are stored in physical registers, are saved to their spill
- ! slots. Outputs sequence of triples:
- ! - physical register
- ! - spill slot
- ! - representation
- [
- [
- 2dup spill-on-gc?
- [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
- ] assoc-each
- ] { } make ;
-
-M: ##gc assign-registers-in-insn
- ! Since ##gc is always the first instruction in a block, the set of
- ! values live at the ##gc is just live-in.
- dup call-next-method
- basic-block get register-live-ins get at
- [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
- drop ;
+M: gc-map-insn assign-registers-in-insn
+ [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
+ [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
+ bi ;
M: insn assign-registers-in-insn drop ;
: begin-block ( bb -- )
- dup basic-block set
- dup block-from activate-new-intervals
- [ live-in vregs>regs ] keep register-live-ins get set-at ;
-
-: end-block ( bb -- )
- [ live-out vregs>regs ] keep register-live-outs get set-at ;
-
-ERROR: bad-vreg vreg ;
-
-: vreg-at-start ( vreg bb -- state )
- register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
- register-live-outs get at ?at [ bad-vreg ] unless ;
-
-:: assign-registers-in-block ( bb -- )
- bb [
+ {
+ [ basic-block set ]
+ [ block-from activate-new-intervals ]
+ [ compute-edge-live-in ]
+ [ compute-live-in ]
+ } cleave ;
+
+: assign-registers-in-block ( bb -- )
+ dup begin-block
+ [
[
- bb begin-block
[
{
[ insn#>> 1 - prepare-insn ]
[ , ]
} cleave
] each
- bb end-block
] V{ } make
- ] change-instructions drop ;
+ ] change-instructions compute-live-out ;
-: assign-registers ( live-intervals cfg -- )
- [ init-assignment ] dip
- linearization-order [ assign-registers-in-block ] each ;
+: init-assignment ( live-intervals -- )
+ [ [ start>> ] map ] keep zip >min-heap unhandled-intervals set
+ <min-heap> pending-interval-heap set
+ H{ } clone pending-interval-assoc set
+ H{ } clone machine-live-ins set
+ H{ } clone machine-edge-live-ins set
+ H{ } clone machine-live-outs set ;
+
+: assign-registers ( cfg live-intervals -- )
+ init-assignment
+ linearization-order [ kill-block?>> ] reject
+ [ assign-registers-in-block ] each ;
projects / factor.git / blobdiff