! 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 combinators.short-circuit sets locals arrays
-cpu.architecture layouts
-compiler.cfg
-compiler.cfg.def-use
-compiler.cfg.liveness
-compiler.cfg.liveness.ssa
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.linearization
-compiler.cfg.ssa.destruction
-compiler.cfg.renaming.functor
-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
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
-:: vreg>reg ( vreg -- reg )
- ! If a live vreg is not in the pending set, then it must
- ! have been spilled.
- vreg leader :> leader
- leader pending-interval-assoc get at* [
- drop leader vreg rep-of lookup-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* ;
-: vregs>regs ( vregs -- assoc )
- [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
+ERROR: not-spilled-error vreg ;
-: add-unhandled ( live-interval -- )
- dup start>> unhandled-intervals get heap-push ;
+: vreg>spill-slot ( vreg -- spill-slot )
+ dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
-: init-unhandled ( live-intervals -- )
- [ add-unhandled ] each ;
+: vregs>regs ( vregs -- assoc )
+ [ dup vreg>reg ] H{ } map>assoc ;
-! Liveness info is used by resolve pass
+SYMBOL: unhandled-intervals
-! Mapping from basic blocks to values which are live at the start
-! on all incoming CFG edges
SYMBOL: machine-live-ins
: machine-live-in ( bb -- assoc )
: compute-live-in ( bb -- )
[ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
-! Mapping from basic blocks to predecessors to values which are
-! live on a particular incoming edge
SYMBOL: machine-edge-live-ins
: machine-edge-live-in ( predecessor bb -- assoc )
[ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
machine-edge-live-ins get set-at ;
-! Mapping from basic blocks to values which are live at the end
SYMBOL: machine-live-outs
: machine-live-out ( bb -- assoc )
: compute-live-out ( bb -- )
[ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
-: init-assignment ( live-intervals -- )
- <min-heap> pending-interval-heap set
- H{ } clone pending-interval-assoc set
- <min-heap> unhandled-intervals set
- H{ } clone machine-live-ins set
- H{ } clone machine-edge-live-ins set
- H{ } clone machine-live-outs set
- init-unhandled ;
+: 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>> ] [ spill-rep>> ] [ 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>> ] [ reload-rep>> ] [ 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 ;
-M: ##gc-map assign-registers-in-insn
- [ [ vreg>reg ] map ] change-gc-roots drop ;
+: assign-gc-roots ( gc-map -- )
+ [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
+
+: assign-derived-roots ( gc-map -- )
+ [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots 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 ;
[ compute-live-in ]
} cleave ;
-:: assign-registers-in-block ( bb -- )
- bb [
+: assign-registers-in-block ( bb -- )
+ dup begin-block
+ [
[
- bb begin-block
[
{
[ insn#>> 1 - prepare-insn ]
[ , ]
} cleave
] each
- bb compute-live-out
] V{ } make
- ] change-instructions drop ;
+ ] change-instructions compute-live-out ;
+
+: 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 ( live-intervals cfg -- )
- [ init-assignment ] dip
- linearization-order [ assign-registers-in-block ] each ;
+: assign-registers ( cfg live-intervals -- )
+ init-assignment
+ linearization-order [ kill-block?>> ] reject
+ [ assign-registers-in-block ] each ;
projects / factor.git / blobdiff