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       (expression (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           (add-succ prev-bb 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)) ;; TODO what about work duplication ?
 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              (add-succ bb bb-false) ; since we cons each new successor at the front, true has to be added last
 383              (add-succ bb bb-true)
 384              (emit (new-instr id byte1 byte2 #f)))
 385             ((byte-lit? byte1)
 386              (let ((id
 387                     (case id
 388                       ((x==y) 'x==y)
 389                       ((x<y) 'x>y)
 390                       ((x>y) 'x<y)
 391                       (else (error "invalid test")))))
 392                (add-succ bb bb-false)
 393                (add-succ bb bb-true)
 394                (emit (new-instr id byte2 byte1 #f))))
 395             (else
 396              (add-succ bb bb-false)
 397              (add-succ bb bb-true)
 398              (emit (new-instr id byte1 byte2 #f))))) ;; TODO doesn't change from if we had literals, at least not now
 399
 400     (define (test-value id value1 value2 bb-true bb-false)
 401          (let loop ((bytes1  (value-bytes value1)) ; lsb first
 402                     (bytes2  (value-bytes value2))
 403                     (padded1 '())
 404                     (padded2 '()))
 405            (if (not (and (null? bytes1) (null? bytes2)))
 406                ;; note: won't work with signed types, as the padding is done
 407                ;; with 0s only
 408                (loop (if (null? bytes1) bytes1 (cdr bytes1)) ;; TODO ugly
 409                      (if (null? bytes2) bytes2 (cdr bytes2))
 410                      (cons (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 411                            padded1)
 412                      (cons (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 413                            padded2))
 414                ;; now so the test itself, using the padded values
 415                ;; the comparisons are done msb-first, for < and >
 416                (case id
 417                  ((x==y) ; unlike < and >, must check all bytes, so is simpler
 418                   (let loop2 ((bytes1 padded1)
 419                               (bytes2 padded2))
 420                     (let ((byte1 (car bytes1))
 421                           (byte2 (car bytes2)))
 422                       (if (null? (cdr bytes1)) ;; TODO factor with code for < and > ?
 423                           (test-byte 'x==y byte1 byte2 bb-true bb-false)
 424                           (let ((bb-true2 (new-bb)))
 425                             (test-byte 'x==y byte1 byte2 bb-true2 bb-false)
 426                             (in bb-true2)
 427                             (loop2 (cdr bytes1) (cdr bytes2)))))))
 428
 429                  (else ; < and >
 430                   (let loop2 ((bytes1 padded1) ; msb first
 431                               (bytes2 padded2))
 432                     (let ((byte1 (car bytes1))
 433                           (byte2 (car bytes2)))
 434                       (if (null? (cdr bytes1))
 435                           (test-byte id byte1 byte2 bb-true bb-false)
 436                           (let ((bb-test-equal (new-bb))
 437                                 (bb-keep-going (new-bb)))
 438                             ;; if the test is true for the msb, the whole test
 439                             ;; is true
 440                             (test-byte id byte1 byte2 bb-true bb-test-equal)
 441                             ;; if not, check for equality, if both bytes are
 442                             ;; equal, keep going
 443                             (in bb-test-equal) ;; TODO is this the most efficient way ?
 444                             (test-byte 'x==y byte1 byte2 bb-keep-going bb-false)
 445                             ;; 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
 446                             (in bb-keep-going)
 447                             (loop2 (cdr bytes1) (cdr bytes2)))))))))))
 448
 449     (define (test-relation id x y bb-true bb-false)
 450       (cond ((and (literal? x) (not (literal? y)))
 451              ;; literals must be in the last argument for code generation
 452              ;; flip the relation if needed
 453              (test-relation (case id
 454                               ((x==y x!=y) id) ; commutative, no change
 455                               ((x<y)       'x>y)
 456                               ((x>y)       'x<y)
 457                               ((x<=y)      'x>=y)
 458                               ((x>=y)      'x<=y)
 459                               (else (error "relation error")))
 460                             y
 461                             x
 462                             bb-true
 463                             bb-false))
 464             ((assq id '((x!=y . x==y) (x<=y . x>y) (x>=y . x<y)))
 465              ;; flip the destination blocks to have a simpler comparison
 466              =>
 467              (lambda (z) (test-relation (cdr z) x y bb-false bb-true)))
 468             (else
 469              ;; normal case
 470 ;;           ' ;; TODO use these special cases, but fall back on the current implementation for default
 471 ;;           (case id
 472 ;;             ((x==y)
 473 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 474 ;;                     (test-zero x bb-true bb-false))
 475 ;;                    ((literal? y)
 476 ;;                     (test-eq-lit x (literal-val y) bb-true bb-false))
 477 ;;                    (else
 478 ;;                     (error "unhandled case"))))
 479 ;;             ((x<y)
 480 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 481 ;;                     (test-negative x bb-true bb-false)) ;; TODO does this exist ?
 482 ;;                    (else
 483 ;;                     (error "unhandled case"))))
 484 ;;             ((x>y)
 485 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 486 ;;                     (test-positive x bb-true bb-false))
 487 ;;                    (else
 488 ;;                     (error "unhandled case"))))
 489 ;;             (else
 490 ;;              (error "unexpected operator")))
 491
 492              (let* ((value1 (expression x))
 493                     (value2 (expression y)))
 494                (test-value id value1 value2 bb-true bb-false))
 495              )))
 496
 497     (define (test-zero ast bb-true bb-false)
 498
 499       (define (default)
 500         (let ((type (expr-type ast))
 501               (value (expression ast)))
 502           ;; since nonzero is true, we must swap the destinations to use ==
 503           ;; TODO use int->value ? the padding is done automatically later on...
 504           (test-value 'x==y value (int->value 0 type) bb-false bb-true))) ;; TODO should probably call test-relation, instead, no shortcuts
 505
 506       (cond ((oper? ast)
 507              (let* ((op (oper-op ast))
 508                     (id (op-id op)))
 509                (case id
 510                  ((!x)
 511                   (test-zero (subast1 ast) bb-false bb-true))
 512                  ((x&&y)
 513                   (let ((bb-true2 (new-bb)))
 514                     (test-zero (subast1 ast) bb-true2 bb-false)
 515                     (in bb-true2)
 516                     (test-zero (subast2 ast) bb-true bb-false)))
 517                  ((|x\|\|y|)
 518                   (let ((bb-false2 (new-bb)))
 519                     (test-zero (subast1 ast) bb-true bb-false2)
 520                     (in bb-false2)
 521                     (test-zero (subast2 ast) bb-true bb-false)))
 522                  ((x==y x!=y x<y x>y x<=y x>=y)
 523                   (test-relation id
 524                                  (subast1 ast)
 525                                  (subast2 ast)
 526                                  bb-true
 527                                  bb-false))
 528                  (else (default)))))
 529             (else (default))))
 530
 531     (test-zero ast bb-true bb-false))
 532
 533   (define (expression ast)
 534     (let ((result
 535            (cond ((literal? ast)
 536                   (literal ast))
 537                  ((ref? ast)
 538                   (ref ast))
 539                  ((oper? ast)
 540                   (oper ast))
 541                  ((call? ast)
 542                   (call ast))
 543                  (else
 544                   (error "unexpected ast" ast)))))
 545       (do-delayed-post-incdec)
 546       result))
 547
 548   (define (literal ast)
 549     (let ((val (literal-val ast)))
 550       (int->value val (expr-type ast))))
 551
 552   (define (ref ast)
 553     (let* ((def-var (ref-def-var ast))
 554            (value (def-variable-value def-var)))
 555       value))
 556
 557   (define (add-sub id value1 value2 result)
 558     (let loop ((bytes1 (value-bytes value1)) ; car is lsb
 559                (bytes2 (value-bytes value2))
 560                (bytes3 (value-bytes result))
 561                (ignore-carry-borrow? #t))
 562       (if (not (null? bytes3))
 563           (begin (emit
 564                   (new-instr (if ignore-carry-borrow?
 565                                  (case id ((x+y) 'add)  ((x-y) 'sub))
 566                                  (case id ((x+y) 'addc) ((x-y) 'subb)))
 567                              (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 568                              (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 569                              (car bytes3)))
 570                  (loop (if (null? bytes1) bytes1 (cdr bytes1))
 571                        (if (null? bytes2) bytes2 (cdr bytes2))
 572                        (cdr bytes3)
 573                        #f)))))
 574
 575   (define (mul x y type result)
 576     ;; finds the appropriate multiplication routine (depending on the length
 577     ;; of each argument) and turns the multiplication into a call to the
 578     ;; routine
 579     ;; the arguments must be the asts of the 2 arguments (x and y) and the
 580     ;; type of the returned value, since these are what are expected by the
 581     ;; call function
 582     (let ((lx (length (value-bytes (expression x))))
 583           (ly (length (value-bytes (expression y))))) ;; TODO we end up doing some work that call will also end up doing, wasteful, but I don't see another way
 584       ;; to avoid code duplication (i.e. habing a routine for 8 by 16
 585       ;; multplication and one for 16 by 8), the longest operand goes first
 586       (if (> ly lx)
 587           (let ((tmp1 y)
 588                 (tmp2 ly))
 589             (set! y x)
 590             (set! x tmp1)
 591             (set! ly lx)
 592             (set! lx tmp2)))
 593       (let* ((op (string->symbol ; mul8_8, mul8_16, etc
 594                   ;; for now, only unsigned multiplications are supported
 595                   (string-append "mul"
 596                                  (number->string (* lx 8)) "_"
 597                                  (number->string (* ly 8)))))
 598              ;; find the definition of the predefined routine in the initial cte
 599              (def-proc (car (memp (lambda (x) (eq? (def-id x) op))
 600                                   initial-cte))))
 601         ;; put the result of the call where the rest of the expression expects it
 602         (move-value (call (new-call (list x y)
 603                                     type
 604                                     def-proc))
 605                     result))))
 606
 607   (define (shift id x y result)
 608     (let ((bytes1 (value-bytes x))
 609           (bytes2 (value-bytes y))
 610           (bytes3 (value-bytes result))) ;; TODO not used for now, but will be once we cover all the cases
 611       ;; if the second argument is a literal and a multiple of 8, we can simply
 612       ;; chop bytes off or add padding to the first argument
 613       (let ((y (car bytes2)))
 614         ;; note: I assume that if the first byte is a literal, the others will
 615         ;; be as well. I doubt any other case could happen here.
 616         ;; TODO actually, we construct such a case just after by adding literal 0s at the end. watch out for it, and adjust
 617         (pp (list RES: (length bytes3))) ;; FOO
 618         (if (and (byte-lit? y) (= (modulo (byte-lit-val y) 8) 0))
 619             (let loop ((n (/ (byte-lit-val y) 8))
 620                        (x bytes1)) ;; TODO differentiate between l and r, and have some bigger return values for l, since it might not fit FOO, check if truncation occurs too early, TEST IT
 621               (if (= n 0)
 622                   (move-value (new-value x) result)
 623                   (loop (- n 1)
 624                         (case id
 625                           ((x<<y) (cons (new-byte-lit 0) x))
 626                           ((x>>y) (cdr x))))))
 627             ;; TODO handle the other cases, at least the other literal cases
 628             (error "shifting only implemented for literal multiples of 8")))))
 629
 630   ;; bitwise and, or, xor TODO not ? no, elsewhere since it's unary
 631   ;; TODO similar to add-sub and probably others, abstract multi-byte operations
 632   (define (bitwise id value1 value2 result)
 633     (let loop ((bytes1 (value-bytes value1))
 634                (bytes2 (value-bytes value2))
 635                (bytes3 (value-bytes result)))
 636       (if (not (null? bytes3))
 637           (begin (emit
 638                   (new-instr (case id ((x&y) 'and) ((|x\|y|) 'ior) ((x^y) 'xor))
 639                              (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 640                              (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 641                              (car bytes3)))
 642                  (loop (if (null? bytes1) bytes1 (cdr bytes1))
 643                        (if (null? bytes2) bytes2 (cdr bytes2))
 644                        (cdr bytes3))))))
 645
 646   (define (do-delayed-post-incdec)
 647     (if (not (null? delayed-post-incdec))
 648         (let* ((ast (car delayed-post-incdec))
 649                (type (expr-type ast))
 650                (op (oper-op ast))
 651                (id (op-id op)))
 652           (set! delayed-post-incdec (cdr delayed-post-incdec))
 653           (let ((x (subast1 ast)))
 654             (if (not (ref? x))
 655                 (error "assignment target must be a variable"))
 656             (let ((result (def-variable-value (ref-def-var x))))
 657               ;; clobbers the original value, which is fine, since it
 658               ;; was moved somewhere else for the expression
 659               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 660                        result
 661                        (int->value 1 type)
 662                        result)))
 663           (do-delayed-post-incdec))))
 664
 665   ;; calculates an address in an array by adding the base pointer and the offset
 666   ;; and puts the answer in FSR0 so that changes to INDF0 change the array
 667   ;; location
 668   (define (calculate-address ast)
 669     ;; if we have a special FSR variable, no need to calculate the address as
 670     ;; it is already in the register
 671     (let ((base-name (array-base-name ast))
 672           (index? (eq? (op-id (oper-op ast)) 'index)))
 673       (if (not (and base-name
 674                     (memq base-name fsr-variables)))
 675           (let ((base    (expression (subast1 ast)))
 676                 (address (new-value (list (get-register FSR0L)
 677                                           (get-register FSR0H))))) ;; TODO actual addresses are 12 bits, not 16
 678             (if index?
 679                 (add-sub 'x+y base (expression (subast2 ast)) address)
 680                 ;; no offset with simple dereference
 681                 (move-value base address)))
 682           (error "You used the array index syntax with a FSR variable, didn't you? I told you not to."))))
 683
 684   (define (array-base-name ast)
 685     ;; returns #f if the lhs is not a direct variable reference
 686     ;; eg : *x++ ; (x+y)* ; ...
 687     (let ((lhs (subast1 ast)))
 688       (and (ref? lhs)
 689            (def-id (ref-def-var lhs)))))
 690
 691   (define (get-indf base-name)
 692     ;; INDF0 is not here, since it's already used for regular array accesses
 693     (if (eq? base-name 'SIXPIC_FSR1)
 694         (new-value (list (get-register INDF1)))
 695         (new-value (list (get-register INDF2)))))
 696
 697   (define (oper ast)
 698     (let* ((type (expr-type ast))
 699            (op (oper-op ast))
 700            (id (op-id op)))
 701       (let ((op (oper-op ast)))
 702         (if (op1? op)
 703             (begin
 704               (case id
 705                 ((-x)
 706                  (let ((x (subast1 ast)))
 707                    (let ((value-x (expression x)))
 708                      (let ((ext-value-x (extend value-x type)))
 709                        (let ((result (alloc-value type)))
 710                          (add-sub 'x-y
 711                                   (int->value 0 type)
 712                                   ext-value-x
 713                                   result)
 714                          result)))))
 715                 ((++x --x)
 716                  (let ((x (subast1 ast)))
 717                    (if (not (ref? x))
 718                        (error "assignment target must be a variable"))
 719                    (let ((result (def-variable-value (ref-def-var x))))
 720                      (add-sub (if (eq? id '++x) 'x+y 'x-y)
 721                               result
 722                               (int->value 1 type)
 723                               result)
 724                      result)))
 725                 ((x++ x--)
 726                  (let ((x (subast1 ast)))
 727                    (if (not (ref? x))
 728                        (error "assignment target must be a variable"))
 729                    ;; push-delayed-post-incdec moves the original value
 730                    ;; somewhere else, and returns that location
 731                    (push-delayed-post-incdec ast)))
 732                 ((*x)
 733                  ;; if it's a FSR variable, no adress to set
 734                  (let ((base-name (array-base-name ast)))
 735                    (if (and (ref? (subast1 ast)) ; do we have a FSR variable ?
 736                             base-name
 737                             (memq base-name fsr-variables))
 738                        (get-indf base-name)
 739                        (begin (calculate-address ast)
 740                               (new-value (list (get-register INDF0)))))))
 741                 (else
 742                  (error "unary operation error" ast))))
 743             (begin
 744               (case id
 745                 ((x+y x-y x*y x/y x%y x&y |x\|y| x^y x>>y x<<y)
 746                  (let* ((x (subast1 ast))
 747                         (y (subast2 ast)))
 748                    ;; TODO use the extend function to do the padding, instead of doing it ad hoc everywhere
 749                    (let* ((value-x (extend (expression x) type))
 750                           (value-y (extend (expression y) type)))
 751                      ;; unless both arguments are literals, only the second can
 752                      ;; be one
 753                      (if (and (literal? x) (not (literal? y)))
 754                          (if (memq id '(x+y x*y x&y |x\|y| x^y))
 755                              ;; the operator is commutative, we can swap the args
 756                              (let ((tmp value-x))
 757                                (set! value-x value-y)
 758                                (set! value-y tmp))
 759                              ;; the operator is not commutative, we have to
 760                              ;; allocate the first argument somewhere
 761                              (let ((dest (alloc-value (expr-type x))))
 762                                (move-value value-x dest)
 763                                (set! value-x dest))))
 764                      (let ((result (alloc-value type)))
 765                        (case id
 766                          ((x+y x-y)        (add-sub id value-x value-y result))
 767                          ((x*y)            (mul x y type result))
 768                          ((x/y)            (error "division not implemented yet"))
 769                          ((x%y)            (mod value-x value-y result)) ;; TODO oops, not implemented yet
 770                          ((x&y |x\|y| x^y) (bitwise id value-x value-y result))
 771                          ((x>>y x<<y)      (shift id value-x value-y result)))
 772                        result))))
 773                 ((x=y)
 774                  (let* ((x       (subast1 ast))
 775                         (y       (subast2 ast))
 776                         (value-y (expression y)))
 777                    (cond
 778                     ;; lhs is a variable
 779                     ((ref? x)
 780                      (let ((ext-value-y (extend value-y type))) ;; TODO useless for now
 781                        (let ((result (def-variable-value (ref-def-var x))))
 782                          (move-value value-y result)
 783                          result)))
 784                     ;; lhs is a pointer dereference
 785                     ((and (oper? x) (eq? (op-id (oper-op x)) '*x))
 786                      (let ((base-name (array-base-name x))
 787                            (val       (car (value-bytes value-y))))
 788                        (if (and (ref? (subast1 x))
 789                                 base-name
 790                                 (memq base-name fsr-variables))
 791                            (move val (car (value-bytes (get-indf base-name))))
 792                            (begin (calculate-address x)
 793                                   (move val (get-register INDF0))))))
 794                     ;; lhs is an indexed array access
 795                     ((and (oper? x) (eq? (op-id (oper-op x)) 'index))
 796                      ;; note: this will throw an error if SIXPIC_FSR{1,2} is
 797                      ;; used. this is by design, as it would clobber the value
 798                      ;; in the FSR registers, which goes against their purpose
 799                      ;; of storing a user-chosen value
 800                      (calculate-address x)
 801                      ;; this section of memory is a byte array, only the lsb
 802                      ;; of y is used
 803                      (move (car (value-bytes value-y)) (get-register INDF0)))
 804                     (else (error "assignment target must be a variable or an array slot")))))
 805                 ((index)
 806                  ;; note: throws an error if given SIXPIC_FSR{1,2}, see above
 807                  (calculate-address ast)
 808                  (new-value (list (get-register INDF0))))
 809                 (else
 810                  (error "binary operation error" ast))))))))
 811
 812   ;; generates the cfg for a predefined routine and adds it to the current cfg
 813   (define (include-predefined-routine proc)
 814     (define (get-bytes var)
 815       (value-bytes (def-variable-value var)))
 816     (let ((id (def-id proc))
 817           (params (def-procedure-params proc))
 818           (value (def-procedure-value proc))
 819           (old-bb bb)
 820           (entry (new-bb))) ;; TODO insipired from def-procedure, abstract
 821       (def-procedure-entry-set! proc entry)
 822       (set! current-def-proc proc)
 823       (in entry)
 824       (case id
 825
 826         ((mul8_8)
 827          (let ((x (car params))
 828                (y (cadr params))
 829                (z (value-bytes value)))
 830            ;; TODO implement literal multiplication in the simulator
 831            (emit (new-instr 'mul (car (get-bytes x)) (car (get-bytes y)) #f))
 832            ;; TODO talking about prodl/h here is abstraction leak, maybe have 2 destinations for the instruction
 833            (move (get-register PRODL) (car z)) ; lsb
 834            (move (get-register PRODH) (cadr z))))
 835
 836         ((mul16_8)
 837          (let* ((x  (get-bytes (car params))) ;; TODO make sure endianness is ok
 838                 (x0 (car x)) ; lsb
 839                 (x1 (cadr x))
 840                 (y  (get-bytes (cadr params)))
 841                 (y0 (car y))
 842                 (z  (value-bytes value))
 843                 (z0 (car z)) ; lsb
 844                 (z1 (cadr z))
 845                 (z2 (caddr z)))
 846            (emit (new-instr 'mul y0 x1 #f))
 847            (move (get-register PRODH) z2)
 848            (move (get-register PRODL) z1)
 849
 850            (emit (new-instr 'mul y0 x0 #f))
 851            (move (get-register PRODL) z0)
 852            (emit (new-instr 'add  (get-register PRODH) z1 z1))
 853            (emit (new-instr 'addc z2 (new-byte-lit 0) z2))))
 854
 855         ((mul16_16)
 856          (let* ((x  (get-bytes (car params)))
 857                 (x0 (car x))
 858                 (x1 (cadr x))
 859                 (y  (get-bytes (cadr params)))
 860                 (y0 (car y))
 861                 (y1 (cadr y))
 862                 (z  (value-bytes value))
 863                 (z0 (car z))
 864                 (z1 (cadr z))
 865                 (z2 (caddr z))
 866                 (z3 (cadddr z)))
 867
 868            (emit (new-instr 'mul x1 y1 #f))
 869            (move (get-register PRODH) z3)
 870            (move (get-register PRODL) z2)
 871
 872            (emit (new-instr 'mul x0 y0 #f))
 873            (move (get-register PRODH) z1)
 874            (move (get-register PRODL) z0)
 875
 876            (emit (new-instr 'mul x0 y1 #f))
 877            (emit (new-instr 'add  (get-register PRODL) z1 z1))
 878            (emit (new-instr 'addc (get-register PRODH) z2 z2))
 879            (emit (new-instr 'addc z3 (new-byte-lit 0) z3))
 880
 881            (emit (new-instr 'mul x1 y0 #f))
 882            (emit (new-instr 'add  (get-register PRODL) z1 z1))
 883            (emit (new-instr 'addc (get-register PRODH) z2 z2))
 884            (emit (new-instr 'addc z3 (new-byte-lit 0) z3))))
 885         ;; TODO have 16-32 and 32-32 ? needed for picobit ?
 886         )
 887       ;; TODO alloc-value if intermediary results are needed, wouldn't be as optimal as directly adding prodl and prodh to the right register, but makes it more generic, maybe register allocation could fix this suboptimality ? (actually, for the moment, we play with the PROD registers right here, so it's not that subobtimal)
 888       (return-with-no-new-bb proc)
 889       (set! current-def-proc #f)
 890       (resolve-all-gotos entry (list-named-bbs entry '()) '())
 891       (in old-bb)))
 892
 893   (define (call ast)
 894     (let* ((def-proc   (call-def-proc ast))
 895            (arguments  (ast-subasts ast))
 896            (parameters (def-procedure-params def-proc)))
 897       (if (and (memq (def-id def-proc) predefined-routines)
 898                (not (def-procedure-entry def-proc)))
 899           ;; it's the first time we encounter this predefined routine, generate
 900           ;; the corresponding cfg
 901           (include-predefined-routine def-proc))
 902       ;; argument number check
 903       (if (not (= (length arguments) (length parameters))) ;; TODO check at parse time ?
 904           (error (string-append "wrong number of arguments given to function "
 905                                 (symbol->string (def-id def-proc)) ": "
 906                                 (number->string (length arguments)) " given, "
 907                                 (number->string (length parameters))
 908                                 " expected")))
 909       (for-each (lambda (ast def-var)
 910                   (let ((value (expression ast)))
 911                     (let ((ext-value (extend value (def-variable-type def-var))))
 912                       (move-value value (def-variable-value def-var)))))
 913                 arguments
 914                 parameters)
 915       (emit (new-call-instr def-proc))
 916       (let ((value (def-procedure-value def-proc)))
 917         (let ((result (alloc-value (def-procedure-type def-proc))))
 918           (move-value value result)
 919           result))))
 920
 921   ;; remplaces empty bbs by bbs with a single goto, to have a valid CFG for optimizations
 922   (define (fill-empty-bbs)
 923     (for-each (lambda (x) (if (null? (bb-rev-instrs x))
 924                                (begin (in x)
 925                                       (emit (new-instr 'goto #f #f #f)))))
 926               (cfg-bbs cfg)))
 927
 928   (in (new-bb))
 929   (program ast)
 930   (fill-empty-bbs)
 931   cfg)
 932
 933 (define (print-cfg-bbs cfg)
 934   (for-each (lambda (bb)
 935               (pp (list "BB:" (bb-label-num bb)
 936                         "SUCCS" (map bb-label-num (bb-succs bb))
 937                         "PREDS" (map bb-label-num (bb-preds bb))
 938                         (cond ((null? (bb-rev-instrs bb)) "EMPTY")
 939                               ((and (null? (cdr (bb-rev-instrs bb)))
 940                                      (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
 941                               (else #f)))))
 942             (cfg-bbs cfg)))