| blob | cfea222dc6b2a4a992c03844858d8cc74aa9283a |
1 ;;; generation of control flow graph
3 ;; special variables whose contents are located in the FSR registers
4 (define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2))
6 (define-type cfg
7 bbs
8 next-label-num)
10 (define (new-cfg)
11 (make-cfg '() 0))
13 (define-type bb
14 label-num
15 label-name ; if the block had a label
16 label
17 rev-instrs
18 unprintable:
19 preds
20 succs
21 live-before)
23 (define-type instr
24 extender: define-type-of-instr
25 (live-before unprintable:)
26 (live-after unprintable:)
27 (hash unprintable:)
28 id
29 src1
30 src2
31 dst)
33 (define-type-of-instr call-instr
34 unprintable:
35 def-proc)
37 (define-type-of-instr return-instr
38 unprintable:
39 def-proc)
41 (define (new-instr id src1 src2 dst)
42 (make-instr '() '() #f id src1 src2 dst))
44 ;; list of all conditional branching generic instructions
45 (define conditional-instrs ;; TODO add as we add specialized instructions
46 '(x==y x!=y x<y x>y x<=y x>=y))
48 (define (new-call-instr def-proc)
49 (make-call-instr '() '() #f 'call #f #f #f def-proc))
51 (define (new-return-instr def-proc)
52 (make-return-instr '() '() #f 'return #f #f #f def-proc))
54 (define (add-bb cfg)
55 (let* ((label-num (cfg-next-label-num cfg))
56 (bb (make-bb label-num #f #f '() '() '() '())))
57 (bb-label-set!
58 bb
59 (asm-make-label
60 (string->symbol
61 (string-append "$"
62 (number->string label-num)))))
63 (cfg-bbs-set! cfg (cons bb (cfg-bbs cfg)))
64 (cfg-next-label-num-set! cfg (+ 1 (cfg-next-label-num cfg)))
65 bb))
67 (define (add-instr bb instr)
68 (let ((rev-instrs (bb-rev-instrs bb)))
69 (bb-rev-instrs-set! bb (cons instr rev-instrs))))
71 (define (add-succ bb succ)
72 (bb-succs-set! bb (cons succ (bb-succs bb)))
73 (bb-preds-set! succ (cons bb (bb-preds succ))))
75 (define (generate-cfg ast)
77 (define cfg (new-cfg))
79 (define bb #f) ; current bb
81 (define (in x) (set! bb x))
83 (define (new-bb) (add-bb cfg))
85 (define (emit instr) (add-instr bb instr))
87 (define current-def-proc #f)
88 (define break-stack '())
89 (define continue-stack '())
90 (define delayed-post-incdec '())
92 (define (push-break x) (set! break-stack (cons x break-stack)))
93 (define (pop-break) (set! break-stack (cdr break-stack)))
95 (define (push-continue x) (set! continue-stack (cons x continue-stack)))
96 (define (pop-continue) (set! continue-stack (cdr continue-stack)))
98 (define (push-delayed-post-incdec ast)
99 (set! delayed-post-incdec (cons ast delayed-post-incdec))
100 ;; moves the original value to a new location (so it won't be modified)
101 ;; and returns that location to the original expression
102 (let ((x (subast1 ast)))
103 (if (not (ref? x))
104 (error "assignment target must be a variable")
105 (let* ((def-var (ref-def-var x))
106 (result (alloc-value (def-variable-type def-var))))
107 (move-value (def-variable-value def-var) result)
108 result))))
110 (define (program ast)
111 (let loop ((asts (ast-subasts ast)))
112 (if (not (null? asts))
113 (let ((ast (car asts)))
114 (if (null? (cdr asts))
115 (let ((value (expression ast)))
116 (return-with-no-new-bb value))
117 (begin
118 (toplevel ast)
119 (loop (cdr asts))))))))
121 (define (toplevel ast)
122 (cond ((def-variable? ast)
123 (def-variable ast))
124 ((def-procedure? ast)
125 (def-procedure ast))
126 (else
127 (statement ast))))
129 (define (def-variable ast)
130 (let ((subasts (ast-subasts ast)))
131 (if (not (null? subasts)) ; if needed, set the variable
132 (let ((value (expression (subast1 ast))))
133 (let ((ext-value (extend value (def-variable-type ast))))
134 (move-value value (def-variable-value ast)))))))
136 ;; resolve the C gotos by setting the appropriate successor to their bb
137 (define (resolve-all-gotos start table visited)
138 (if (not (memq start visited))
139 (begin (for-each (lambda (x)
140 (if (and (eq? (instr-id x) 'goto)
141 (instr-dst x)) ; unresolved label
142 (let ((target (assoc (instr-dst x) table)))
143 (if target
144 (begin (add-succ start (cdr target))
145 (instr-dst-set! x #f))
146 (error "invalid goto target" (instr-dst x))))))
147 (bb-rev-instrs start))
148 (for-each (lambda (x)
149 (resolve-all-gotos x table (cons start visited)))
150 (bb-succs start)))))
152 (define (def-procedure ast)
153 (let ((old-bb bb)
154 (entry (new-bb)))
155 (def-procedure-entry-set! ast entry)
156 (set! current-def-proc ast)
157 (in entry)
158 (for-each statement (ast-subasts ast))
159 (return-with-no-new-bb ast)
160 (set! current-def-proc #f)
161 (resolve-all-gotos entry (list-named-bbs entry '()) '())
162 (in old-bb)))
164 ;; returns a list of all named bbs in the successor-tree of a given bb
165 (define (list-named-bbs start visited)
166 (if (not (memq start visited))
167 (let ((succs
168 (apply append
169 (map (lambda (bb) (list-named-bbs bb (cons start visited)))
170 (bb-succs start)))))
171 (if (bb-label-name start)
172 (cons (cons (bb-label-name start) start) succs)
173 succs))
174 '()))
176 (define (statement ast)
177 (cond ((def-variable? ast) (def-variable ast))
178 ((block? ast) (block ast))
179 ((return? ast) (return ast))
180 ((if? ast) (if (null? (cddr (ast-subasts ast)))
181 (if1 ast)
182 (if2 ast)))
183 ((while? ast) (while ast))
184 ((do-while? ast) (do-while ast))
185 ((for? ast) (for ast))
186 ((switch? ast) (switch ast))
187 ((break? ast) (break ast))
188 ((continue? ast) (continue ast))
189 ((goto? ast) (goto ast))
190 (else (expression ast))))
192 (define (block ast)
193 (if (block-name ast) ; named block ?
194 (begin (let ((new (new-bb)))
195 (gen-goto new)
196 (in new))
197 (bb-label-name-set! bb (block-name ast)) ))
198 (for-each statement (ast-subasts ast)))
200 (define (move from to)
201 (emit (new-instr 'move from #f to)))
203 (define (move-value from to)
204 (let loop ((from (value-bytes from))
205 (to (value-bytes to)))
206 (cond ((null? to)) ; done, we truncate the rest
207 ((null? from) ; promote the value by padding
208 (move (new-byte-lit 0) (car to))
209 (loop from (cdr to)))
210 (else
211 (move (car from) (car to))
212 (loop (cdr from) (cdr to))))))
214 (define (return-with-no-new-bb def-proc)
215 (emit (new-return-instr def-proc)))
217 (define (return ast)
218 (if (null? (ast-subasts ast))
219 (return-with-no-new-bb current-def-proc)
220 (let ((value (expression (subast1 ast))))
221 (let ((ext-value (extend value (def-procedure-type current-def-proc))))
222 (move-value value (def-procedure-value current-def-proc))
223 (return-with-no-new-bb current-def-proc))))
224 (in (new-bb)))
226 (define (if1 ast)
227 (let* ((bb-join (new-bb))
228 (bb-then (new-bb)))
229 (test-expression (subast1 ast) bb-then bb-join)
230 (in bb-then)
231 (statement (subast2 ast))
232 (gen-goto bb-join)
233 (in bb-join)))
235 (define (if2 ast)
236 (let* ((bb-join (new-bb))
237 (bb-then (new-bb))
238 (bb-else (new-bb)))
239 (test-expression (subast1 ast) bb-then bb-else)
240 (in bb-then)
241 (statement (subast2 ast))
242 (gen-goto bb-join)
243 (in bb-else)
244 (statement (subast3 ast))
245 (gen-goto bb-join)
246 (in bb-join)))
248 (define (while ast)
249 (let* ((bb-cont (new-bb))
250 (bb-exit (new-bb))
251 (bb-body (new-bb)))
252 (push-continue bb-cont)
253 (push-break bb-exit)
254 (gen-goto bb-cont)
255 (in bb-cont)
256 (test-expression (subast1 ast) bb-body bb-exit)
257 (in bb-body)
258 (statement (subast2 ast))
259 (gen-goto bb-cont)
260 (in bb-exit)
261 (pop-continue)
262 (pop-break)))
264 (define (do-while ast)
265 (let* ((bb-body (new-bb))
266 (bb-cont (new-bb))
267 (bb-exit (new-bb)))
268 (push-continue bb-cont)
269 (push-break bb-exit)
270 (in bb-body)
271 (statement (subast1 ast))
272 (in bb-cont)
273 (test-expression (subast2 ast) bb-body bb-exit)
274 (in bb-exit)
275 (pop-continue)
276 (pop-break)))
278 (define (for ast)
279 (let* ((bb-loop (new-bb))
280 (bb-body (new-bb))
281 (bb-cont (new-bb))
282 (bb-exit (new-bb)))
283 (statement (subast1 ast))
284 (gen-goto bb-loop)
285 (push-continue bb-cont)
286 (push-break bb-exit)
287 (in bb-loop)
288 (test-expression (subast2 ast) bb-body bb-exit)
289 (in bb-body)
290 (statement (subast4 ast))
291 (gen-goto bb-cont)
292 (in bb-cont)
293 (statement (subast3 ast))
294 (gen-goto bb-loop)
295 (in bb-exit)
296 (pop-continue)
297 (pop-break)))
299 (define (switch ast)
300 (let* ((var (subast1 ast))
301 (case-list #f)
302 (default #f)
303 (decision-bb bb)
304 (exit-bb (new-bb))
305 (prev-bb decision-bb))
306 (push-break exit-bb)
307 (for-each (lambda (x) ; generate each case
308 (in (new-bb)) ; this bb will be given the name of the case
309 (add-succ decision-bb bb)
310 ;; if the previous case didn't end in a break, fall through
311 (if (null? (bb-succs prev-bb))
312 (let ((curr bb))
313 (in prev-bb)
314 (gen-goto curr)
315 (in curr)))
316 (statement x)
317 (set! prev-bb bb))
318 (cdr (ast-subasts ast)))
319 (if (null? (bb-succs prev-bb)) ; if the last case didn't end in a break, fall through to the exit
320 (gen-goto exit-bb))
321 (bb-succs-set! decision-bb (reverse (bb-succs decision-bb))) ; preserving the order is important in the absence of break
322 (set! case-list (list-named-bbs decision-bb '()))
323 (set! default (keep (lambda (x) (eq? (car x) 'default))
324 (list-named-bbs decision-bb '())))
325 (set! case-list (keep (lambda (x) (and (list? (car x))
326 (eq? (caar x) 'case)))
327 case-list))
328 (bb-succs-set! decision-bb '()) ; now that we have the list of cases we don't need the successors anymore
329 (let loop ((case-list case-list)
330 (decision-bb decision-bb))
331 (in decision-bb)
332 (if (not (null? case-list))
333 (let* ((next-bb (new-bb))
334 (curr-case (car case-list))
335 (curr-case-id (cadar curr-case))
336 (curr-case-bb (cdr curr-case)))
337 (emit (new-instr 'x==y
338 (car (value-bytes (expression var)))
339 (new-byte-lit curr-case-id) #f))
340 (add-succ bb next-bb) ; if false, keep looking
341 (add-succ bb curr-case-bb) ; if true, go to the case
342 (loop (cdr case-list)
343 next-bb))
344 (gen-goto (if (not (null? default))
345 (cdar default)
346 exit-bb))))
347 (in exit-bb)
348 (pop-break)))
350 (define (break ast)
351 (gen-goto (car break-stack)))
353 (define (continue ast)
354 (gen-goto (car continue-stack)))
356 ;; generates a goto with a target label. once the current function definition
357 ;; is over, all these labels are resolved. therefore, we don't have any gotos
358 ;; that jump from a function to another
359 (define (goto ast)
360 (emit (new-instr 'goto #f #f (subast1 ast))))
362 (define (gen-goto dest)
363 (add-succ bb dest)
364 (emit (new-instr 'goto #f #f #f)))
366 (define (test-expression ast bb-true bb-false)
368 (define (test-byte id byte1 byte2 bb-true bb-false)
369 (define (test-lit id x y)
370 ((case id
371 ((x==y) =)
372 ((x<y) <)
373 ((x>y) >)
374 (else (error "invalid test")))
375 x
376 y))
377 (cond ((and (byte-lit? byte1) (byte-lit? byte2))
378 (if (test-lit id (byte-lit-val byte1) (byte-lit-val byte2))
379 (gen-goto bb-true)
380 (gen-goto bb-false)))
381 ((byte-lit? byte2)
382 ;; since we cons each new successor at the front, true has to be
383 ;; added last
384 (add-succ bb bb-false)
385 (add-succ bb bb-true)
386 (emit (new-instr id byte1 byte2 #f)))
387 ((byte-lit? byte1)
388 (let ((id
389 (case id
390 ((x==y) 'x==y)
391 ((x<y) 'x>y)
392 ((x>y) 'x<y)
393 (else (error "invalid test")))))
394 (add-succ bb bb-false)
395 (add-succ bb bb-true)
396 (emit (new-instr id byte2 byte1 #f))))
397 (else
398 (add-succ bb bb-false)
399 (add-succ bb bb-true)
400 (emit (new-instr id byte1 byte2 #f)))))
402 (define (test-value id value1 value2 bb-true bb-false)
403 (let loop ((bytes1 (value-bytes value1)) ; lsb first
404 (bytes2 (value-bytes value2))
405 (padded1 '())
406 (padded2 '()))
407 (if (not (and (null? bytes1) (null? bytes2)))
408 ;; note: won't work with signed types, as the padding is done
409 ;; with 0s only
410 (loop (if (null? bytes1) bytes1 (cdr bytes1))
411 (if (null? bytes2) bytes2 (cdr bytes2))
412 (cons (if (null? bytes1) (new-byte-lit 0) (car bytes1)) ;; TODO use extend ?
413 padded1)
414 (cons (if (null? bytes2) (new-byte-lit 0) (car bytes2))
415 padded2))
416 ;; now so the test itself, using the padded values
417 ;; the comparisons are done msb-first, for < and >
418 (case id
419 ((x==y) ; unlike < and >, must check all bytes, so is simpler
420 (let loop2 ((bytes1 padded1)
421 (bytes2 padded2))
422 (let ((byte1 (car bytes1))
423 (byte2 (car bytes2)))
424 (if (null? (cdr bytes1)) ;; TODO factor with code for < and > ?
425 (test-byte 'x==y byte1 byte2 bb-true bb-false)
426 (let ((bb-true2 (new-bb)))
427 (test-byte 'x==y byte1 byte2 bb-true2 bb-false)
428 (in bb-true2)
429 (loop2 (cdr bytes1) (cdr bytes2)))))))
431 (else ; < and >
432 (let loop2 ((bytes1 padded1) ; msb first
433 (bytes2 padded2))
434 (let ((byte1 (car bytes1))
435 (byte2 (car bytes2)))
436 (if (null? (cdr bytes1))
437 (test-byte id byte1 byte2 bb-true bb-false)
438 (let ((bb-test-equal (new-bb))
439 (bb-keep-going (new-bb)))
440 ;; if the test is true for the msb, the whole test
441 ;; is true
442 (test-byte id byte1 byte2 bb-true bb-test-equal)
443 ;; if not, check for equality, if both bytes are
444 ;; equal, keep going
445 (in bb-test-equal)
446 (test-byte 'x==y byte1 byte2 bb-keep-going bb-false)
447 ;; TODO do some analysis to check the value already in w, in this case, it won't change between both tests, so no need to charge it back, as is done now
448 (in bb-keep-going)
449 (loop2 (cdr bytes1) (cdr bytes2)))))))))))
451 (define (test-relation id x y bb-true bb-false)
452 (cond ((and (literal? x) (not (literal? y)))
453 ;; literals must be in the last argument for code generation
454 ;; flip the relation if needed
455 (test-relation (case id
456 ((x==y x!=y) id) ; commutative, no change
457 ((x<y) 'x>y)
458 ((x>y) 'x<y)
459 ((x<=y) 'x>=y)
460 ((x>=y) 'x<=y)
461 (else (error "relation error")))
462 y
463 x
464 bb-true
465 bb-false))
466 ((assq id '((x!=y . x==y) (x<=y . x>y) (x>=y . x<y)))
467 ;; flip the destination blocks to have a simpler comparison
468 =>
469 (lambda (z) (test-relation (cdr z) x y bb-false bb-true)))
470 (else
471 ;; normal case
472 ;; ' ;; TODO use these special cases, but fall back on the current implementation for default
473 ;; (case id
474 ;; ((x==y)
475 ;; (cond ((and (literal? y) (= (literal-val y) 0))
476 ;; (test-zero x bb-true bb-false))
477 ;; ((literal? y)
478 ;; (test-eq-lit x (literal-val y) bb-true bb-false))
479 ;; (else
480 ;; (error "unhandled case"))))
481 ;; ((x<y)
482 ;; (cond ((and (literal? y) (= (literal-val y) 0))
483 ;; (test-negative x bb-true bb-false))
484 ;; (else
485 ;; (error "unhandled case"))))
486 ;; ((x>y)
487 ;; (cond ((and (literal? y) (= (literal-val y) 0))
488 ;; (test-positive x bb-true bb-false))
489 ;; (else
490 ;; (error "unhandled case"))))
491 ;; (else
492 ;; (error "unexpected operator")))
494 (let* ((value1 (expression x))
495 (value2 (expression y)))
496 (test-value id value1 value2 bb-true bb-false))
497 )))
499 (define (test-zero ast bb-true bb-false)
501 (define (default)
502 (let ((type (expr-type ast))
503 (value (expression ast)))
504 ;; since nonzero is true, we must swap the destinations to use ==
505 (test-value 'x==y value (int->value 0 type) bb-false bb-true)))
507 (cond ((oper? ast)
508 (let* ((op (oper-op ast))
509 (id (op-id op)))
510 (case id
511 ((!x)
512 (test-zero (subast1 ast) bb-false bb-true))
513 ((x&&y)
514 (let ((bb-true2 (new-bb)))
515 (test-zero (subast1 ast) bb-true2 bb-false)
516 (in bb-true2)
517 (test-zero (subast2 ast) bb-true bb-false)))
518 ((|x\|\|y|)
519 (let ((bb-false2 (new-bb)))
520 (test-zero (subast1 ast) bb-true bb-false2)
521 (in bb-false2)
522 (test-zero (subast2 ast) bb-true bb-false)))
523 ((x==y x!=y x<y x>y x<=y x>=y)
524 (test-relation id
525 (subast1 ast)
526 (subast2 ast)
527 bb-true
528 bb-false))
529 (else (default)))))
530 (else (default))))
532 (test-zero ast bb-true bb-false))
534 (define (expression ast)
535 (let ((result
536 (cond ((literal? ast) (literal ast))
537 ((ref? ast) (ref ast))
538 ((oper? ast) (oper ast))
539 ((call? ast) (call ast))
540 (else (error "unexpected ast" ast)))))
541 (do-delayed-post-incdec)
542 result))
544 (define (literal ast)
545 (let ((val (literal-val ast)))
546 (int->value val (expr-type ast))))
548 (define (ref ast)
549 (let* ((def-var (ref-def-var ast))
550 (value (def-variable-value def-var)))
551 value))
553 (define (add-sub id value1 value2 result)
554 (let loop ((bytes1 (value-bytes value1)) ; car is lsb
555 (bytes2 (value-bytes value2))
556 (bytes3 (value-bytes result))
557 (ignore-carry-borrow? #t))
558 (if (not (null? bytes3))
559 (begin (emit
560 (new-instr (if ignore-carry-borrow?
561 (case id ((x+y) 'add) ((x-y) 'sub))
562 (case id ((x+y) 'addc) ((x-y) 'subb)))
563 (car bytes1) (car bytes2) (car bytes3)))
564 (loop (cdr bytes1) (cdr bytes2) (cdr bytes3) #f)))))
566 (define (mul x y type result)
567 (let* ((value-x (expression x))
568 (value-y (expression y))
569 (bytes-x (value-bytes value-x))
570 (bytes-y (value-bytes value-y))
571 (lx (length bytes-x))
572 (ly (length bytes-y)))
573 ;; if this a multiplication by 2 or 4, we use additions instead
574 ;; at this point, only y (or both x and y) can contain a literal
575 (if (and (= ly 1)
576 (byte-lit? (car bytes-y))
577 (let ((v (byte-lit-val (car bytes-y))))
578 (or (= v 2) (= v 4))))
579 (case (byte-lit-val (car bytes-y))
580 ((2) (add-sub 'x+y value-x value-x result)) ; simple addition
581 ((4) (let ((tmp (alloc-value (bytes->type
582 (length (value-bytes result))))))
583 (add-sub 'x+y value-x value-x tmp)
584 (add-sub 'x+y tmp tmp result))))
585 ;; if not, we have to do it the long way
586 (begin
587 ;; finds the appropriate multiplication routine (depending on the
588 ;; length of each argument) and turns the multiplication into a
589 ;; call to the routine
590 ;; the arguments must be the asts of the 2 arguments (x and y) and
591 ;; the type of the returned value, since these are what are
592 ;; expected by the call function
594 ;; to avoid code duplication (i.e. habing a routine for 8 by 16
595 ;; multplication and one for 16 by 8), the longest operand goes first
596 (if (> ly lx)
597 (let ((tmp1 y)
598 (tmp2 ly))
599 (set! y x)
600 (set! x tmp1)
601 (set! ly lx)
602 (set! lx tmp2)))
603 (routine-call
604 (string->symbol ; mul8_8, mul8_16, etc
605 ;; for now, only unsigned multiplications are supported
606 (string-append "mul"
607 (number->string (* lx 8)) "_"
608 (number->string (* ly 8))))
609 (list x y)
610 type
611 result)))))
613 (define (mod x y result)
614 (let ((bytes1 (value-bytes x)) ;; TODO common pattern, abstract
615 (bytes2 (value-bytes y))
616 (bytes3 (value-bytes result)))
617 ;; if y is a literal and a power of 2, we can do a bitwise and
618 (let ((y0 (car bytes2)))
619 (if (and (byte-lit? y0)
620 (let ((x (/ (log (value->int y)) (log 2))))
621 (= (floor x) x)))
622 ;; bitwise and with y - 1
623 (begin (let* ((l (bytes->type (length bytes2)))
624 (tmp (alloc-value l)))
625 (move-value (int->value (- (value->int y) 1)
626 (bytes->type (length bytes2)))
627 tmp)
628 (bitwise 'x&y x tmp result)))
629 ;; TODO for the general case, try to optimise the case where division and modulo are used together, since they are used together
630 (error "modulo is only supported for powers of 2")))))
632 (define (shift id x y type result)
633 (let ((bytes1 (value-bytes (extend (expression x) type)))
634 (bytes2 (value-bytes (extend (expression y) type)))
635 (bytes3 (value-bytes result)))
636 ;; if the second argument is a literal and a multiple of 8, we can simply
637 ;; move the bytes around
638 (let ((y0 (car bytes2)))
639 (if (and (byte-lit? y0) (= (modulo (byte-lit-val y0) 8) 0))
640 ;; uses only the first byte, but shifting by 255 should be enough
641 (let ((n (/ (byte-lit-val y0) 8))
642 (l (length bytes1))) ; same length for x and result
643 (let loop ((i 0)
644 (x bytes1))
645 (if (< i l)
646 (case id
647 ((x<<y)
648 (move (if (< i n)
649 (new-byte-lit 0) ; padding
650 (car x))
651 (list-ref bytes3 i))
652 (loop (+ i 1) (if (< i n) x (cdr x))))
653 ((x>>y)
654 (move (if (<= l (+ i n))
655 (new-byte-lit 0)
656 (list-ref x (+ i n)))
657 (list-ref bytes3 i))
658 (loop (+ i 1) x))))))
659 (routine-call
660 (string->symbol
661 (string-append "sh"
662 (case id ((x<<y) "l") ((x>>y) "r"))
663 (number->string (* 8 (length bytes1)))))
664 (list x y)
665 type
666 result)))))
668 ;; bitwise and, or, xor
669 ;; TODO similar to add-sub and probably others, abstract multi-byte ops
670 ;; TODO use bit set, clear and toggle for some shortcuts
671 (define (bitwise id value1 value2 result)
672 (let loop ((bytes1 (value-bytes value1))
673 (bytes2 (value-bytes value2))
674 (bytes3 (value-bytes result)))
675 (if (not (null? bytes3))
676 (begin
677 (emit (new-instr (case id ((x&y) 'and) ((|x\|y|) 'ior) ((x^y) 'xor))
678 (car bytes1) (car bytes2) (car bytes3)))
679 (loop (cdr bytes1) (cdr bytes2) (cdr bytes3))))))
681 (define (bitwise-negation x result)
682 (let loop ((bytes1 (value-bytes x))
683 (bytes2 (value-bytes result)))
684 (if (not (null? bytes2))
685 (begin (emit (new-instr 'not (car bytes1) #f (car bytes2)))
686 (loop (cdr bytes1) (cdr bytes2))))))
688 (define (do-delayed-post-incdec)
689 (if (not (null? delayed-post-incdec))
690 (let* ((ast (car delayed-post-incdec))
691 (type (expr-type ast))
692 (op (oper-op ast))
693 (id (op-id op)))
694 (set! delayed-post-incdec (cdr delayed-post-incdec))
695 (let ((x (subast1 ast)))
696 (if (not (ref? x))
697 (error "assignment target must be a variable"))
698 (let ((result (def-variable-value (ref-def-var x))))
699 ;; clobbers the original value, which is fine, since it
700 ;; was moved somewhere else for the expression
701 (add-sub (if (eq? id 'x++) 'x+y 'x-y)
702 result
703 (int->value 1 type)
704 result)))
705 (do-delayed-post-incdec))))
707 ;; calculates an address in an array by adding the base pointer and the offset
708 ;; and puts the answer in FSR0 so that changes to INDF0 change the array
709 ;; location
710 (define (calculate-address ast)
711 ;; if we have a special FSR variable, no need to calculate the address as
712 ;; it is already in the register
713 (let ((base-name (array-base-name ast))
714 (index? (eq? (op-id (oper-op ast)) 'index)))
715 (if (not (and base-name
716 (memq base-name fsr-variables)))
717 (let ((base (expression (subast1 ast)))
718 ;; NB: actual addresses are 12 bits, not 16
719 (address (new-value (list (get-register FSR0L)
720 (get-register FSR0H)))))
721 (if index?
722 ;; we pad up to int16, since it is the size of the addresses
723 (let ((value1 (extend base 'int16))
724 (value2 (extend (expression (subast2 ast)) 'int16)))
725 (add-sub 'x+y value1 value2 address))
726 ;; no offset with simple dereference
727 (move-value base address)))
728 (error "You used the array index syntax with a FSR variable, didn't you? I told you not to."))))
730 (define (array-base-name ast)
731 ;; returns #f if the lhs is not a direct variable reference
732 ;; eg : *x++ ; (x+y)* ; ...
733 (let ((lhs (subast1 ast)))
734 (and (ref? lhs)
735 (def-id (ref-def-var lhs)))))
737 (define (get-indf base-name)
738 ;; INDF0 is not here, since it's already used for regular array accesses
739 (if (eq? base-name 'SIXPIC_FSR1)
740 (new-value (list (get-register INDF1)))
741 (new-value (list (get-register INDF2)))))
743 (define (oper ast)
744 (let* ((type (expr-type ast))
745 (op (oper-op ast))
746 (id (op-id op)))
747 (let ((op (oper-op ast)))
749 (define (arith-op id x y value-x value-y) ;; TODO find a way not to pass x and y as well
750 ;; since code generation does not accept literals as first
751 ;; arguments unless both arguments are, if this is the
752 ;; case, we either have to swap the arguments (if
753 ;; possible) or allocate the argument somewhere
754 (if (and (literal? x) (not (literal? y)))
755 (if (memq id '(x+y x*y x&y |x\|y| x^y))
756 ;; the operator is commutative, we can swap the args
757 (let ((tmp value-x))
758 (set! value-x value-y)
759 (set! value-y tmp))
760 ;; the operator is not commutative, we have to
761 ;; allocate the first argument somewhere
762 (let ((dest (alloc-value (expr-type x))))
763 (move-value value-x dest)
764 (set! value-x dest))))
765 (let ((result (alloc-value type)))
766 (case id
767 ((x+y x-y) (add-sub id value-x value-y result))
768 ((x*y) (mul x y type result))
769 ((x/y) (error "division not implemented yet")) ;; TODO optimize for powers of 2
770 ((x%y) (mod value-x value-y result))
771 ((x&y |x\|y| x^y) (bitwise id value-x value-y result))
772 ((x>>y x<<y) (shift id x y type result)))
773 result))
775 (cond
776 ((op1? op)
777 (case id
778 ((-x ~x)
779 (let ((x (extend (expression (subast1 ast))
780 type))
781 (result (alloc-value type)))
782 (case id
783 ((-x) (add-sub 'x-y
784 (int->value 0 type)
785 x
786 result))
787 ((~x) (bitwise-negation x result)))
788 result))
789 ((++x --x)
790 (let ((x (subast1 ast)))
791 (if (not (ref? x))
792 (error "assignment target must be a variable"))
793 (let ((result (def-variable-value (ref-def-var x))))
794 (add-sub (if (eq? id '++x) 'x+y 'x-y)
795 result
796 (int->value 1 type)
797 result)
798 result)))
799 ((x++ x--)
800 (let ((x (subast1 ast)))
801 (if (not (ref? x))
802 (error "assignment target must be a variable"))
803 ;; push-delayed-post-incdec moves the original value
804 ;; somewhere else, and returns that location
805 (push-delayed-post-incdec ast)))
806 ((*x)
807 ;; if it's a FSR variable, no adress to set
808 (let ((base-name (array-base-name ast)))
809 (if (and (ref? (subast1 ast)) ; do we have a FSR variable ?
810 base-name
811 (memq base-name fsr-variables))
812 (get-indf base-name)
813 (begin (calculate-address ast)
814 (new-value (list (get-register INDF0)))))))
815 (else
816 (error "unary operation error" id))))
818 ((op2? op)
819 (case id
820 ((x+y x-y x*y x/y x%y x&y |x\|y| x^y x>>y x<<y)
821 (let* ((x (subast1 ast))
822 (y (subast2 ast)))
823 (let* ((value-x (extend (expression x) type))
824 (value-y (extend (expression y) type)))
825 (arith-op id x y value-x value-y))))
826 ((x=y)
827 (let* ((x (subast1 ast))
828 (y (subast2 ast))
829 (value-y (expression y)))
830 (cond
831 ;; lhs is a variable
832 ((ref? x)
833 (let ((ext-value-y (extend value-y type)))
834 (let ((result (def-variable-value (ref-def-var x))))
835 (move-value value-y result)
836 result)))
837 ;; lhs is a pointer dereference
838 ((and (oper? x) (eq? (op-id (oper-op x)) '*x))
839 (let ((base-name (array-base-name x))
840 (val (car (value-bytes value-y))))
841 (if (and (ref? (subast1 x))
842 base-name
843 (memq base-name fsr-variables))
844 (move val (car (value-bytes (get-indf base-name))))
845 (begin (calculate-address x)
846 (move val (get-register INDF0))))))
847 ;; lhs is an indexed array access
848 ((and (oper? x) (eq? (op-id (oper-op x)) 'index))
849 ;; note: this will throw an error if SIXPIC_FSR{1,2} is
850 ;; used. this is by design, as it would clobber the value
851 ;; in the FSR registers, which goes against their purpose
852 ;; of storing a user-chosen value
853 (calculate-address x)
854 ;; this section of memory is a byte array, only the lsb
855 ;; of y is used
856 (move (car (value-bytes value-y)) (get-register INDF0)))
857 (else (error "assignment target must be a variable or an array slot")))))
858 ((index)
859 ;; note: throws an error if given SIXPIC_FSR{1,2}, see above
860 (calculate-address ast)
861 (new-value (list (get-register INDF0))))
862 ((x+=y x-=y x*=y x/=y x%=y x&=y |x\|=y| x^=y x>>=y x<<=y)
863 (let* ((x (subast1 ast))
864 (y (subast2 ast))
865 (value-x (extend (expression x) type))
866 (value-y (extend (expression y) type)))
867 (move-value (arith-op (case id
868 ((x+=y) 'x+y)
869 ((x-=y) 'x-y)
870 ((x*=y) 'x*y)
871 ((x/=y) 'x/y)
872 ((x%=y) 'x%y)
873 ((x&=y) 'x&y)
874 ((|x\|=y|) '|x\|y|)
875 ((x^=y) 'x^=y)
876 ((x>>=y) 'x>>y)
877 ((x<<=y) 'x<<y))
878 x y value-x value-y)
879 value-x)
880 value-x))
881 ((x==y x!=y x>y x>=y x<y x<=y x&&y |x\|\|y|) ;; TODO !x, have it also, maybe do this check before the op1-2-3 test to catch them all ?
882 (let ((bb-start bb)
883 (bb-true (new-bb))
884 (bb-false (new-bb))
885 (bb-join (new-bb))
886 (result (alloc-value type)))
887 (in bb-true)
888 (move-value (int->value 1 type) result)
889 (gen-goto bb-join)
890 (in bb-false)
891 (move-value (int->value 0 type) result)
892 (gen-goto bb-join)
893 (in bb-start)
894 (test-expression ast bb-true bb-false)
895 (in bb-join)
896 result))
897 (else
898 (error "binary operation error" id))))
900 ((op3? op)
901 (let ((bb-start bb)
902 (bb-true (new-bb))
903 (bb-false (new-bb))
904 (bb-join (new-bb))
905 (result (alloc-value type)))
906 (in bb-true)
907 (move-value (expression (subast2 ast)) result)
908 (gen-goto bb-join)
909 (in bb-false)
910 (move-value (expression (subast3 ast)) result)
911 (gen-goto bb-join)
912 (in bb-start)
913 (test-expression (subast1 ast) bb-true bb-false)
914 (in bb-join)
915 result))))))
917 ;; generates the cfg for a predefined routine and adds it to the current cfg
918 (define (include-predefined-routine proc)
919 (define (get-bytes var)
920 (value-bytes (def-variable-value var)))
921 (let ((old-proc current-def-proc) ; if we were already defining a procedure, save it
922 (id (def-id proc))
923 (params (def-procedure-params proc))
924 (value (def-procedure-value proc))
925 (old-bb bb)
926 (entry (new-bb))) ;; TODO insipired from def-procedure, abstract
927 (def-procedure-entry-set! proc entry)
928 (set! current-def-proc proc)
929 (in entry)
930 (case id
932 ((mul8_8)
933 (let ((x (car params))
934 (y (cadr params))
935 (z (value-bytes value)))
936 ;; TODO implement literal multiplication in the simulator
937 (emit (new-instr 'mul (car (get-bytes x)) (car (get-bytes y)) #f))
938 (move (get-register PRODL) (car z)))) ; lsb
940 ((mul16_8)
941 (let* ((x (get-bytes (car params)))
942 (x0 (car x)) ; lsb
943 (x1 (cadr x))
944 (y (get-bytes (cadr params)))
945 (y0 (car y))
946 (z (value-bytes value))
947 (z0 (car z)) ; lsb
948 (z1 (cadr z)))
949 (emit (new-instr 'mul y0 x1 #f))
950 (move (get-register PRODL) z1)
952 (emit (new-instr 'mul y0 x0 #f))
953 (move (get-register PRODL) z0)
954 (emit (new-instr 'add (get-register PRODH) z1 z1))))
956 ((mul16_16)
957 (let* ((x (get-bytes (car params)))
958 (x0 (car x))
959 (x1 (cadr x))
960 (y (get-bytes (cadr params)))
961 (y0 (car y))
962 (y1 (cadr y))
963 (z (value-bytes value))
964 (z0 (car z))
965 (z1 (cadr z)))
967 (emit (new-instr 'mul x0 y0 #f))
968 (move (get-register PRODH) z1)
969 (move (get-register PRODL) z0)
971 (emit (new-instr 'mul x0 y1 #f))
972 (emit (new-instr 'add (get-register PRODL) z1 z1))
974 (emit (new-instr 'mul x1 y0 #f))
975 (emit (new-instr 'add (get-register PRODL) z1 z1))))
977 ((mul32_16)
978 (let* ((x (get-bytes (car params)))
979 (x0 (car x))
980 (x1 (cadr x))
981 (x2 (caddr x))
982 (x3 (cadddr x))
983 (y (get-bytes (cadr params)))
984 (y0 (car y))
985 (y1 (cadr y))
986 (z (value-bytes value))
987 (z0 (car z))
988 (z1 (cadr z))
989 (z2 (caddr z))
990 (z3 (cadddr z)))
992 (emit (new-instr 'mul x0 y0 #f))
993 (move (get-register PRODH) z1)
994 (move (get-register PRODL) z0)
996 (emit (new-instr 'mul x1 y1 #f))
997 (move (get-register PRODH) z3)
998 (move (get-register PRODL) z2)
1000 (emit (new-instr 'mul x1 y0 #f))
1001 (emit (new-instr 'add (get-register PRODL) z1 z1))
1002 (emit (new-instr 'addc (get-register PRODH) z2 z2))
1003 (emit (new-instr 'addc z3 (new-byte-lit 0) z3))
1005 (emit (new-instr 'mul x0 y1 #f))
1006 (emit (new-instr 'add (get-register PRODL) z1 z1))
1007 (emit (new-instr 'addc (get-register PRODH) z2 z2))
1008 (emit (new-instr 'addc z3 (new-byte-lit 0) z3))
1010 (emit (new-instr 'mul x2 y0 #f))
1011 (emit (new-instr 'add (get-register PRODL) z2 z2))
1012 (emit (new-instr 'addc (get-register PRODH) z3 z3))
1014 (emit (new-instr 'mul x2 y1 #f))
1015 (emit (new-instr 'add (get-register PRODL) z3 z3))
1017 (emit (new-instr 'mul x3 y0 #f))
1018 (emit (new-instr 'add (get-register PRODL) z3 z3))))
1020 ((shl8 shr8 shl16 shr16 shl32 shr32)
1021 (let* ((id (symbol->string id))
1022 (left-shift? (eq? (string-ref id 2) #\l))
1023 (x (def-variable-value (car params)))
1024 (y (def-variable-value (cadr params)))
1025 (y0 (car (value-bytes y))) ; shift by 255 is enough
1026 (bytes-z (value-bytes value))
1027 (start-bb (new-bb))
1028 (loop-bb (new-bb))
1029 (after-bb (new-bb)))
1030 (move-value x value)
1031 (gen-goto start-bb) ; fall through to the loop
1032 (in start-bb)
1033 ;; if we'd shift of 0, we're done
1034 (add-succ bb loop-bb) ; false
1035 (add-succ bb after-bb) ; true
1036 (emit (new-instr 'x==y y0 (new-byte-lit 0) #f))
1037 (in loop-bb)
1038 ;; shift for each byte, since it's a rotation using the carry,
1039 ;; what goes out from the low bytes gets into the high bytes
1040 (for-each (lambda (b)
1041 (emit (new-instr (if left-shift? 'shl 'shr)
1042 b #f b)))
1043 (if left-shift? bytes-z (reverse bytes-z)))
1044 ;; clear the carry, to avoid reinserting it in the register
1045 (emit (new-instr 'set
1046 (get-register STATUS)
1047 (new-byte-lit 0)
1048 #f))
1049 (emit (new-instr 'sub y0 (new-byte-lit 1) y0))
1050 (gen-goto start-bb)
1051 (in after-bb))))
1052 (return-with-no-new-bb proc)
1053 (set! current-def-proc old-proc)
1054 (resolve-all-gotos entry (list-named-bbs entry '()) '())
1055 (in old-bb)))
1057 (define (call ast)
1058 (let* ((def-proc (call-def-proc ast))
1059 (arguments (ast-subasts ast))
1060 (parameters (def-procedure-params def-proc)))
1061 (if (and (memq (def-id def-proc) predefined-routines)
1062 (not (def-procedure-entry def-proc)))
1063 ;; it's the first time we encounter this predefined routine, generate
1064 ;; the corresponding cfg
1065 (include-predefined-routine def-proc))
1066 ;; argument number check
1067 (if (not (= (length arguments) (length parameters))) ;; TODO check at parse time ?
1068 (error (string-append "wrong number of arguments given to function "
1069 (symbol->string (def-id def-proc)) ": "
1070 (number->string (length arguments)) " given, "
1071 (number->string (length parameters))
1072 " expected")))
1073 (for-each (lambda (ast def-var)
1074 (let ((value (expression ast)))
1075 (let ((ext-value (extend value (def-variable-type def-var))))
1076 (move-value value (def-variable-value def-var)))))
1077 arguments
1078 parameters)
1079 (emit (new-call-instr def-proc))
1080 (let ((value (def-procedure-value def-proc)))
1081 (let ((result (alloc-value (def-procedure-type def-proc))))
1082 (move-value value result)
1083 result))))
1085 ;; call to a predefined routine, a simple wrapper to an ordinary call
1086 ;; name is a symbol, args is a list of the arguments
1087 (define (routine-call name args type result)
1088 (cond ((memp (lambda (x) (eq? (def-id x) name))
1089 initial-cte)
1090 => (lambda (x) (move-value (call (new-call args type (car x)))
1091 result)))
1092 (else (error "unknown routine: " name))))
1094 ;; remplaces empty bbs by bbs with a single goto, to have a valid CFG for
1095 ;; optimizations
1096 (define (fill-empty-bbs)
1097 (for-each (lambda (x) (if (null? (bb-rev-instrs x))
1098 (begin (in x)
1099 (emit (new-instr 'goto #f #f #f)))))
1100 (cfg-bbs cfg)))
1102 (in (new-bb))
1103 (program ast)
1104 (fill-empty-bbs)
1105 cfg)
1107 (define (print-cfg-bbs cfg)
1108 (for-each (lambda (bb)
1109 (pp (list "BB:" (bb-label-num bb)
1110 "SUCCS" (map bb-label-num (bb-succs bb))
1111 "PREDS" (map bb-label-num (bb-preds bb))
1112 (cond ((null? (bb-rev-instrs bb)) "EMPTY")
1113 ((and (null? (cdr (bb-rev-instrs bb)))
1114 (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
1115 (else #f)))))
1116 (cfg-bbs cfg)))