| blob | d21914ecc30d2c02692d31a9c83cc4461c0513af |
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 '())
10 (define (interfere x y)
11 (if (not (memq x (byte-cell-interferes-with y)))
12 (begin
13 (byte-cell-interferes-with-set!
14 x
15 (cons y (byte-cell-interferes-with x)))
16 (byte-cell-interferes-with-set!
17 y
18 (cons x (byte-cell-interferes-with y))))))
20 (define (interfere-pairwise live)
21 (set! all-live (union all-live live))
22 (for-each (lambda (x)
23 (for-each (lambda (y)
24 (if (not (eq? x y))
25 (interfere x y)))
26 live))
27 live))
29 (define (instr-interference-graph instr)
30 (let ((dst (instr-dst instr)))
31 (if (byte-cell? dst)
32 (let ((src1 (instr-src1 instr))
33 (src2 (instr-src2 instr)))
34 (if (byte-cell? src1)
35 (begin
36 (byte-cell-coalesceable-with-set!
37 dst
38 (union (byte-cell-coalesceable-with dst)
39 (list src1)))
40 (byte-cell-coalesceable-with-set!
41 src1
42 (union (byte-cell-coalesceable-with src1)
43 (list dst)))))
44 (if (byte-cell? src2)
45 (begin
46 (byte-cell-coalesceable-with-set!
47 dst
48 (union (byte-cell-coalesceable-with dst)
49 (list src2)))
50 (byte-cell-coalesceable-with-set!
51 src2
52 (union (byte-cell-coalesceable-with src2)
53 (list dst))))))))
54 (let ((live-before (instr-live-before instr)))
55 (interfere-pairwise live-before)))
57 (define (bb-interference-graph bb)
58 (for-each instr-interference-graph (bb-rev-instrs bb)))
60 (analyze-liveness cfg)
62 (for-each bb-interference-graph (cfg-bbs cfg))
64 all-live)
66 (define (allocate-registers cfg)
67 (let ((all-live (interference-graph cfg)))
69 (define (color byte-cell)
70 (let ((coalesce-candidates ; TODO right now, no coalescing is done
71 (keep byte-cell-adr
72 (diff (byte-cell-coalesceable-with byte-cell)
73 (byte-cell-interferes-with byte-cell)))))
74 '
75 (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
76 coalesce-candidates
77 ; interferes-with: (byte-cell-interferes-with byte-cell)
78 ; coalesceable-with: (byte-cell-coalesceable-with byte-cell)
79 ))
81 (if #f #;(not (null? coalesce-candidates))
82 (let ((adr (byte-cell-adr (car coalesce-candidates))))
83 (byte-cell-adr-set! byte-cell adr))
84 (let ((neighbours (byte-cell-interferes-with byte-cell)))
85 (let loop1 ((adr 0))
86 (if (and memory-divide ; the user wants his own zone
87 (>= adr memory-divide)) ; and we'd use it
88 (error "register allocation would cross the memory divide") ;; TODO fallback ?
89 (let loop2 ((lst neighbours))
90 (if (null? lst)
91 (byte-cell-adr-set! byte-cell adr)
92 (let ((x (car lst)))
93 (if (= adr (byte-cell-adr x))
94 (loop1 (+ adr 1))
95 (loop2 (cdr lst))))))))))))
97 (define (delete byte-cell1 neighbours)
98 (for-each (lambda (byte-cell2)
99 (let ((lst (byte-cell-interferes-with byte-cell2)))
100 (byte-cell-interferes-with-set!
101 byte-cell2
102 (remove byte-cell1 lst))))
103 neighbours))
105 (define (undelete byte-cell1 neighbours)
106 (for-each (lambda (byte-cell2)
107 (let ((lst (byte-cell-interferes-with byte-cell2)))
108 (byte-cell-interferes-with-set!
109 byte-cell2
110 (cons byte-cell1 lst))))
111 neighbours))
113 (define (find-min-neighbours graph)
114 (let loop ((lst graph) (m #f) (byte-cell #f))
115 (if (null? lst)
116 byte-cell
117 (let* ((x (car lst))
118 (n (length (byte-cell-interferes-with x))))
119 (if (or (not m) (< n m))
120 (loop (cdr lst) n x)
121 (loop (cdr lst) m byte-cell))))))
123 (define (alloc-reg graph)
124 (if (not (null? graph))
125 (let* ((byte-cell (find-min-neighbours graph))
126 (neighbours (byte-cell-interferes-with byte-cell)))
127 (let ((new-graph (remove byte-cell graph)))
128 (delete byte-cell neighbours)
129 (alloc-reg new-graph)
130 (undelete byte-cell neighbours))
131 (if (not (byte-cell-adr byte-cell))
132 (color byte-cell)))))
134 (alloc-reg all-live)))
137 (define (linearize-and-cleanup cfg)
139 (define bbs-vector (cfg->vector cfg))
141 (define todo '())
143 (define (add-todo bb)
144 (set! todo (cons bb todo)))
146 (define rev-code '())
148 (define (emit instr)
149 (set! rev-code (cons instr rev-code)))
151 (define (movlw val)
152 (emit (list 'movlw val)))
154 (define (movwf adr)
155 (emit (list 'movwf adr)))
157 (define (movfw adr)
158 (emit (list 'movfw adr)))
160 (define (movff src dst)
161 (emit (list 'movff src dst)))
163 (define (clrf adr)
164 (emit (list 'clrf adr)))
166 (define (setf adr)
167 (emit (list 'setf adr)))
169 (define (incf adr)
170 (emit (list 'incf adr)))
172 (define (decf adr)
173 (emit (list 'decf adr)))
175 (define (addwf adr)
176 (emit (list 'addwf adr)))
178 (define (addwfc adr)
179 (emit (list 'addwfc adr)))
181 (define (subwf adr)
182 (emit (list 'subwf adr)))
184 (define (subwfb adr)
185 (emit (list 'subwfb adr)))
187 (define (cpfseq adr)
188 (emit (list 'cpfseq adr)))
190 (define (cpfslt adr)
191 (emit (list 'cpfslt adr)))
193 (define (cpfsgt adr)
194 (emit (list 'cpfsgt adr)))
196 (define (bra label)
197 (emit (list 'bra label)))
199 (define (rcall label)
200 (emit (list 'rcall label)))
202 (define (return)
203 (if (and #f (and (not (null? rev-code)) ; TODO probably here for eventual inlining
204 (eq? (caar rev-code) 'rcall)))
205 (let ((label (cadar rev-code)))
206 (set! rev-code (cdr rev-code))
207 (bra label))
208 (emit (list 'return))))
210 (define (label lab)
211 (if (and #f (and (not (null? rev-code)) ; TODO would probably be useful to eliminate things like : bra $2, $2:
212 (eq? (caar rev-code) 'bra)
213 (eq? (cadar rev-code) lab)))
214 (begin
215 (set! rev-code (cdr rev-code))
216 (label lab))
217 (emit (list 'label lab))))
219 (define (sleep)
220 (emit (list 'sleep)))
222 (define (move-reg src dst)
223 (cond ((= src dst))
224 ((= src WREG)
225 (movwf dst))
226 ((= dst WREG)
227 (movfw src))
228 (else
229 (movfw src)
230 (movwf dst)
231 ;(movff src dst) ; takes 2 cycles (as much as movfw src ; movwf dst), but takes only 1 instruction TODO not implemented in the simulator
232 )))
234 (define (bb-linearize bb)
235 (let ((label-num (bb-label-num bb)))
236 (let ((bb (vector-ref bbs-vector label-num)))
238 (define (move-lit n adr)
239 (cond ((= n 0)
240 (clrf adr))
241 ((= n #xff)
242 (setf adr))
243 (else
244 (movlw n)
245 (movwf adr))))
247 (define (dump-instr instr)
248 (cond ((call-instr? instr)
249 (let* ((def-proc (call-instr-def-proc instr))
250 (entry (def-procedure-entry def-proc)))
251 (if (bb? entry)
252 (begin
253 (add-todo entry)
254 (let ((label (bb-label entry)))
255 (rcall label)))
256 (rcall entry))))
257 ((return-instr? instr)
258 (return))
259 (else
260 (let ((src1 (instr-src1 instr))
261 (src2 (instr-src2 instr))
262 (dst (instr-dst instr)))
263 (if (and (or (not (byte-cell? dst))
264 (byte-cell-adr dst))
265 (or (not (byte-cell? src1))
266 (byte-cell-adr src1))
267 (or (not (byte-cell? src2))
268 (byte-cell-adr src2)))
269 (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))))
278 ((add addc sub subb)
279 (if (byte-lit? src2)
280 (let ((n (byte-lit-val src2))
281 (z (byte-cell-adr dst)))
282 (if (byte-lit? src1)
283 (move-lit (byte-lit-val src1) z)
284 (move-reg (byte-cell-adr src1) z))
285 (case (instr-id instr)
286 ((add)
287 (cond ((= n 1)
288 (incf z))
289 ((= n #xff)
290 (decf z))
291 (else
292 (movlw n)
293 (addwf z))))
294 ((addc)
295 (movlw n)
296 (addwfc z))
297 ((sub)
298 (cond ((= n 1)
299 (decf z))
300 ((= n #xff)
301 (incf z))
302 (else
303 (movlw n)
304 (subwf z))))
305 ((subb)
306 (movlw n)
307 (subwfb z))))
308 (let ((x (byte-cell-adr src1))
309 (y (byte-cell-adr src2))
310 (z (byte-cell-adr dst)))
311 (cond ((and (not (= x y)) (= y z))
312 (move-reg x WREG)
313 (case (instr-id instr)
314 ((add)
315 (addwf z))
316 ((addc)
317 (addwfc z))
318 ((sub)
319 (subwfr z))
320 ((subb)
321 (subwfbr z))
322 (else (error "..."))))
323 (else
324 (move-reg x z)
325 (move-reg y WREG)
326 (case (instr-id instr)
327 ((add)
328 (addwf z))
329 ((addc)
330 (addwfc z))
331 ((sub)
332 (subwf z))
333 ((subb)
334 (subwfb z))
335 (else (error "..."))))))))
336 ((goto)
337 (let* ((succs (bb-succs bb))
338 (dest (car succs)))
339 (bra (bb-label dest))
340 (add-todo dest)))
341 ((x==y x<y x>y)
342 (let* ((succs (bb-succs bb))
343 (dest-true (car succs))
344 (dest-false (cadr succs)))
346 (define (compare flip adr)
347 (case (instr-id instr)
348 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
349 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
350 (else (cpfseq adr)))
351 (bra (bb-label dest-false))
352 (bra (bb-label dest-true))
353 (add-todo dest-false)
354 (add-todo dest-true))
356 (cond ((byte-lit? src1)
357 (let ((n (byte-lit-val src1))
358 (y (byte-cell-adr src2)))
359 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
360 (eq? (instr-id instr) 'x==y))
361 (special-compare-eq-lit n x)
362 (begin
363 (movlw n)
364 (compare #t y)))))
365 ((byte-lit? src2)
366 (let ((x (byte-cell-adr src1))
367 (n (byte-lit-val src2)))
368 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
369 (eq? (instr-id instr) 'x==y))
370 (special-compare-eq-lit n x) ;; TODO does not exist. the only way apart from cpfseq I see would be to load w, do a subtraction, then conditional branch, but would be larger and would take 1-2 cycles more
371 (begin
372 (movlw n)
373 (compare #f x)))))
374 (else
375 (let ((x (byte-cell-adr src1))
376 (y (byte-cell-adr src2)))
377 (move-reg y WREG)
378 (compare #f x))))))
379 (else
380 ;...
381 (emit (list (instr-id instr))))))))))
383 (if bb
384 (begin
385 (vector-set! bbs-vector label-num #f)
386 (label (bb-label bb))
387 (for-each dump-instr (reverse (bb-rev-instrs bb)))
388 (for-each add-todo (bb-succs bb)))))))
390 (let ((prog-label (asm-make-label 'PROG)))
391 (rcall prog-label)
392 (sleep)
393 (label prog-label))
395 (add-todo (vector-ref bbs-vector 0))
397 (let loop ()
398 (if (null? todo)
399 (reverse rev-code)
400 (let ((bb (car todo)))
401 (set! todo (cdr todo))
402 (bb-linearize bb)
403 (loop)))))
406 (define (assembler-gen filename cfg)
408 (define (gen instr)
409 (case (car instr)
410 ((movlw)
411 (movlw (cadr instr)))
412 ((movwf)
413 (movwf (cadr instr)))
414 ((movfw)
415 (movf (cadr instr) 'w))
416 ((movff)
417 (movff (cadr instr) (caddr instr)))
418 ((clrf)
419 (clrf (cadr instr)))
420 ((setf)
421 (setf (cadr instr)))
422 ((incf)
423 (incf (cadr instr)))
424 ((decf)
425 (decf (cadr instr)))
426 ((addwf)
427 (addwf (cadr instr)))
428 ((addwfc)
429 (addwfc (cadr instr)))
430 ((subwf)
431 (subwf (cadr instr)))
432 ((subwfb)
433 (subwfb (cadr instr)))
434 ((cpfseq)
435 (cpfseq (cadr instr)))
436 ((cpfslt)
437 (cpfslt (cadr instr)))
438 ((cpfsgt)
439 (cpfsgt (cadr instr)))
440 ((bra)
441 (bra (cadr instr)))
442 ((rcall)
443 (rcall (cadr instr)))
444 ((return)
445 (return))
446 ((label)
447 (asm-listing
448 (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
449 (asm-label (cadr instr)))
450 ((sleep)
451 (sleep))
452 (else
453 (error "unknown instruction" instr))))
455 (asm-begin! 0 #f)
457 ; (pretty-print cfg)
459 (let ((code (linearize-and-cleanup cfg)))
460 ; (pretty-print code)
461 (for-each gen code))
463 (asm-assemble)
465 '(display "------------------ GENERATED CODE\n")
467 (asm-display-listing (current-output-port))
469 (asm-write-hex-file (string-append filename ".hex")) ;; TODO move to main ?
471 (asm-end!))
473 (define (code-gen filename cfg)
474 (allocate-registers cfg)
475 (assembler-gen filename cfg)
476 ; (pretty-print cfg)
477 ; (pretty-print (reverse (bb-rev-instrs bb))) ;; TODO what ? there are no bbs here...
478 )