| blob | 2a2c0733d3f1900a58d45bf48432c2375097d24b |
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 (define (interference-graph cfg)
8 (define all-live (new-empty-set))
10 (define (interfere x y)
11 (if (not (set-member? (byte-cell-interferes-with y) x))
12 (begin
13 (set-add! (byte-cell-interferes-with x) y)
14 (set-add! (byte-cell-interferes-with y) x))))
16 (define (interfere-pairwise live)
17 (set! all-live (union all-live live))
18 (table-for-each (lambda (x dummy) ;; TODO do it in utilities ?
19 (table-for-each (lambda (y dummy)
20 (if (not (eq? x y)) (interfere x y)))
21 live))
22 live))
24 (define (instr-interference-graph instr)
25 (let ((dst (instr-dst instr)))
26 (if (byte-cell? dst)
27 (let ((src1 (instr-src1 instr))
28 (src2 (instr-src2 instr)))
29 (if (byte-cell? src1)
30 (begin
31 (set-add! (byte-cell-coalesceable-with dst) src1)
32 (set-add! (byte-cell-coalesceable-with src1) dst)))
33 (if (byte-cell? src2)
34 (begin
35 (set-add! (byte-cell-coalesceable-with dst) src2)
36 (set-add! (byte-cell-coalesceable-with src2) dst))))))
37 (let ((live-before (instr-live-before instr)))
38 (interfere-pairwise live-before)))
40 (define (bb-interference-graph bb)
41 (for-each instr-interference-graph (bb-rev-instrs bb)))
43 (analyze-liveness cfg)
45 (for-each bb-interference-graph (cfg-bbs cfg))
47 all-live)
49 (define (allocate-registers cfg)
50 (let ((all-live (interference-graph cfg)))
52 (define (color byte-cell)
53 (let ((coalesce-candidates ; TODO right now, no coalescing is done
54 (set-filter byte-cell-adr
55 (diff (byte-cell-coalesceable-with byte-cell)
56 (byte-cell-interferes-with byte-cell)))))
57 '
58 (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
59 coalesce-candidates
60 ; interferes-with: (byte-cell-interferes-with byte-cell)
61 ; coalesceable-with: (byte-cell-coalesceable-with byte-cell)
62 ))
64 (if #f #;(not (null? coalesce-candidates))
65 (let ((adr (byte-cell-adr (car (set->list coalesce-candidates))))) ;; TODO have as a set all along
66 (byte-cell-adr-set! byte-cell adr))
67 (let ((neighbours (byte-cell-interferes-with byte-cell)))
68 (let loop1 ((adr 0))
69 (if (and memory-divide ; the user wants his own zone
70 (>= adr memory-divide)) ; and we'd use it
71 (error "register allocation would cross the memory divide") ;; TODO fallback ?
72 (let loop2 ((lst (set->list neighbours))) ;; TODO keep using sets, but not urgent, it's not a bottleneck
73 (if (null? lst)
74 (byte-cell-adr-set! byte-cell adr)
75 (let ((x (car lst)))
76 (if (= adr (byte-cell-adr x))
77 (loop1 (+ adr 1))
78 (loop2 (cdr lst))))))))))))
80 (define (delete byte-cell1 neighbours)
81 (table-for-each (lambda (byte-cell2 dummy)
82 (set-remove! (byte-cell-interferes-with byte-cell2)
83 byte-cell1))
84 neighbours))
86 (define (undelete byte-cell1 neighbours)
87 (table-for-each (lambda (byte-cell2 val)
88 (set-add! (byte-cell-interferes-with byte-cell2)
89 byte-cell1))
90 neighbours))
92 (define (find-min-neighbours graph)
93 (let loop ((lst graph) (m #f) (byte-cell #f))
94 (if (null? lst)
95 byte-cell
96 (let* ((x (car lst))
97 (n (table-length (byte-cell-interferes-with x))))
98 (if (or (not m) (< n m))
99 (loop (cdr lst) n x)
100 (loop (cdr lst) m byte-cell))))))
102 (define (alloc-reg graph)
103 (if (not (null? graph))
104 (let* ((byte-cell (find-min-neighbours graph))
105 (neighbours (byte-cell-interferes-with byte-cell)))
106 (let ((new-graph (remove byte-cell graph)))
107 (delete byte-cell neighbours)
108 (alloc-reg new-graph)
109 (undelete byte-cell neighbours))
110 (if (not (byte-cell-adr byte-cell))
111 (color byte-cell)))))
113 (alloc-reg (set->list all-live)))) ;; TODO convert find-min-neighbors andalloc-reg to use tables, not urgent since it's not a bottleneck
116 (define (linearize-and-cleanup cfg)
118 (define bbs-vector (cfg->vector cfg))
120 (define todo '())
122 (define (add-todo bb)
123 (set! todo (cons bb todo)))
125 (define rev-code '())
127 (define (emit instr)
128 (set! rev-code (cons instr rev-code)))
130 (define (movlw val)
131 (emit (list 'movlw val)))
132 (define (movwf adr)
133 (emit (list 'movwf adr)))
134 (define (movfw adr)
135 (emit (list 'movfw adr)))
136 (define (movff src dst)
137 (emit (list 'movff src dst)))
139 (define (clrf adr)
140 (emit (list 'clrf adr)))
141 (define (setf adr)
142 (emit (list 'setf adr)))
144 (define (incf adr)
145 (emit (list 'incf adr)))
146 (define (decf adr)
147 (emit (list 'decf adr)))
149 (define (addwf adr)
150 (emit (list 'addwf adr)))
151 (define (addwfc adr)
152 (emit (list 'addwfc adr)))
154 (define (subwf adr)
155 (emit (list 'subwf adr)))
156 (define (subwfb adr)
157 (emit (list 'subwfb adr)))
159 (define (mullw adr)
160 (emit (list 'mullw adr)))
161 (define (mulwf adr)
162 (emit (list 'mulwf adr)))
164 (define (andwf adr)
165 (emit (list 'andwf adr)))
166 (define (iorwf adr)
167 (emit (list 'iorwf adr)))
168 (define (xorwf adr)
169 (emit (list 'xorwf adr)))
171 (define (rlcf adr)
172 (emit (list 'rlcf adr)))
173 (define (rrcf adr)
174 (emit (list 'rrcf adr)))
176 (define (bcf adr bit)
177 (emit (list 'bcf adr bit)))
178 (define (bsf adr bit)
179 (emit (list 'bsf adr bit)))
180 (define (btg adr bit)
181 (emit (list 'btg adr bit)))
183 (define (comf adr)
184 (emit (list 'comf adr)))
186 (define (cpfseq adr)
187 (emit (list 'cpfseq adr)))
188 (define (cpfslt adr)
189 (emit (list 'cpfslt adr)))
190 (define (cpfsgt adr)
191 (emit (list 'cpfsgt adr)))
193 (define (bra label)
194 (emit (list 'bra label)))
196 (define (rcall label)
197 (emit (list 'rcall label)))
199 (define (return)
200 (if (and #f (and (not (null? rev-code))
201 (eq? (caar rev-code) 'rcall)))
202 (let ((label (cadar rev-code)))
203 (set! rev-code (cdr rev-code))
204 (bra label))
205 (emit (list 'return))))
207 (define (label lab)
208 (if (and #f (and (not (null? rev-code))
209 (eq? (caar rev-code) 'bra)
210 (eq? (cadar rev-code) lab)))
211 (begin
212 (set! rev-code (cdr rev-code))
213 (label lab))
214 (emit (list 'label lab))))
216 (define (sleep)
217 (emit (list 'sleep)))
219 (define (move-reg src dst)
220 (cond ((= src dst))
221 ((= src WREG)
222 (movwf dst))
223 ((= dst WREG)
224 (movfw src))
225 (else
226 ;; (movfw src)
227 ;; (movwf dst)
228 ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
229 ;; only 1 instruction
230 (movff src dst))))
232 (define (bb-linearize bb)
233 (let ((label-num (bb-label-num bb)))
234 (let ((bb (vector-ref bbs-vector label-num)))
236 (define (move-lit n adr)
237 (cond ((= n 0)
238 (clrf adr))
239 ((= n #xff)
240 (setf adr))
241 (else
242 (movlw n)
243 (movwf adr))))
245 (define (dump-instr instr)
246 (cond ((call-instr? instr)
247 (let* ((def-proc (call-instr-def-proc instr))
248 (entry (def-procedure-entry def-proc)))
249 (if (bb? entry)
250 (begin
251 (add-todo entry)
252 (let ((label (bb-label entry)))
253 (rcall label)))
254 (rcall entry))))
255 ((return-instr? instr)
256 (return))
257 (else
258 (let ((src1 (instr-src1 instr))
259 (src2 (instr-src2 instr))
260 (dst (instr-dst instr)))
261 (if (and (or (not (byte-cell? dst))
262 (byte-cell-adr dst))
263 (or (not (byte-cell? src1))
264 (byte-cell-adr src1))
265 (or (not (byte-cell? src2))
266 (byte-cell-adr src2)))
268 (case (instr-id instr)
270 ((move)
271 (if (byte-lit? src1)
272 (let ((n (byte-lit-val src1))
273 (z (byte-cell-adr dst)))
274 (move-lit n z))
275 (let ((x (byte-cell-adr src1))
276 (z (byte-cell-adr dst)))
277 (move-reg x z))))
279 ((add addc sub subb)
280 (if (byte-lit? src2)
281 (let ((n (byte-lit-val src2))
282 (z (byte-cell-adr dst)))
283 (if (byte-lit? src1)
284 (move-lit (byte-lit-val src1) z)
285 (move-reg (byte-cell-adr src1) z))
286 (case (instr-id instr)
287 ((add) (cond ((= n 1) (incf z))
288 ((= n #xff) (decf z))
289 (else (movlw n)
290 (addwf z))))
291 ((addc) (movlw n) (addwfc z))
292 ((sub) (cond ((= n 1) (decf z))
293 ((= n #xff) (incf z))
294 (else (movlw n)
295 (subwf z))))
296 ((subb) (movlw n) (subwfb z))))
297 (let ((x (byte-cell-adr src1))
298 (y (byte-cell-adr src2))
299 (z (byte-cell-adr dst)))
300 (cond ((and (not (= x y))
301 (= y z)
302 (memq (instr-id instr)
303 '(add addc)))
304 ;; since this basically swaps the
305 ;; arguments, it can't be used for
306 ;; subtraction
307 (move-reg x WREG))
308 ((and (not (= x y))
309 (= y z))
310 ;; for subtraction, preserves argument
311 ;; order
312 (move-reg y WREG)
313 ;; this NEEDS to be done with movff, or
314 ;; else wreg will get clobbered and this
315 ;; won't work
316 (move-reg x z))
317 (else ;; TODO check if it could be merged with the previous case
318 (move-reg x z)
319 (move-reg y WREG)))
320 (case (instr-id instr)
321 ((add) (addwf z))
322 ((addc) (addwfc z))
323 ((sub) (subwf z))
324 ((subb) (subwfb z))
325 (else (error "..."))))))
327 ((mul) ; 8 by 8 multiplication
328 (if (byte-lit? src2)
329 ;; since multiplication is commutative, the
330 ;; arguments are set up so the second one will
331 ;; be a literal if the operator is applied on a
332 ;; literal and a variable
333 (let ((n (byte-lit-val src2)))
334 (if (byte-lit? src1)
335 (movlw (byte-lit-val src1))
336 (move-reg (byte-cell-adr src1) WREG))
337 ;; literal multiplication
338 (mullw n))
339 (let ((x (byte-cell-adr src1))
340 (y (byte-cell-adr src2)))
341 (move-reg x WREG)
342 (mulwf y))))
344 ((and ior xor)
345 ;; no instructions for bitwise operations involving
346 ;; literals exist on the PIC18
347 (let ((x (if (byte-lit? src1)
348 (byte-lit-val src1)
349 (byte-cell-adr src1)))
350 (y (if (byte-lit? src2)
351 (byte-lit-val src2)
352 (byte-cell-adr src2)))
353 (z (byte-cell-adr dst)))
354 (cond ((byte-lit? src1)
355 (if (byte-lit? src2)
356 (move-lit y z)
357 (move-reg y z))
358 (movlw x))
359 ((and (not (= x y)) (= y z))
360 (move-reg x WREG))
361 (else
362 (move-reg x z)
363 (move-reg y WREG)))
364 (case (instr-id instr)
365 ((and) (andwf z))
366 ((ior) (iorwf z))
367 ((xor) (xorwf z))
368 (else (error "...")))))
370 ((shl shr)
371 (let ((x (if (byte-lit? src1)
372 (byte-lit-val src1)
373 (byte-cell-adr src1)))
374 (z (byte-cell-adr dst)))
375 (cond ((byte-lit? src1) (move-lit x z))
376 ((not (= x z)) (move-reg x z)))
377 (case (instr-id instr)
378 ((shl) (rlcf z))
379 ((shr) (rrcf z)))))
381 ((set clear toggle)
382 ;; bit operations
383 (if (not (byte-lit? src2))
384 (error "bit offset must be a literal"))
385 (let ((x (byte-cell-adr src1))
386 (y (byte-lit-val src2)))
387 (case (instr-id instr)
388 ((set) (bsf x y))
389 ((clear) (bcf x y))
390 ((toggle) (btg x y)))))
392 ((not)
393 (let ((z (byte-cell-adr dst)))
394 (if (byte-lit? src1)
395 (move-lit (byte-lit-val src1) z)
396 (move-reg (byte-cell-adr src1) z))
397 (comf z)))
399 ((goto)
400 (if (null? (bb-succs bb))
401 (error "I think you might have given me an empty source file."))
402 (let* ((succs (bb-succs bb))
403 (dest (car succs)))
404 (bra (bb-label dest))
405 (add-todo dest)))
406 ((x==y x<y x>y)
407 (let* ((succs (bb-succs bb))
408 (dest-true (car succs))
409 (dest-false (cadr succs)))
411 (define (compare flip adr)
412 (case (instr-id instr)
413 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
414 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
415 (else (cpfseq adr)))
416 (bra (bb-label dest-false))
417 (bra (bb-label dest-true))
418 (add-todo dest-false)
419 (add-todo dest-true))
421 (cond ((byte-lit? src1)
422 (let ((n (byte-lit-val src1))
423 (y (byte-cell-adr src2)))
424 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
425 (eq? (instr-id instr) 'x==y))
426 (special-compare-eq-lit n x)
427 (begin
428 (movlw n)
429 (compare #t y)))))
430 ((byte-lit? src2)
431 (let ((x (byte-cell-adr src1))
432 (n (byte-lit-val src2)))
433 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
434 (eq? (instr-id instr) 'x==y))
435 (special-compare-eq-lit n x)
436 (begin
437 (movlw n)
438 (compare #f x)))))
439 (else
440 (let ((x (byte-cell-adr src1))
441 (y (byte-cell-adr src2)))
442 (move-reg y WREG)
443 (compare #f x))))))
444 (else
445 ;...
446 (emit (list (instr-id instr))))))))))
448 (if bb
449 (begin
450 (vector-set! bbs-vector label-num #f)
451 (label (bb-label bb))
452 (for-each dump-instr (reverse (bb-rev-instrs bb)))
453 (for-each add-todo (bb-succs bb)))))))
455 (let ((prog-label (asm-make-label 'PROG)))
456 (rcall prog-label)
457 (sleep)
458 (label prog-label))
460 (add-todo (vector-ref bbs-vector 0))
462 (let loop ()
463 (if (null? todo)
464 (reverse rev-code)
465 (let ((bb (car todo)))
466 (set! todo (cdr todo))
467 (bb-linearize bb)
468 (loop)))))
471 (define (assembler-gen filename cfg)
473 (define (gen instr)
474 (case (car instr)
475 ((movlw)
476 (movlw (cadr instr)))
477 ((movwf)
478 (movwf (cadr instr)))
479 ((movfw)
480 (movf (cadr instr) 'w))
481 ((movff)
482 (movff (cadr instr) (caddr instr)))
483 ((clrf)
484 (clrf (cadr instr)))
485 ((setf)
486 (setf (cadr instr)))
487 ((incf)
488 (incf (cadr instr)))
489 ((decf)
490 (decf (cadr instr)))
491 ((addwf)
492 (addwf (cadr instr)))
493 ((addwfc)
494 (addwfc (cadr instr)))
495 ((subwf)
496 (subwf (cadr instr)))
497 ((subwfb)
498 (subwfb (cadr instr)))
499 ((mullw)
500 (mullw (cadr instr)))
501 ((mulwf)
502 (mulwf (cadr instr)))
503 ((andwf)
504 (andwf (cadr instr)))
505 ((iorwf)
506 (iorwf (cadr instr)))
507 ((xorwf)
508 (xorwf (cadr instr)))
509 ((rlcf)
510 (rlcf (cadr instr)))
511 ((rrcf)
512 (rrcf (cadr instr)))
513 ((bcf)
514 (bcf (cadr instr) (caddr instr)))
515 ((bsf)
516 (bsf (cadr instr) (caddr instr)))
517 ((btg)
518 (btg (cadr instr) (caddr instr)))
519 ((comf)
520 (comf (cadr instr)))
521 ((cpfseq)
522 (cpfseq (cadr instr)))
523 ((cpfslt)
524 (cpfslt (cadr instr)))
525 ((cpfsgt)
526 (cpfsgt (cadr instr)))
527 ((bra)
528 (bra (cadr instr)))
529 ((rcall)
530 (rcall (cadr instr)))
531 ((return)
532 (return))
533 ((label)
534 (asm-listing
535 (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
536 (asm-label (cadr instr)))
537 ((sleep)
538 (sleep))
539 (else
540 (error "unknown instruction" instr))))
542 (asm-begin! 0 #f)
544 ; (pretty-print cfg)
546 (let ((code (linearize-and-cleanup cfg)))
547 ; (pretty-print code)
548 (for-each gen code)))
550 (define (code-gen filename cfg)
551 (pp register-allocation:)
552 (allocate-registers cfg)
553 (pp code-generation:)
554 (assembler-gen filename cfg))