1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel math assocs namespaces sequences heaps
4 fry make combinators combinators.short-circuit sets locals arrays
5 cpu.architecture layouts
10 compiler.cfg.instructions
11 compiler.cfg.linearization
12 compiler.cfg.ssa.destruction
13 compiler.cfg.renaming.functor
14 compiler.cfg.linear-scan.allocation
15 compiler.cfg.linear-scan.allocation.state
16 compiler.cfg.linear-scan.live-intervals ;
17 FROM: namespaces => set ;
18 IN: compiler.cfg.linear-scan.assignment
20 ! This contains both active and inactive intervals; any interval
21 ! such that start <= insn# <= end is in this set.
22 SYMBOL: pending-interval-heap
23 SYMBOL: pending-interval-assoc
25 : add-pending ( live-interval -- )
26 [ dup end>> pending-interval-heap get heap-push ]
27 [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
30 : remove-pending ( live-interval -- )
31 vreg>> pending-interval-assoc get delete-at ;
33 :: vreg>reg ( vreg -- reg )
34 ! If a live vreg is not in the pending set, then it must
37 leader pending-interval-assoc get at* [
38 drop leader vreg rep-of lookup-spill-slot
41 ERROR: not-spilled-error vreg ;
43 : vreg>spill-slot ( vreg -- spill-slot )
44 dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
46 : vregs>regs ( vregs -- assoc )
47 [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
49 ! Minheap of live intervals which still need a register allocation
50 SYMBOL: unhandled-intervals
52 : add-unhandled ( live-interval -- )
53 dup start>> unhandled-intervals get heap-push ;
55 : init-unhandled ( live-intervals -- )
56 [ add-unhandled ] each ;
58 ! Liveness info is used by resolve pass
60 ! Mapping from basic blocks to values which are live at the start
61 ! on all incoming CFG edges
62 SYMBOL: machine-live-ins
64 : machine-live-in ( bb -- assoc )
65 machine-live-ins get at ;
67 : compute-live-in ( bb -- )
68 [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
70 ! Mapping from basic blocks to predecessors to values which are
71 ! live on a particular incoming edge
72 SYMBOL: machine-edge-live-ins
74 : machine-edge-live-in ( predecessor bb -- assoc )
75 machine-edge-live-ins get at at ;
77 : compute-edge-live-in ( bb -- )
78 [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
79 machine-edge-live-ins get set-at ;
81 ! Mapping from basic blocks to values which are live at the end
82 SYMBOL: machine-live-outs
84 : machine-live-out ( bb -- assoc )
85 machine-live-outs get at ;
87 : compute-live-out ( bb -- )
88 [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
90 : init-assignment ( live-intervals -- )
91 <min-heap> pending-interval-heap set
92 H{ } clone pending-interval-assoc set
93 <min-heap> unhandled-intervals set
94 H{ } clone machine-live-ins set
95 H{ } clone machine-edge-live-ins set
96 H{ } clone machine-live-outs set
99 : insert-spill ( live-interval -- )
100 [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ;
102 : handle-spill ( live-interval -- )
103 dup spill-to>> [ insert-spill ] [ drop ] if ;
105 : expire-interval ( live-interval -- )
106 [ remove-pending ] [ handle-spill ] bi ;
108 : (expire-old-intervals) ( n heap -- )
109 dup heap-empty? [ 2drop ] [
110 2dup heap-peek nip <= [ 2drop ] [
111 dup heap-pop drop expire-interval
112 (expire-old-intervals)
116 : expire-old-intervals ( n -- )
117 pending-interval-heap get (expire-old-intervals) ;
119 : insert-reload ( live-interval -- )
120 [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ;
122 : handle-reload ( live-interval -- )
123 dup reload-from>> [ insert-reload ] [ drop ] if ;
125 : activate-interval ( live-interval -- )
126 [ add-pending ] [ handle-reload ] bi ;
128 : (activate-new-intervals) ( n heap -- )
129 dup heap-empty? [ 2drop ] [
130 2dup heap-peek nip = [
131 dup heap-pop drop activate-interval
132 (activate-new-intervals)
136 : activate-new-intervals ( n -- )
137 unhandled-intervals get (activate-new-intervals) ;
139 : prepare-insn ( n -- )
140 [ expire-old-intervals ] [ activate-new-intervals ] bi ;
142 GENERIC: assign-registers-in-insn ( insn -- )
144 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
146 M: vreg-insn assign-registers-in-insn
147 [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
149 M: gc-map-insn assign-registers-in-insn
150 [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
151 [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ]
154 M: insn assign-registers-in-insn drop ;
156 : begin-block ( bb -- )
159 [ block-from activate-new-intervals ]
160 [ compute-edge-live-in ]
164 :: assign-registers-in-block ( bb -- )
171 [ insn#>> 1 - prepare-insn ]
172 [ insn#>> prepare-insn ]
173 [ assign-registers-in-insn ]
179 ] change-instructions drop
182 : assign-registers ( live-intervals cfg -- )
183 [ init-assignment ] dip
184 linearization-order [ assign-registers-in-block ] each ;