! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg
-compiler.cfg.instructions
-compiler.cfg.linear-scan.allocation.state
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linearization compiler.cfg.liveness
-compiler.cfg.registers compiler.cfg.renaming.functor
-compiler.cfg.ssa.destruction.leaders heaps kernel locals make
-math namespaces sequences ;
+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 )
- 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* ;
ERROR: not-spilled-error vreg ;
dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
: vregs>regs ( vregs -- assoc )
- [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
+ [ 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 ;
-
-: init-unhandled ( live-intervals -- )
- [ add-unhandled ] each ;
-
-! Liveness info is used by resolve pass
-
-! 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, ;
: 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, ;
: 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 ;
[ compute-live-in ]
} cleave ;
-:: assign-registers-in-block ( bb -- )
- bb kill-block?>> [
- bb [
+: assign-registers-in-block ( bb -- )
+ dup begin-block
+ [
+ [
[
- bb begin-block
- [
- {
- [ insn#>> 1 - prepare-insn ]
- [ insn#>> prepare-insn ]
- [ assign-registers-in-insn ]
- [ , ]
- } cleave
- ] each
- bb compute-live-out
- ] V{ } make
- ] change-instructions drop
- ] unless ;
-
-: assign-registers ( live-intervals cfg -- )
- [ init-assignment ] dip
- linearization-order [ assign-registers-in-block ] each ;
+ {
+ [ insn#>> 1 - prepare-insn ]
+ [ insn#>> prepare-insn ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ } cleave
+ ] each
+ ] V{ } make
+ ] 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 ( cfg live-intervals -- )
+ init-assignment
+ linearization-order [ kill-block?>> ] reject
+ [ assign-registers-in-block ] each ;