| blob | 10f8708dc27e8505b48fc124a5251f2ca30ffd8d |
1 (define bank-1-used? #f)
3 (define (linearize-and-cleanup cfg)
5 (define bbs-vector (cfg->vector cfg))
7 (define todo '())
9 (define (add-todo bb)
10 (set! todo (cons bb todo)))
12 (define rev-code '())
14 (define (emit instr)
15 (set! rev-code (cons instr rev-code)))
17 (define (outside-bank-0? adr)
18 (if (and (> adr #x5F) (< adr #xF60)) ; not a special register
19 (begin (set! bank-1-used? #t) #t)
20 #f))
21 (define (emit-byte-oriented op file #!optional (d? #t) (w? #f))
22 ;; we might have to access the second bank
23 (emit (if (outside-bank-0? file)
24 (if d?
25 (list op (- file 96) (if w? 'w 'f) 'b)
26 (list op (- file 96) 'b))
27 (if d?
28 (list op file (if w? 'w 'f) 'a)
29 (list op file 'a)))))
30 (define (emit-bit-oriented op file bit)
31 (emit (if (outside-bank-0? file)
32 (list op (- file 96) bit 'b)
33 (list op file bit 'a))))
35 (define (movlw val)
36 (emit (list 'movlw val)))
37 (define (movwf adr)
38 (emit-byte-oriented 'movwf adr #f))
39 (define (movfw adr)
40 (emit-byte-oriented 'movf adr #t #t))
41 (define (movff src dst)
42 ;; anything over #x5f is in the second bank (at #x100)
43 (let ((src (if (outside-bank-0? src)
44 (+ src #xa0)
45 src))
46 (dst (if (outside-bank-0? dst)
47 (+ dst #xa0)
48 dst)))
49 (emit (list 'movff src dst))))
51 (define (clrf adr)
52 (emit-byte-oriented 'clrf adr #f))
53 (define (setf adr)
54 (emit-byte-oriented 'setf adr #f))
56 (define (incf adr)
57 (emit-byte-oriented 'incf adr))
58 (define (decf adr)
59 (emit-byte-oriented 'decf adr))
61 (define (addwf adr)
62 (emit-byte-oriented 'addwf adr))
63 (define (addwfc adr)
64 (emit-byte-oriented 'addwfc adr))
66 (define (subwf adr)
67 (emit-byte-oriented 'subwf adr))
68 (define (subwfb adr)
69 (emit-byte-oriented 'subwfb adr))
71 (define (mullw adr)
72 (emit (list 'mullw adr)))
73 (define (mulwf adr)
74 (emit-byte-oriented 'mulwf adr #f))
76 (define (andwf adr)
77 (emit-byte-oriented 'andwf adr))
78 (define (iorwf adr)
79 (emit-byte-oriented 'iorwf adr))
80 (define (xorwf adr)
81 (emit-byte-oriented 'xorwf adr))
83 (define (rlcf adr)
84 (emit-byte-oriented 'rlcf adr))
85 (define (rrcf adr)
86 (emit-byte-oriented 'rrcf adr))
88 (define (bcf adr bit)
89 (emit-bit-oriented 'bcf adr bit))
90 (define (bsf adr bit)
91 (emit-bit-oriented 'bsf adr bit))
92 (define (btg adr bit)
93 (emit-bit-oriented 'btg adr bit))
95 (define (comf adr)
96 (emit-byte-oriented 'comf adr))
98 (define (tblrd) ;; TODO support the different modes
99 (emit (list 'tblrd)))
101 (define (cpfseq adr)
102 (emit-byte-oriented 'cpfseq adr #f))
103 (define (cpfslt adr)
104 (emit-byte-oriented 'cpfslt adr #f))
105 (define (cpfsgt adr)
106 (emit-byte-oriented 'cpfsgt adr #f))
108 (define (bc label)
109 (emit (list 'bc label)))
110 (define (bra-or-goto label)
111 (emit (list 'bra-or-goto label)))
112 (define (goto label)
113 (emit (list 'goto label)))
115 (define (rcall label)
116 (emit (list 'rcall label)))
118 (define (return)
119 (if (and #f (and (not (null? rev-code))
120 (eq? (caar rev-code) 'rcall)))
121 (let ((label (cadar rev-code)))
122 (set! rev-code (cdr rev-code))
123 (bra-or-goto label))
124 (emit (list 'return))))
126 (define (label lab)
127 (if (and (and (not (null? rev-code)) ;; TODO have a flag to disable this optimization
128 (or (eq? (caar rev-code) 'bra-or-goto)
129 (eq? (caar rev-code) 'goto))
130 (eq? (cadar rev-code) lab)))
131 (begin
132 (set! rev-code (cdr rev-code))
133 (label lab))
134 (emit (list 'label lab))))
136 (define (sleep)
137 (emit (list 'sleep)))
139 (define (move-reg src dst)
140 (cond ((= src dst))
141 ((= src WREG)
142 (movwf dst))
143 ((= dst WREG)
144 (movfw src))
145 (else
146 ;; (movfw src)
147 ;; (movwf dst)
148 ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
149 ;; only 1 instruction
150 (movff src dst))))
152 (define (bb-linearize bb)
153 (let ((label-num (bb-label-num bb)))
154 (let ((bb (vector-ref bbs-vector label-num)))
156 (define (move-lit n adr)
157 (cond ((= n 0)
158 (clrf adr))
159 ((= n #xff)
160 (setf adr))
161 (else
162 (movlw n)
163 (movwf adr))))
165 ;; when eliminating additions/substractions, it is important that the
166 ;; next one ignores the carry/borrow, to avoid using a leftover carry
167 ;; from an earlier operation
168 (define ignore-carry-borrow? #f)
170 (define (dump-instr instr)
171 (cond ((call-instr? instr)
172 (let* ((def-proc (call-instr-def-proc instr))
173 (entry (def-procedure-entry def-proc)))
174 (if (bb? entry)
175 (begin
176 (add-todo entry)
177 (let ((label (bb-label entry)))
178 (rcall label)))
179 (rcall entry))))
180 ((return-instr? instr)
181 (return))
182 (else
183 (let ((src1 (instr-src1 instr))
184 (src2 (instr-src2 instr))
185 (dst (instr-dst instr))
186 (id (instr-id instr)))
187 (if (and (or (not (byte-cell? dst))
188 (and (byte-cell-adr dst)
189 ;; must go in a special register, or in a
190 ;; live variable, or else don't generate
191 ;; the instruction
192 #;(or (assq (byte-cell-adr dst) ;; TODO eliminating instructions does not work, too many are eliminated, it seems
193 file-reg-names)
194 ;; if the instruction affects the
195 ;; carry, it must be generated
196 (memq id carry-affecting-instrs)
197 ;; destination is used
198 (bitset-member?
199 (instr-live-after instr)
200 (byte-cell-id dst)))))
201 (or (not (byte-cell? src1))
202 (byte-cell-adr src1))
203 (or (not (byte-cell? src2))
204 (byte-cell-adr src2)))
206 (case id
208 ((move)
209 (if (byte-lit? src1)
210 (let ((n (byte-lit-val src1))
211 (z (byte-cell-adr dst)))
212 (move-lit n z))
213 (let ((x (byte-cell-adr src1))
214 (z (byte-cell-adr dst)))
215 (move-reg x z))))
217 ((add addc sub subb)
218 (if (byte-lit? src2)
219 (let ((n (byte-lit-val src2))
220 (z (byte-cell-adr dst)))
221 (if (byte-lit? src1)
222 (move-lit (byte-lit-val src1) z)
223 (move-reg (byte-cell-adr src1) z))
224 (if (and (= n 0) ; nop
225 (or (eq? id 'add)
226 (eq? id 'sub)))
227 (set! ignore-carry-borrow? #t)
228 (begin
229 (case id
230 ((add) (cond ((= n 1) (incf z))
231 ;; ((= n #xff) (decf z)) ;; TODO set the carry
232 (else (movlw n)
233 (addwf z))))
234 ((addc)
235 (movlw n)
236 (if ignore-carry-borrow?
237 (addwf z)
238 (addwfc z)))
239 ((sub) (cond ((= n 1) (decf z))
240 ;; ((= n #xff) (incf z)) ;; TODO same
241 (else (movlw n)
242 (subwf z))))
243 ((subb)
244 (movlw n)
245 (if ignore-carry-borrow?
246 (subwf z)
247 (subwfb z))))
248 (set! ignore-carry-borrow? #f))))
249 (let ((x (or (and (byte-cell? src1) (byte-cell-adr src1)) 0)) ;; FOO this should not be needed (or correct), but without it, PICOBIT without bignums won't compile. it gives the right results for the vectors test, haven't checked the others.
250 (y (byte-cell-adr src2))
251 (z (byte-cell-adr dst)))
252 (cond ((and (not (= x y))
253 (= y z)
254 (memq id '(add addc)))
255 ;; since this basically swaps the
256 ;; arguments, it can't be used for
257 ;; subtraction
258 (move-reg x WREG))
259 ((and (not (= x y))
260 (= y z))
261 ;; for subtraction, preserves argument
262 ;; order
263 (move-reg y WREG)
264 ;; this NEEDS to be done with movff, or
265 ;; else wreg will get clobbered and this
266 ;; won't work
267 (move-reg x z))
268 (else ;; TODO check if it could be merged with the previous case
269 (move-reg x z)
270 (move-reg y WREG)))
271 (case id
272 ((add) (addwf z))
273 ((addc) (if ignore-carry-borrow?
274 (addwf z)
275 (addwfc z)))
276 ((sub) (subwf z))
277 ((subb) (if ignore-carry-borrow?
278 (subwf z)
279 (subwfb z)))
280 (else (error "...")))
281 (set! ignore-carry-borrow? #f))))
283 ((mul) ; 8 by 8 multiplication
284 (if (byte-lit? src2)
285 ;; since multiplication is commutative, the
286 ;; arguments are set up so the second one will
287 ;; be a literal if the operator is applied on a
288 ;; literal and a variable
289 (let ((n (byte-lit-val src2)))
290 (if (byte-lit? src1)
291 (movlw (byte-lit-val src1))
292 (move-reg (byte-cell-adr src1) WREG))
293 ;; literal multiplication
294 (mullw n))
295 (let ((x (byte-cell-adr src1))
296 (y (byte-cell-adr src2)))
297 (move-reg x WREG)
298 (mulwf y))))
300 ((and ior xor)
301 (let* ((x (if (byte-lit? src1)
302 (byte-lit-val src1)
303 (byte-cell-adr src1)))
304 (y (if (byte-lit? src2)
305 (byte-lit-val src2)
306 (byte-cell-adr src2)))
307 (z (byte-cell-adr dst))
308 (f (case id
309 ((and) andwf)
310 ((ior) iorwf)
311 ((xor) xorwf)
312 (else (error "...")))))
313 (if (byte-lit? src2)
314 (cond ((byte-lit? src1)
315 ;; low-level constant folding
316 (move-lit ((case id
317 ((and) bitwise-and)
318 ((ior) bitwise-ior)
319 ((xor) bitwise-xor))
320 x y)
321 z))
322 ((or (and (eq? id 'and) (= y #xff))
323 (and (eq? id 'ior) (= y #x00)))
324 ;; nop, just move the value
325 (move-reg x z))
326 ((and (eq? id 'and)
327 (= y #x00))
328 (clrf z))
329 ((and (eq? id 'ior) (= y #xff))
330 (setf z))
331 ;; use bit-set or bit-toggle
332 ((and (memq id '(ior xor))
333 ;; a single bit is set
334 (memq y '(#x01 #x02 #x04 #x08
335 #x10 #x20 #x40 #x80))
336 (eq? x z))
337 ((if (eq? id 'ior) bsf btg)
338 z (inexact->exact
339 (/ (log y) (log 2)))))
340 ;; use bit-clear
341 ((and (eq? id 'and)
342 ;; a single bit is unset
343 (memq y '(#x7f #xbf #xdf #xef
344 #xf7 #xfb #xfd #xfe))
345 (eq? x z))
346 (bcf z (inexact->exact
347 (/ (log (- #xff y))
348 (log 2))))) ;; TODO since this requires x and z to be in the same place to be efficient, maybe coalesce theses cases in priority ? for now, this optimization does not save much
349 (else
350 (move-reg x z)
351 (movlw y)
352 (f z)))
353 (begin (if (and (not (= x y)) (= y z))
354 (move-reg x WREG)
355 (begin
356 (move-reg x z)
357 (move-reg y WREG)))
358 (f z)))))
360 ((shl shr)
361 (let ((x (if (byte-lit? src1)
362 (byte-lit-val src1)
363 (byte-cell-adr src1)))
364 (z (byte-cell-adr dst)))
365 (cond ((byte-lit? src1) (move-lit x z))
366 ((not (= x z)) (move-reg x z)))
367 (case id
368 ((shl) (rlcf z))
369 ((shr) (rrcf z)))))
371 ((set clear toggle)
372 ;; bit operations
373 (if (not (byte-lit? src2))
374 (error "bit offset must be a literal"))
375 (let ((x (byte-cell-adr src1))
376 (y (byte-lit-val src2)))
377 (case id
378 ((set) (bsf x y))
379 ((clear) (bcf x y))
380 ((toggle) (btg x y)))))
382 ((not)
383 (let ((z (byte-cell-adr dst)))
384 (if (byte-lit? src1)
385 (move-lit (byte-lit-val src1) z)
386 (move-reg (byte-cell-adr src1) z))
387 (comf z)))
389 ((tblrd)
390 (if (byte-lit? src1)
391 (move-lit (byte-lit-val src1) TBLPTRL)
392 (move-reg (byte-cell-adr src1) TBLPTRL))
393 (if (byte-lit? src2)
394 (move-lit (byte-lit-val src2) TBLPTRH)
395 (move-reg (byte-cell-adr src2) TBLPTRH))
396 ;; TODO the 5 high bits are not used for now
397 (tblrd))
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-or-goto (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 id
413 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
414 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
415 (else (cpfseq adr)))
416 (bra-or-goto (bb-label dest-false))
417 (bra-or-goto (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? id '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? id '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))))))
445 ((branch-if-carry)
446 (let* ((succs (bb-succs bb))
447 (dest-true (car succs))
448 (dest-false (cadr succs))
449 ;; scratch is always a byte cell
450 (scratch (byte-cell-adr src1)))
451 ;; note : bc is too short for some cases
452 ;; (bc (bb-label dest-true))
453 ;; (bra-or-goto (bb-label dest-false))
454 ;; instead, we use scratch to indirectly test the
455 ;; carry and use regular branches
456 (clrf scratch)
457 (clrf WREG)
458 (addwfc scratch)
459 (cpfsgt scratch)
460 (bra-or-goto (bb-label dest-false))
461 (bra-or-goto (bb-label dest-true))
462 (add-todo dest-false)
463 (add-todo dest-true)))
465 ((branch-table)
466 (let* ((off (if (byte-lit? src1) ; branch no
467 (byte-lit-val src1)
468 (byte-cell-adr src1)))
469 (scratch (byte-cell-adr src2)) ; working space
470 (succs (bb-succs bb))
471 (n-succs (length succs)))
474 ;; ;; size of the branch table (without the
475 ;; ;; offset-calculating code), if it uses short jumps
476 ;; ;; that take 2 bytes per instruction
477 ;; (let ((size-using-bra (* 2 n-succs))
478 ;; ;; size of the offset-calculating code, if we
479 ;; ;; use short jumps
480 ;; (bra-header-size ))
482 ;; (asm-at-assembly
483 ;; ;; check if the targets are close enough to use
484 ;; ;; short jumps. all the targets must be close
485 ;; ;; enough, since all jumps must be of the same
486 ;; ;; size
487 ;; (lambda (self)
488 ;; (foldl
489 ;; (lambda (acc new)
490 ;; (and acc
491 ;; (let ((dist (- (label-pos (car new))
492 ;; (+ self (cdr new)))))
493 ;; ;; close enough for short jumps
494 ;; (if (and (>= dist -2048)
495 ;; (<= dist 2047)
496 ;; (even? dist))
497 ;; 2
498 ;; #f))))
499 ;; #t
500 ;; (map
501 ;; (lambda (l n)
502 ;; (cons l (+ self n bra-header-size)))
503 ;; succs (iota n-succs)))))) ;; FOO no time for this for the moment
506 ;; precalculate the low byte of the PC
507 ;; note: both branches (off is a literal or a
508 ;; register) are of the same length in terms of
509 ;; code, which is important
510 (if (byte-lit? src1)
511 (movlw off)
512 (movfw off))
513 ;; we add 4 times the offset, since gotos are 4
514 ;; bytes long
515 (if (byte-lit? src1)
516 (begin (movlw off)
517 (movwf scratch))
518 (movff off scratch))
519 (addwf scratch)
520 (addwf scratch)
521 (addwf scratch)
522 ;; to compensate for the PC advancing while we calculate
523 (movlw 10)
524 (addwf scratch)
525 (movfw PCL) ;; TODO at assembly, this can all be known statically
526 (addwf scratch)
527 (clrf WREG)
528 (addwfc PCLATH)
529 (movff scratch PCL)
531 ;; create the jump table
532 (for-each (lambda (bb)
533 (goto (bb-label bb))
534 (add-todo bb))
535 succs)))
537 (else
538 ;; ...
539 (emit (list id)))))))))
541 (if bb
542 (begin
543 (vector-set! bbs-vector label-num #f)
544 (label (bb-label bb))
545 (for-each dump-instr (reverse (bb-rev-instrs bb))))))))
547 (let ((prog-label (asm-make-label 'PROG)))
548 (rcall prog-label)
549 (sleep)
550 (label prog-label))
552 (add-todo (vector-ref bbs-vector 0))
554 (let loop ()
555 (if (null? todo)
556 (reverse rev-code)
557 (let ((bb (car todo)))
558 (set! todo (cdr todo))
559 (bb-linearize bb)
560 (loop)))))
563 (define (assembler-gen filename cfg)
565 (define (gen instr)
566 (define (gen-1-arg)
567 ((eval (car instr)) (cadr instr)))
568 (define (gen-2-args)
569 ((eval (car instr)) (cadr instr) (caddr instr)))
570 (define (gen-3-args)
571 ((eval (car instr)) (cadr instr) (caddr instr) (cadddr instr)))
573 (let ((id (car instr)))
574 ;; count instructions by kind
575 (table-set! concrete-instructions-counts id
576 (+ (table-ref concrete-instructions-counts id 0) 1))
577 (case id
578 ((movlw mullw)
579 (gen-1-arg))
580 ((movff movwf clrf setf cpfseq cpfslt cpfsgt mulwf)
581 (gen-2-args))
582 ((incf decf addwf addwfc subwf subwfb andwf iorwf xorwf rlcf rrcf comf
583 bcf bsf btg movf)
584 (gen-3-args))
585 ((tblrd)
586 (tblrd*)) ;; TODO support the other modes
587 ((bc)
588 (bc (cadr instr)))
589 ((bra)
590 (bra (cadr instr)))
591 ((goto)
592 (goto (cadr instr)))
593 ((bra-or-goto)
594 (bra-or-goto (cadr instr)))
595 ((rcall)
596 (rcall-or-call (cadr instr)))
597 ((return)
598 (return))
599 ((label)
600 (asm-listing
601 (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
602 (asm-label (cadr instr)))
603 ((sleep)
604 (sleep))
605 (else
606 (error "unknown instruction" instr)))))
608 (asm-begin! 0 #f)
610 ;; (pretty-print cfg)
612 (let ((code (linearize-and-cleanup cfg)))
613 ;; (pretty-print code)
614 ;; if we would need a second bank, load the address for the second bank in BSR
615 (if bank-1-used?
616 (begin (gen (list 'movlw 1))
617 (gen (list 'movwf BSR 'a))))
618 (for-each gen code)))