| blob | 264e0e75a6b69917178f55875b5d1339df88a0bd |
1 ;; address after which memory is allocated by the user, therefore not used for
2 ;; register allocation
3 ;; in programs, located in the SIXPIC_MEMORY_DIVIDE variable
4 (define memory-divide #f)
6 ;; the vector equivalent to all-byte-cells
7 (define byte-cells #f)
8 (define (id->byte-cell id) (vector-ref byte-cells id))
10 (define (interference-graph cfg)
12 (define (analyze-liveness cfg)
13 (define changed? #t)
14 (define (instr-analyze-liveness instr live-after)
15 (let ((live-before
16 (cond
18 ((call-instr? instr)
19 (let ((def-proc (call-instr-def-proc instr)))
20 (if (and (not (bitset-empty? live-after))
21 (not (bitset-subset?
22 (def-procedure-live-after-calls def-proc)
23 live-after)))
24 (begin
25 (set! changed? #t)
26 (bitset-union! (def-procedure-live-after-calls def-proc)
27 live-after)))
28 (let ((live
29 (bitset-union-multi
30 byte-cell-counter
31 `(,(bitset-diff
32 live-after
33 (list->bitset
34 byte-cell-counter
35 (map (lambda (x) (byte-cell-id x))
36 (value-bytes
37 (def-procedure-value def-proc)))))
38 ,(bb-live-before (def-procedure-entry def-proc))
39 ,@(map (lambda (def-var)
40 (list->bitset
41 byte-cell-counter
42 (map (lambda (x) (byte-cell-id x))
43 (value-bytes
44 (def-variable-value def-var)))))
45 (def-procedure-params def-proc))))))
46 (if (bb? (def-procedure-entry def-proc))
47 (bitset-intersection
48 (bb-live-before (def-procedure-entry def-proc))
49 live)
50 live))))
52 ((return-instr? instr)
53 (let* ((def-proc (return-instr-def-proc instr))
54 (live
55 (if (def-procedure? def-proc)
56 (def-procedure-live-after-calls def-proc)
57 (list->bitset byte-cell-counter
58 (map (lambda (x) (byte-cell-id x))
59 (value-bytes def-proc))))))
60 (set! live-after live)
61 live))
63 (else
64 (let* ((src1 (instr-src1 instr))
65 (src2 (instr-src2 instr))
66 (dst (instr-dst instr))
67 (s (bitset-copy live-after)))
68 (define (add-if-byte-cell c)
69 (if (byte-cell? c)
70 (bitset-add! s (byte-cell-id c))))
71 (define (remove-if-byte-cell c)
72 (if (byte-cell? c)
73 (bitset-remove! s (byte-cell-id c))))
74 (add-if-byte-cell src1)
75 (add-if-byte-cell src2)
76 (remove-if-byte-cell dst)
77 s)))))
79 (instr-live-before-set! instr live-before)
80 (instr-live-after-set! instr live-after)
81 live-before))
82 (define (bb-analyze-liveness bb)
83 (let loop ((rev-instrs (bb-rev-instrs bb))
84 (live-after (bitset-union-multi
85 byte-cell-counter
86 (map bb-live-before (bb-succs bb)))))
87 (if (null? rev-instrs)
88 (if (not (equal? live-after (bb-live-before bb)))
89 (begin (set! changed? #t)
90 (bb-live-before-set! bb live-after)))
91 (let* ((instr (car rev-instrs))
92 (live-before (instr-analyze-liveness instr live-after)))
93 (loop (cdr rev-instrs)
94 live-before)))))
96 ;; build a vector with all the byte-cells and initialise the bitsets
97 (set! byte-cells (make-vector byte-cell-counter #f))
98 (table-for-each (lambda (id cell)
99 (byte-cell-interferes-with-set!
100 cell (make-bitset byte-cell-counter))
101 (vector-set! byte-cells id cell))
102 all-byte-cells)
103 ;; create the bitsets for each bb, instr and def-procedure
104 (for-each (lambda (bb)
105 (bb-live-before-set! bb (make-bitset byte-cell-counter))
106 (for-each (lambda (instr)
107 (instr-live-before-set!
108 instr (make-bitset byte-cell-counter))
109 (instr-live-after-set!
110 instr (make-bitset byte-cell-counter)))
111 (bb-rev-instrs bb)))
112 (cfg-bbs cfg))
113 (table-for-each (lambda (key s) (def-procedure-live-after-calls-set!
114 s (make-bitset byte-cell-counter)))
115 all-def-procedures)
117 (let loop ()
118 (if changed?
119 (begin (set! changed? #f)
120 (for-each bb-analyze-liveness (cfg-bbs cfg))
121 (loop)))))
123 ;;-----------------------------------------------------------------------------
125 (define all-live (new-empty-set))
127 (define (bb-interference-graph bb)
128 (define (interfere x y)
129 (bitset-add! (byte-cell-interferes-with x) (byte-cell-id y))
130 (bitset-add! (byte-cell-interferes-with y) (byte-cell-id x)))
131 (define (make-coalesceable-with x y)
132 (set-add! (byte-cell-coalesceable-with x) y)
133 (set-add! (byte-cell-coalesceable-with y) x))
135 (define (interfere-pairwise live)
136 (set-union! all-live (list->set live))
137 (for-each
138 (lambda (x)
139 (for-each
140 (lambda (y)
141 (if (not (eq? x y))
142 (bitset-add! (byte-cell-interferes-with x) (byte-cell-id y))))
143 live))
144 live))
146 (define (instr-interference-graph instr)
147 (define (bitset->cells bs) (map id->byte-cell (bitset->list bs)))
148 (let ((dst (instr-dst instr))
149 (src1 (instr-src1 instr))
150 (src2 (instr-src2 instr)))
151 (if (byte-cell? dst)
152 (begin
153 (if (and (byte-cell? src1) (not (eq? dst src1)))
154 (make-coalesceable-with src1 dst))
155 (if (and (byte-cell? src2) (not (eq? dst src2)))
156 (make-coalesceable-with src2 dst))))
157 (if (call-instr? instr)
158 (let* ((before (instr-live-before instr))
159 (after (instr-live-after instr))
160 (diff (bitset->cells (bitset-diff before after)))
161 (diff2 (bitset-diff after before)))
162 (interfere-pairwise diff)
163 (for-each
164 (lambda (x)
165 (for-each
166 (lambda (y)
167 (if (and (not (eq? x y))
168 (not (bitset-member? diff2 (byte-cell-id y))))
169 (interfere x y)))
170 (bitset->cells after)))
171 diff))
172 (if (byte-cell? dst)
173 (begin (set-add! all-live dst)
174 (for-each (lambda (x)
175 (set-add! all-live x)
176 (if (not (eq? dst x))
177 (interfere dst x)))
178 (bitset->cells (instr-live-after instr))))))))
180 (for-each instr-interference-graph (bb-rev-instrs bb)))
182 (pp analyse-liveness:)
183 (time (analyze-liveness cfg))
185 (pp interference-graph:)
186 (time (for-each bb-interference-graph (cfg-bbs cfg)))
188 ;; change the bitsets to sets, to speed up graph coloring
189 (pp bitsets->sets:)
190 (time
191 (let loop ((l (- (vector-length byte-cells) 1)))
192 (if (not (< l 0))
193 (let* ((cell (id->byte-cell l)))
194 (if cell
195 (byte-cell-interferes-with-set!
196 cell
197 (let* ((bs (byte-cell-interferes-with cell))
198 (n (fxarithmetic-shift-left (u8vector-length bs) 3))
199 (set (new-empty-set)))
200 (let loop ((i (- n 1)))
201 (if (>= i 0)
202 (begin (if (bitset-member? bs i)
203 (set-add! set (id->byte-cell i)))
204 (loop (- i 1)))
205 set)))))
206 (loop (- l 1))))))
208 all-live)
210 ;;-----------------------------------------------------------------------------
212 (define (delete byte-cell1 neighbours)
213 (set-for-each (lambda (byte-cell2)
214 (set-remove! (byte-cell-interferes-with byte-cell2)
215 byte-cell1)
216 (byte-cell-nb-neighbours-set!
217 byte-cell2 (- (byte-cell-nb-neighbours byte-cell2) 1)))
218 neighbours))
219 (define (undelete byte-cell1 neighbours)
220 (set-for-each (lambda (byte-cell2)
221 (set-add! (byte-cell-interferes-with byte-cell2)
222 byte-cell1)
223 (byte-cell-nb-neighbours-set!
224 byte-cell2 (+ (byte-cell-nb-neighbours byte-cell2) 1)))
225 neighbours))
227 (define (coalesce graph)
228 (pp coalesce:)
229 (time
230 (if coalesce?
231 (filter
232 (lambda (byte-cell)
233 (let* ((coalesceable-with (byte-cell-coalesceable-with byte-cell))
234 (neighbours (byte-cell-interferes-with byte-cell))
235 (coalesce-candidates (set-diff coalesceable-with
236 neighbours)))
237 (if (or (byte-cell-adr byte-cell) ; in a special register
238 (set-empty? coalesce-candidates))
239 #t ;; keep it
240 ;; coalesce byte-cell with another cell
241 (let loop ((l (set->list coalesce-candidates)))
242 (if (null? l)
243 #t ; can't coalesce, keep
244 (let ((c (car l)))
245 ;; don't coalesce with a special register
246 (if (byte-cell-adr c)
247 (loop (cdr l))
248 (let ((c-neighbours
249 (byte-cell-interferes-with c))
250 (c-coalesceable-with
251 (byte-cell-coalesceable-with c))
252 (c-coalesced
253 (byte-cell-coalesced-with c)))
254 ;; remove all references to byte-cell and replace
255 ;; them with references to c
256 (set-union! c-neighbours neighbours)
257 (undelete c neighbours)
258 (delete byte-cell neighbours)
259 (set-union! c-coalesced
260 (byte-cell-coalesced-with byte-cell))
261 (set-for-each
262 (lambda (cell)
263 (let ((s (byte-cell-coalesceable-with cell)))
264 (set-remove! s byte-cell)
265 #;(set-add! s c) ;; TODO does not work, register allocation fails with that
266 #;(set-add! c-coalesceable-with cell)))
267 coalesceable-with)
268 (byte-cell-coalesceable-with-set! byte-cell
269 (new-empty-set))
270 (byte-cell-interferes-with-set! byte-cell
271 (new-empty-set))
272 (set-add! c-coalesced byte-cell)
273 #f))))))))
274 graph)
275 graph)))
277 ;;-----------------------------------------------------------------------------
279 (define register-table (make-table))
280 (define reverse-register-table (make-table))
281 (define (allocate-registers cfg)
282 (let ((all-live (coalesce (set->list (interference-graph cfg))))
283 (max-adr 0)) ; to know how much ram we need
285 (define (color byte-cell)
286 (define (set-register-table cell adr)
287 (if #f (not (string=? (byte-cell-name cell) "__tmp"))
288 (let* ((adr (if (and (> adr #x5F) (< adr #xF60)) ; not in bank 0 ;; TODO have a function for that
289 (+ adr #xa0)
290 adr))
291 (name (byte-cell-name cell))
292 (full-name (cons (if name name "__tmp")
293 (byte-cell-id cell))))
294 (table-set! register-table
295 adr
296 (cons (cons (byte-cell-bb cell)
297 full-name)
298 (table-ref register-table adr '())))
299 (table-set! reverse-register-table name adr))))
300 (let ((neighbours (set->list (byte-cell-interferes-with byte-cell))))
301 (let loop1 ((adr 0))
302 (if (and memory-divide ; the user wants his own zone
303 (>= adr memory-divide)) ; and we'd use it
304 (error "register allocation would cross the memory divide") ;; TODO fallback ?
305 (let loop2 ((lst neighbours)) ;; TODO keep using sets, but not urgent, it's not a bottleneck
306 (if (null? lst)
307 (begin (byte-cell-adr-set! byte-cell adr)
308 (set-register-table byte-cell adr)
309 (set-for-each
310 (lambda (cell)
311 (byte-cell-adr-set! cell adr)
312 (set-register-table cell adr))
313 (byte-cell-coalesced-with byte-cell)))
314 (if (= adr (byte-cell-adr (car lst)))
315 (loop1 (+ adr 1))
316 (loop2 (cdr lst))))))
317 (set! max-adr (max max-adr adr)))))
319 (define (find-min-neighbours graph)
320 (let loop ((lst graph) (m #f) (byte-cell #f))
321 (if (null? lst)
322 byte-cell
323 (let* ((x (car lst))
324 (n (byte-cell-nb-neighbours x)))
325 (if (or (not m) (< n m))
326 (loop (cdr lst) n x)
327 (loop (cdr lst) m byte-cell))))))
329 (define (alloc-reg graph)
330 (if (not (null? graph))
331 (let* ((byte-cell (find-min-neighbours graph))
332 (neighbours (byte-cell-interferes-with byte-cell)))
333 (let ((new-graph (remove byte-cell graph)))
334 (delete byte-cell neighbours)
335 (alloc-reg new-graph)
336 (undelete byte-cell neighbours))
337 (if (not (byte-cell-adr byte-cell))
338 (color byte-cell)))))
340 ;; cache the number of neighbours
341 (for-each (lambda (cell)
342 (byte-cell-nb-neighbours-set!
343 cell (set-length (byte-cell-interferes-with cell))))
344 all-live)
346 (pp register-allocation:)
347 (time (alloc-reg all-live))
348 (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))