cfg.scm

   1 ;;; generation of control flow graph
   2
   3 ;; special variables whose contents are located in the FSR registers
   4 (define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2))
   5
   6 (define-type cfg
   7   bbs
   8   next-label-num)
   9
  10 (define (new-cfg)
  11   (make-cfg '() 0))
  12
  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)
  22
  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)
  32
  33 (define-type-of-instr call-instr
  34   unprintable:
  35   def-proc)
  36
  37 (define-type-of-instr return-instr
  38   unprintable:
  39   def-proc)
  40
  41 (define (new-instr id src1 src2 dst)
  42   (make-instr '() '() #f id src1 src2 dst))
  43
  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))
  47
  48 (define (new-call-instr def-proc)
  49   (make-call-instr '() '() #f 'call #f #f #f def-proc))
  50
  51 (define (new-return-instr def-proc)
  52   (make-return-instr '() '() #f 'return #f #f #f def-proc))
  53
  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))
  66
  67 (define (add-instr bb instr)
  68   (let ((rev-instrs (bb-rev-instrs bb)))
  69     (bb-rev-instrs-set! bb (cons instr rev-instrs))))
  70
  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))))
  74
  75 (define (generate-cfg ast)
  76
  77   (define cfg (new-cfg))
  78
  79   (define bb #f) ; current bb
  80
  81   (define (in x) (set! bb x))
  82
  83   (define (new-bb) (add-bb cfg))
  84
  85   (define (emit instr) (add-instr bb instr))
  86
  87   (define current-def-proc #f)
  88   (define break-stack '())
  89   (define continue-stack '())
  90   (define delayed-post-incdec '())
  91
  92   (define (push-break x) (set! break-stack (cons x break-stack)))
  93   (define (pop-break)    (set! break-stack (cdr break-stack)))
  94
  95   (define (push-continue x) (set! continue-stack (cons x continue-stack)))
  96   (define (pop-continue)    (set! continue-stack (cdr continue-stack)))
  97
  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))))
 109
 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))))))))
 120
 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))))
 128
 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)))))))
 135
 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)))))
 151
 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)))
 163
 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         '()))
 175
 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))))
 191
 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)))
 199
 200   (define (move from to)
 201     (emit (new-instr 'move from #f to)))
 202
 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))))))
 213
 214   (define (return-with-no-new-bb def-proc)
 215     (emit (new-return-instr def-proc)))
 216
 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)))
 225
 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)))
 234
 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)))
 247
 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)))
 263
 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)))
 277
 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)))
 298
 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)))
 349
 350   (define (break ast)
 351     (gen-goto (car break-stack)))
 352
 353   (define (continue ast)
 354     (gen-goto (car continue-stack)))
 355
 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))))
 361
 362   (define (gen-goto dest)
 363     (add-succ bb dest)
 364     (emit (new-instr 'goto #f #f #f)))
 365
 366   (define (test-expression ast bb-true bb-false)
 367
 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)))))
 401
 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)))))))
 430
 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)))))))))))
 450
 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")))
 493
 494              (let* ((value1 (expression x))
 495                     (value2 (expression y)))
 496                (test-value id value1 value2 bb-true bb-false))
 497              )))
 498
 499     (define (test-zero ast bb-true bb-false)
 500
 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)))
 506
 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))))
 531
 532     (test-zero ast bb-true bb-false))
 533
 534   (define (expression ast)
 535     (let ((result
 536            (cond ((literal? ast)
 537                   (literal ast))
 538                  ((ref? ast)
 539                   (ref ast))
 540                  ((oper? ast)
 541                   (oper ast))
 542                  ((call? ast)
 543                   (call ast))
 544                  (else
 545                   (error "unexpected ast" ast)))))
 546       (do-delayed-post-incdec)
 547       result))
 548
 549   (define (literal ast)
 550     (let ((val (literal-val ast)))
 551       (int->value val (expr-type ast))))
 552
 553   (define (ref ast)
 554     (let* ((def-var (ref-def-var ast))
 555            (value (def-variable-value def-var)))
 556       value))
 557
 558   (define (add-sub id value1 value2 result)
 559     (let loop ((bytes1 (value-bytes value1)) ; car is lsb
 560                (bytes2 (value-bytes value2))
 561                (bytes3 (value-bytes result))
 562                (ignore-carry-borrow? #t))
 563       (if (not (null? bytes3))
 564           (begin (emit
 565                   (new-instr (if ignore-carry-borrow?
 566                                  (case id ((x+y) 'add)  ((x-y) 'sub))
 567                                  (case id ((x+y) 'addc) ((x-y) 'subb)))
 568                              (car bytes1) (car bytes2) (car bytes3)))
 569                  (loop (cdr bytes1) (cdr bytes2) (cdr bytes3) #f)))))
 570
 571   (define (mul x y type result)
 572     (let* ((value-x (expression x))
 573            (value-y (expression y))
 574            (bytes-x (value-bytes value-x))
 575            (bytes-y (value-bytes value-y))
 576            (lx (length bytes-x))
 577            (ly (length bytes-y)))
 578       ;; if this a multiplication by 2 or 4, we use additions instead
 579       ;; at this point, only y (or both x and y) can contain a literal
 580       (if (and (= ly 1)
 581                (byte-lit? (car bytes-y))
 582                (let ((v (byte-lit-val (car bytes-y))))
 583                  (or (= v 2) (= v 4))))
 584           (case (byte-lit-val (car bytes-y))
 585             ((2) (add-sub 'x+y value-x value-x result)) ; simple addition
 586             ((4) (let ((tmp (alloc-value (bytes->type
 587                                           (length (value-bytes result))))))
 588                    (add-sub 'x+y value-x value-x tmp)
 589                    (add-sub 'x+y tmp tmp result))))
 590           ;; if not, we have to do it the long way
 591           (begin
 592             ;; finds the appropriate multiplication routine (depending on the
 593             ;; length of each argument) and turns the multiplication into a
 594             ;; call to the routine
 595             ;; the arguments must be the asts of the 2 arguments (x and y) and
 596             ;; the type of the returned value, since these are what are
 597             ;; expected by the call function
 598
 599             ;; to avoid code duplication (i.e. habing a routine for 8 by 16
 600             ;; multplication and one for 16 by 8), the longest operand goes first
 601             (if (> ly lx)
 602                 (let ((tmp1 y)
 603                       (tmp2 ly))
 604                   (set! y x)
 605                   (set! x tmp1)
 606                   (set! ly lx)
 607                   (set! lx tmp2)))
 608             (routine-call
 609              (string->symbol ; mul8_8, mul8_16, etc
 610               ;; for now, only unsigned multiplications are supported
 611               (string-append "mul"
 612                              (number->string (* lx 8)) "_"
 613                              (number->string (* ly 8))))
 614              (list x y)
 615              type
 616              result)))))
 617
 618   (define (mod x y result)
 619     (let ((bytes1 (value-bytes x)) ;; TODO common pattern, abstract
 620           (bytes2 (value-bytes y))
 621           (bytes3 (value-bytes result)))
 622       ;; if y is a literal and a power of 2, we can do a bitwise and
 623       (let ((y0 (car bytes2)))
 624         (if (and (byte-lit? y0)
 625                  (let ((x (/ (log (value->int y)) (log 2))))
 626                    (= (floor x) x)))
 627             ;; bitwise and with y - 1
 628             (begin (let* ((l   (bytes->type (length bytes2)))
 629                           (tmp (alloc-value l)))
 630                      (move-value (int->value (- (value->int y) 1)
 631                                              (bytes->type (length bytes2)))
 632                                  tmp)
 633                      (bitwise 'x&y x tmp result)))
 634             ;; TODO for the general case, try to optimise the case where division and modulo are used together, since they are used together
 635             (error "modulo is only supported for powers of 2")))))
 636
 637   (define (shift id x y type result)
 638     (let ((bytes1 (value-bytes (extend (expression x) type)))
 639           (bytes2 (value-bytes (extend (expression y) type)))
 640           (bytes3 (value-bytes result)))
 641       ;; if the second argument is a literal and a multiple of 8, we can simply
 642       ;; move the bytes around
 643       (let ((y0 (car bytes2)))
 644         (if (and (byte-lit? y0) (= (modulo (byte-lit-val y0) 8) 0))
 645             ;; uses only the first byte, but shifting by 255 should be enough
 646             (let ((n (/ (byte-lit-val y0) 8))
 647                   (l (length bytes1))) ; same length for x and result
 648               (let loop ((i 0)
 649                          (x bytes1))
 650                 (if (< i l)
 651                     (case id
 652                       ((x<<y)
 653                        (move (if (< i n)
 654                                  (new-byte-lit 0) ; padding
 655                                  (car x))
 656                              (list-ref bytes3 i))
 657                        (loop (+ i 1) (if (< i n) x (cdr x))))
 658                       ((x>>y)
 659                        (move (if (<= l (+ i n))
 660                                  (new-byte-lit 0)
 661                                  (list-ref x (+ i n)))
 662                              (list-ref bytes3 i))
 663                        (loop (+ i 1) x))))))
 664             (routine-call
 665              (string->symbol
 666               (string-append "sh"
 667                              (case id ((x<<y) "l") ((x>>y) "r"))
 668                              (number->string (* 8 (length bytes1)))))
 669              (list x y)
 670              type
 671              result)))))
 672
 673   ;; bitwise and, or, xor
 674   ;; TODO similar to add-sub and probably others, abstract multi-byte ops
 675   ;; TODO use bit set, clear and toggle for some shortcuts
 676   (define (bitwise id value1 value2 result)
 677     (let loop ((bytes1 (value-bytes value1))
 678                (bytes2 (value-bytes value2))
 679                (bytes3 (value-bytes result)))
 680       (if (not (null? bytes3))
 681           (begin
 682             (emit (new-instr (case id ((x&y) 'and) ((|x\|y|) 'ior) ((x^y) 'xor))
 683                              (car bytes1) (car bytes2) (car bytes3)))
 684             (loop (cdr bytes1) (cdr bytes2) (cdr bytes3))))))
 685
 686   (define (bitwise-negation x result)
 687     (let loop ((bytes1 (value-bytes x))
 688                (bytes2 (value-bytes result)))
 689       (if (not (null? bytes2))
 690           (begin (emit (new-instr 'not (car bytes1) #f (car bytes2)))
 691                  (loop (cdr bytes1) (cdr bytes2))))))
 692
 693   (define (do-delayed-post-incdec)
 694     (if (not (null? delayed-post-incdec))
 695         (let* ((ast (car delayed-post-incdec))
 696                (type (expr-type ast))
 697                (op (oper-op ast))
 698                (id (op-id op)))
 699           (set! delayed-post-incdec (cdr delayed-post-incdec))
 700           (let ((x (subast1 ast)))
 701             (if (not (ref? x))
 702                 (error "assignment target must be a variable"))
 703             (let ((result (def-variable-value (ref-def-var x))))
 704               ;; clobbers the original value, which is fine, since it
 705               ;; was moved somewhere else for the expression
 706               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 707                        result
 708                        (int->value 1 type)
 709                        result)))
 710           (do-delayed-post-incdec))))
 711
 712   ;; calculates an address in an array by adding the base pointer and the offset
 713   ;; and puts the answer in FSR0 so that changes to INDF0 change the array
 714   ;; location
 715   (define (calculate-address ast)
 716     ;; if we have a special FSR variable, no need to calculate the address as
 717     ;; it is already in the register
 718     (let ((base-name (array-base-name ast))
 719           (index? (eq? (op-id (oper-op ast)) 'index)))
 720       (if (not (and base-name
 721                     (memq base-name fsr-variables)))
 722           (let ((base    (expression (subast1 ast)))
 723                 ;; NB: actual addresses are 12 bits, not 16
 724                 (address (new-value (list (get-register FSR0L)
 725                                           (get-register FSR0H)))))
 726             (if index?
 727                 ;; we pad up to int16, since it is the size of the addresses
 728                 (let ((value1 (extend base 'int16))
 729                       (value2 (extend (expression (subast2 ast)) 'int16)))
 730                   (add-sub 'x+y value1 value2 address))
 731                 ;; no offset with simple dereference
 732                 (move-value base address)))
 733           (error "You used the array index syntax with a FSR variable, didn't you? I told you not to."))))
 734
 735   (define (array-base-name ast)
 736     ;; returns #f if the lhs is not a direct variable reference
 737     ;; eg : *x++ ; (x+y)* ; ...
 738     (let ((lhs (subast1 ast)))
 739       (and (ref? lhs)
 740            (def-id (ref-def-var lhs)))))
 741
 742   (define (get-indf base-name)
 743     ;; INDF0 is not here, since it's already used for regular array accesses
 744     (if (eq? base-name 'SIXPIC_FSR1)
 745         (new-value (list (get-register INDF1)))
 746         (new-value (list (get-register INDF2)))))
 747
 748   (define (oper ast)
 749     (let* ((type (expr-type ast))
 750            (op (oper-op ast))
 751            (id (op-id op)))
 752       (let ((op (oper-op ast)))
 753
 754         (define (arith-op id x y value-x value-y) ;; TODO find a way not to pass x and y as well
 755           ;; since code generation does not accept literals as first
 756           ;; arguments unless both arguments are, if this is the
 757           ;; case, we either have to swap the arguments (if
 758           ;; possible) or allocate the argument somewhere
 759           (if (and (literal? x) (not (literal? y)))
 760               (if (memq id '(x+y x*y x&y |x\|y| x^y))
 761                   ;; the operator is commutative, we can swap the args
 762                   (let ((tmp value-x))
 763                     (set! value-x value-y)
 764                     (set! value-y tmp))
 765                   ;; the operator is not commutative, we have to
 766                   ;; allocate the first argument somewhere
 767                   (let ((dest (alloc-value (expr-type x))))
 768                     (move-value value-x dest)
 769                     (set! value-x dest))))
 770           (let ((result (alloc-value type)))
 771             (case id
 772               ((x+y x-y)        (add-sub id value-x value-y result))
 773               ((x*y)            (mul x y type result))
 774               ((x/y)            (error "division not implemented yet")) ;; TODO optimize for powers of 2
 775               ((x%y)            (mod value-x value-y result))
 776               ((x&y |x\|y| x^y) (bitwise id value-x value-y result))
 777               ((x>>y x<<y)      (shift id x y type result)))
 778             result))
 779
 780         (cond
 781          ((op1? op)
 782           (case id
 783             ((-x ~x)
 784              (let ((x (extend (expression (subast1 ast))
 785                               type))
 786                    (result (alloc-value type)))
 787                (case id
 788                  ((-x) (add-sub 'x-y
 789                                 (int->value 0 type)
 790                                 x
 791                                 result))
 792                  ((~x) (bitwise-negation x result)))
 793                result))
 794             ((++x --x)
 795              (let ((x (subast1 ast)))
 796                (if (not (ref? x))
 797                    (error "assignment target must be a variable"))
 798                (let ((result (def-variable-value (ref-def-var x))))
 799                  (add-sub (if (eq? id '++x) 'x+y 'x-y)
 800                           result
 801                           (int->value 1 type)
 802                           result)
 803                  result)))
 804             ((x++ x--)
 805              (let ((x (subast1 ast)))
 806                (if (not (ref? x))
 807                    (error "assignment target must be a variable"))
 808                ;; push-delayed-post-incdec moves the original value
 809                ;; somewhere else, and returns that location
 810                (push-delayed-post-incdec ast)))
 811             ((*x)
 812              ;; if it's a FSR variable, no adress to set
 813              (let ((base-name (array-base-name ast)))
 814                (if (and (ref? (subast1 ast)) ; do we have a FSR variable ?
 815                         base-name
 816                         (memq base-name fsr-variables))
 817                    (get-indf base-name)
 818                    (begin (calculate-address ast)
 819                           (new-value (list (get-register INDF0)))))))
 820             (else
 821              (error "unary operation error" ast))))
 822
 823          ((op2? op)
 824           (case id
 825             ((x+y x-y x*y x/y x%y x&y |x\|y| x^y x>>y x<<y)
 826              (let* ((x (subast1 ast))
 827                     (y (subast2 ast)))
 828                (let* ((value-x (extend (expression x) type))
 829                       (value-y (extend (expression y) type)))
 830                  (arith-op id x y value-x value-y))))
 831             ((x=y)
 832              (let* ((x       (subast1 ast))
 833                     (y       (subast2 ast))
 834                     (value-y (expression y)))
 835                (cond
 836                 ;; lhs is a variable
 837                 ((ref? x)
 838                  (let ((ext-value-y (extend value-y type)))
 839                    (let ((result (def-variable-value (ref-def-var x))))
 840                      (move-value value-y result)
 841                      result)))
 842                 ;; lhs is a pointer dereference
 843                 ((and (oper? x) (eq? (op-id (oper-op x)) '*x))
 844                  (let ((base-name (array-base-name x))
 845                        (val       (car (value-bytes value-y))))
 846                    (if (and (ref? (subast1 x))
 847                             base-name
 848                             (memq base-name fsr-variables))
 849                        (move val (car (value-bytes (get-indf base-name))))
 850                        (begin (calculate-address x)
 851                               (move val (get-register INDF0))))))
 852                 ;; lhs is an indexed array access
 853                 ((and (oper? x) (eq? (op-id (oper-op x)) 'index))
 854                  ;; note: this will throw an error if SIXPIC_FSR{1,2} is
 855                  ;; used. this is by design, as it would clobber the value
 856                  ;; in the FSR registers, which goes against their purpose
 857                  ;; of storing a user-chosen value
 858                  (calculate-address x)
 859                  ;; this section of memory is a byte array, only the lsb
 860                  ;; of y is used
 861                  (move (car (value-bytes value-y)) (get-register INDF0)))
 862                 (else (error "assignment target must be a variable or an array slot")))))
 863             ((index)
 864              ;; note: throws an error if given SIXPIC_FSR{1,2}, see above
 865              (calculate-address ast)
 866              (new-value (list (get-register INDF0))))
 867             ((x+=y x-=y x*=y x/=y x%=y x&=y |x\|=y| x^=y x>>=y x<<=y)
 868              (let* ((x (subast1 ast))
 869                     (y (subast2 ast))
 870                     (value-x (extend (expression x) type))
 871                     (value-y (extend (expression y) type)))
 872                (move-value (arith-op (case id
 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)    'x&y)
 879                                        ((|x\|=y|) '|x\|y|)
 880                                        ((x^=y)    'x^=y)
 881                                        ((x>>=y)   'x>>y)
 882                                        ((x<<=y)   'x<<y))
 883                                      x y value-x value-y)
 884                            value-x)
 885                value-x))
 886             ((x==y x!=y x>y x>=y x<y x<=y)
 887              (let ((bb-start bb)
 888                    (bb-true  (new-bb))
 889                    (bb-false (new-bb))
 890                    (bb-join  (new-bb))
 891                    (result   (alloc-value type)))
 892                (in bb-true)
 893                (move-value (int->value 1 type) result)
 894                (gen-goto bb-join)
 895                (in bb-false)
 896                (move-value (int->value 0 type) result)
 897                (gen-goto bb-join)
 898                (in bb-start)
 899                (test-expression ast bb-true bb-false)
 900                (in bb-join)
 901                result))
 902             (else
 903              (error "binary operation error" ast))))
 904
 905          ((op3? op)
 906           (let ((bb-start bb)
 907                 (bb-true  (new-bb))
 908                 (bb-false (new-bb))
 909                 (bb-join  (new-bb))
 910                 (result   (alloc-value type)))
 911             (in bb-true)
 912             (move-value (expression (subast2 ast)) result)
 913             (gen-goto bb-join)
 914             (in bb-false)
 915             (move-value (expression (subast3 ast)) result)
 916             (gen-goto bb-join)
 917             (in bb-start)
 918             (test-expression (subast1 ast) bb-true bb-false)
 919             (in bb-join)
 920             result))))))
 921
 922   ;; generates the cfg for a predefined routine and adds it to the current cfg
 923   (define (include-predefined-routine proc)
 924     (define (get-bytes var)
 925       (value-bytes (def-variable-value var)))
 926     (let ((old-proc current-def-proc) ; if we were already defining a procedure, save it
 927           (id (def-id proc))
 928           (params (def-procedure-params proc))
 929           (value (def-procedure-value proc))
 930           (old-bb bb)
 931           (entry (new-bb))) ;; TODO insipired from def-procedure, abstract
 932       (def-procedure-entry-set! proc entry)
 933       (set! current-def-proc proc)
 934       (in entry)
 935       (case id
 936
 937         ((mul8_8)
 938          (let ((x (car params))
 939                (y (cadr params))
 940                (z (value-bytes value)))
 941            ;; TODO implement literal multiplication in the simulator
 942            (emit (new-instr 'mul (car (get-bytes x)) (car (get-bytes y)) #f))
 943            (move (get-register PRODL) (car z)) ; lsb
 944            (move (get-register PRODH) (cadr z)))) ;; TODO since 8-8 gives a result 8 bits wide, won't this cause an error ?
 945
 946         ((mul16_8)
 947          (let* ((x  (get-bytes (car params)))
 948                 (x0 (car x)) ; lsb
 949                 (x1 (cadr x))
 950                 (y  (get-bytes (cadr params)))
 951                 (y0 (car y))
 952                 (z  (value-bytes value))
 953                 (z0 (car z)) ; lsb
 954                 (z1 (cadr z))
 955                 (z2 (caddr z)))
 956            (emit (new-instr 'mul y0 x1 #f))
 957            (move (get-register PRODH) z2)
 958            (move (get-register PRODL) z1)
 959
 960            (emit (new-instr 'mul y0 x0 #f))
 961            (move (get-register PRODL) z0)
 962            (emit (new-instr 'add  (get-register PRODH) z1 z1))
 963            (emit (new-instr 'addc z2 (new-byte-lit 0) z2))))
 964
 965         ((mul16_16)
 966          (let* ((x  (get-bytes (car params)))
 967                 (x0 (car x))
 968                 (x1 (cadr x))
 969                 (y  (get-bytes (cadr params)))
 970                 (y0 (car y))
 971                 (y1 (cadr y))
 972                 (z  (value-bytes value))
 973                 (z0 (car z))
 974                 (z1 (cadr z))
 975                 (z2 (caddr z))
 976                 (z3 (cadddr z)))
 977
 978            (emit (new-instr 'mul x1 y1 #f))
 979            (move (get-register PRODH) z3)
 980            (move (get-register PRODL) z2)
 981
 982            (emit (new-instr 'mul x0 y0 #f))
 983            (move (get-register PRODH) z1)
 984            (move (get-register PRODL) z0)
 985
 986            (emit (new-instr 'mul x0 y1 #f))
 987            (emit (new-instr 'add  (get-register PRODL) z1 z1))
 988            (emit (new-instr 'addc (get-register PRODH) z2 z2))
 989            (emit (new-instr 'addc z3 (new-byte-lit 0) z3))
 990
 991            (emit (new-instr 'mul x1 y0 #f))
 992            (emit (new-instr 'add  (get-register PRODL) z1 z1))
 993            (emit (new-instr 'addc (get-register PRODH) z2 z2))
 994            (emit (new-instr 'addc z3 (new-byte-lit 0) z3))))
 995         ;; TODO have 16-32 and 32-32 ? needed for picobit ?
 996
 997         ((shl8 shr8 shl16 shr16 shl32 shr32)
 998          (let* ((id (symbol->string id))
 999                 (left-shift? (eq? (string-ref id 2) #\l))
1000                 (x (def-variable-value (car params)))
1001                 (y (def-variable-value (cadr params)))
1002                 (y0 (car (value-bytes y))) ; shift by 255 is enough
1003                 (bytes-z (value-bytes value))
1004                 (start-bb (new-bb))
1005                 (loop-bb  (new-bb))
1006                 (after-bb (new-bb)))
1007            (move-value x value)
1008            (gen-goto start-bb) ; fall through to the loop
1009            (in start-bb)
1010            ;; if we'd shift of 0, we're done
1011            (add-succ bb loop-bb) ; false
1012            (add-succ bb after-bb) ; true
1013            (emit (new-instr 'x==y y0 (new-byte-lit 0) #f))
1014            (in loop-bb)
1015            ;; shift for each byte, since it's a rotation using the carry,
1016            ;; what goes out from the low bytes gets into the high bytes
1017            (for-each (lambda (b)
1018                        (emit (new-instr (if left-shift? 'shl 'shr)
1019                                         b #f b)))
1020                      (if left-shift? bytes-z (reverse bytes-z)))
1021            ;; clear the carry, to avoid reinserting it in the register
1022            (emit (new-instr 'set
1023                             (get-register STATUS)
1024                             (new-byte-lit 0)
1025                             #f))
1026            (emit (new-instr 'sub y0 (new-byte-lit 1) y0))
1027            (gen-goto start-bb)
1028            (in after-bb))))
1029       (return-with-no-new-bb proc)
1030       (set! current-def-proc old-proc)
1031       (resolve-all-gotos entry (list-named-bbs entry '()) '())
1032       (in old-bb)))
1033
1034   (define (call ast)
1035     (let* ((def-proc   (call-def-proc ast))
1036            (arguments  (ast-subasts ast))
1037            (parameters (def-procedure-params def-proc)))
1038       (if (and (memq (def-id def-proc) predefined-routines)
1039                (not (def-procedure-entry def-proc)))
1040           ;; it's the first time we encounter this predefined routine, generate
1041           ;; the corresponding cfg
1042           (include-predefined-routine def-proc))
1043       ;; argument number check
1044       (if (not (= (length arguments) (length parameters))) ;; TODO check at parse time ?
1045           (error (string-append "wrong number of arguments given to function "
1046                                 (symbol->string (def-id def-proc)) ": "
1047                                 (number->string (length arguments)) " given, "
1048                                 (number->string (length parameters))
1049                                 " expected")))
1050       (for-each (lambda (ast def-var)
1051                   (let ((value (expression ast)))
1052                     (let ((ext-value (extend value (def-variable-type def-var))))
1053                       (move-value value (def-variable-value def-var)))))
1054                 arguments
1055                 parameters)
1056       (emit (new-call-instr def-proc))
1057       (let ((value (def-procedure-value def-proc)))
1058         (let ((result (alloc-value (def-procedure-type def-proc))))
1059           (move-value value result)
1060           result))))
1061
1062   ;; call to a predefined routine, a simple wrapper to an ordinary call
1063   ;; name is a symbol, args is a list of the arguments
1064   (define (routine-call name args type result)
1065     (cond ((memp (lambda (x) (eq? (def-id x) name))
1066                  initial-cte)
1067            => (lambda (x) (move-value (call (new-call args type (car x)))
1068                                       result)))
1069           (else (error "unknown routine: " name))))
1070
1071   ;; remplaces empty bbs by bbs with a single goto, to have a valid CFG for
1072   ;; optimizations
1073   (define (fill-empty-bbs)
1074     (for-each (lambda (x) (if (null? (bb-rev-instrs x))
1075                                (begin (in x)
1076                                       (emit (new-instr 'goto #f #f #f)))))
1077               (cfg-bbs cfg)))
1078
1079   (in (new-bb))
1080   (program ast)
1081   (fill-empty-bbs)
1082   cfg)
1083
1084 (define (print-cfg-bbs cfg)
1085   (for-each (lambda (bb)
1086               (pp (list "BB:" (bb-label-num bb)
1087                         "SUCCS" (map bb-label-num (bb-succs bb))
1088                         "PREDS" (map bb-label-num (bb-preds bb))
1089                         (cond ((null? (bb-rev-instrs bb)) "EMPTY")
1090                               ((and (null? (cdr (bb-rev-instrs bb)))
1091                                      (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
1092                               (else #f)))))
1093             (cfg-bbs cfg)))