cfg.scm

   1 ;;; generation of control flow graph
   2
   3 ;; list of all conditional branching generic instructions
   4 (define conditional-instrs ;; TODO add as we add specialized instructions
   5   '(x==y x!=y x<y x>y branch-if-carry))
   6
   7 ;; generic instructions that end up generating machine instructions that affect
   8 ;; the carry flag
   9 (define carry-affecting-instrs
  10   '(add addc sub subb rlcf rrcf))
  11
  12 ;; special variables whose contents are located in the FSR registers
  13 (define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2))
  14
  15
  16 (define-type cfg
  17   bbs
  18   next-label-num)
  19
  20 (define (new-cfg)
  21   (make-cfg '() 0))
  22
  23 (define-type bb
  24   label-num
  25   label-name ; if the block had a label
  26   label
  27   rev-instrs
  28   unprintable:
  29   preds
  30   succs
  31   live-before) ; bitset
  32
  33 (define (bb-name bb)
  34   (asm-label-id (bb-label bb)))
  35
  36 (define-type instr
  37   extender: define-type-of-instr
  38   (live-before unprintable:) ; bitset
  39   (live-after unprintable:)  ; bitset
  40   (hash unprintable:)
  41   id
  42   src1
  43   src2
  44   dst)
  45
  46 (define-type-of-instr call-instr
  47   unprintable:
  48   def-proc)
  49
  50 (define-type-of-instr return-instr
  51   unprintable:
  52   def-proc)
  53
  54 (define (new-instr id src1 src2 dst)
  55   (make-instr #f #f #f id src1 src2 dst))
  56
  57 (define (new-call-instr def-proc)
  58   (make-call-instr '() '() #f 'call #f #f #f def-proc))
  59
  60 (define (new-return-instr def-proc)
  61   (make-return-instr '() '() #f 'return #f #f #f def-proc))
  62
  63 (define (add-bb cfg proc id) ;; TODO maybe have the name in the label for named-bbs ? would help debugging
  64   (let* ((label-num (cfg-next-label-num cfg))
  65          (bb (make-bb label-num #f #f '() '() '() #f)))
  66     (bb-label-set!
  67      bb
  68      (asm-make-label
  69       (string->symbol
  70        (string-append "$"
  71                       (number->string label-num)
  72                       "$"
  73                       (if proc (symbol->string proc) "")
  74                       "$"
  75                       (if proc (number->string id) "")))))
  76     (cfg-bbs-set! cfg (cons bb (cfg-bbs cfg)))
  77     (cfg-next-label-num-set! cfg (+ 1 (cfg-next-label-num cfg)))
  78     bb))
  79
  80 (define (add-instr bb instr)
  81   (let ((rev-instrs (bb-rev-instrs bb)))
  82     (bb-rev-instrs-set! bb (cons instr rev-instrs))))
  83
  84 (define (add-succ bb succ)
  85   (bb-succs-set! bb (cons succ (bb-succs bb)))
  86   (bb-preds-set! succ (cons bb (bb-preds succ))))
  87
  88 ;; for statistics
  89 (define virtual-instructions-counts  (make-table))
  90 (define concrete-instructions-counts (make-table))
  91 (define byte-cell-src1-counts        (make-table))
  92 (define byte-cell-src2-counts        (make-table))
  93 (define byte-cell-dst-counts         (make-table))
  94 (define byte-cell-all-counts         (make-table))
  95
  96 (define (generate-cfg ast)
  97
  98   (define cfg (new-cfg))
  99
 100   (define bb #f) ; current bb
 101
 102   (define (in x) (set! bb x))
 103
 104   (define current-def-proc #f)
 105   (define (current-def-proc-id)
 106     (if current-def-proc
 107         (def-id current-def-proc)
 108         #f))
 109   (define current-def-proc-bb-id 0)
 110
 111   (define (new-bb)
 112     (let ((bb (add-bb cfg (current-def-proc-id) current-def-proc-bb-id)))
 113       (set! current-def-proc-bb-id (+ current-def-proc-bb-id 1))
 114       bb))
 115
 116   (define (emit instr)
 117     ;; keep statistics
 118     (let ((id   (instr-id   instr)))
 119       (table-set! virtual-instructions-counts id
 120                   (+ (table-ref virtual-instructions-counts id 0) 1)))
 121     (let ((src1 (instr-src1 instr))) ;; TODO have a macro for that
 122       (if (byte-cell? src1)
 123           (let ((src1 (byte-cell-name src1))) ;; TODO also include the id, in the case of multiple vars with the same name, or maybe the bb (though it is not defined everywhere
 124             (table-set! byte-cell-src1-counts src1
 125                         (+ (table-ref byte-cell-src1-counts src1 0) 1))
 126             (table-set! byte-cell-all-counts src1
 127                         (+ (table-ref byte-cell-all-counts src1 0) 1)))))
 128     (let ((src2 (instr-src2 instr)))
 129       (if (byte-cell? src2)
 130           (let ((src2 (byte-cell-name src2)))
 131             (table-set! byte-cell-src2-counts src2
 132                         (+ (table-ref byte-cell-src2-counts src2 0) 1))
 133             (table-set! byte-cell-all-counts src2
 134                         (+ (table-ref byte-cell-all-counts src2 0) 1)))))
 135     (let ((dst (instr-dst instr)))
 136       (if (byte-cell? dst)
 137           (let ((dst (byte-cell-name dst)))
 138             (table-set! byte-cell-dst-counts dst
 139                         (+ (table-ref byte-cell-dst-counts dst 0) 1))
 140             (table-set! byte-cell-all-counts dst
 141                         (+ (table-ref byte-cell-all-counts dst 0) 1)))))
 142     (add-instr bb instr))
 143
 144   (define break-stack '())
 145   (define continue-stack '())
 146   (define delayed-post-incdec '())
 147
 148   (define (push-break x) (set! break-stack (cons x break-stack)))
 149   (define (pop-break)    (set! break-stack (cdr break-stack)))
 150
 151   (define (push-continue x) (set! continue-stack (cons x continue-stack)))
 152   (define (pop-continue)    (set! continue-stack (cdr continue-stack)))
 153
 154   (define (push-delayed-post-incdec ast)
 155     (set! delayed-post-incdec (cons ast delayed-post-incdec))
 156     ;; moves the original value to a new location (so it won't be modified)
 157     ;; and returns that location to the original expression
 158     (let ((x (subast1 ast)))
 159       (if (not (ref? x))
 160           (error "assignment target must be a variable")
 161           (let* ((def-var (ref-def-var x))
 162                  (result  (alloc-value (def-variable-type def-var)
 163                                        (current-def-proc-id)
 164                                        #f (bb-name bb))))
 165             (move-value (def-variable-value def-var) result)
 166             result))))
 167
 168   ;; TODO instead of carrying types around, use the length instead, or even better, just pass the value-bytes, and calculate the length as needed
 169   (define (extend value type)
 170     ;; literals must be extended with literal 0s, while variables must be
 171     ;; extended with byte cells
 172     (let* ((bytes (value-bytes value))
 173            (lit?  (byte-lit? (car bytes))))
 174       (let loop ((rev-bytes (reverse bytes))
 175                  (n         (max 0 (- (type->bytes type) (length bytes)))))
 176         (if (= n 0)
 177             (new-value (reverse rev-bytes))
 178             (loop (cons (new-byte-lit 0) ;; TODO used to extend with empty byte cells when it expanded a variable. caused weird bugs.
 179                         rev-bytes)
 180                   (- n 1))))))
 181
 182   (define (program ast)
 183     (let loop ((asts (ast-subasts ast)))
 184       (if (not (null? asts))
 185           (let ((ast (car asts)))
 186             (if (null? (cdr asts))
 187                 (let ((value (expression ast)))
 188                   (return-with-no-new-bb value))
 189                 (begin
 190                   (toplevel ast)
 191                   (loop (cdr asts))))))))
 192
 193   (define (toplevel ast)
 194     (cond ((def-variable? ast)
 195            (def-variable ast))
 196           ((def-procedure? ast)
 197            (def-procedure ast))
 198           (else
 199            (statement ast))))
 200
 201   (define (def-variable ast) ;; TODO set the fun for each byte-cell
 202     (let ((subasts (ast-subasts ast)))
 203       (if (not (null? subasts)) ; if needed, set the variable
 204           (let ((value (expression (subast1 ast))))
 205             (let ((ext-value (extend value (def-variable-type ast))))
 206               (move-value value (def-variable-value ast)))))))
 207
 208   ;; resolve the C gotos by setting the appropriate successor to their bb
 209   (define (resolve-all-gotos start table)
 210     (let loop ((start start)
 211                (visited (new-empty-set)))
 212       (if (not (set-member? visited start)) ; not visited
 213           (begin (for-each
 214                   (lambda (x)
 215                     (if (and (eq? (instr-id x) 'goto)
 216                              (instr-dst x)) ; unresolved label
 217                         (let ((target (assoc (instr-dst x) table))) ;; TODO use a set, but not urgent, not a bottleneck
 218                           (if target
 219                               (begin (add-succ start (cdr target))
 220                                      (instr-dst-set! x #f))
 221                               (error "invalid goto target" (instr-dst x))))))
 222                   (bb-rev-instrs start))
 223                  (for-each (lambda (x)
 224                              (set-add! visited start)
 225                              (loop x visited))
 226                            (bb-succs start))))))
 227
 228   (define (def-procedure ast) ;; TODO set the fun for the parameters, and maybe also return value
 229     (set! current-def-proc-bb-id 0)
 230     (set! current-def-proc ast)
 231     (let ((old-bb bb)
 232           (entry (new-bb)))
 233       (def-procedure-entry-set! ast entry)
 234       (in entry)
 235       (for-each statement (ast-subasts ast))
 236       (return-with-no-new-bb ast)
 237       (set! current-def-proc #f)
 238       (resolve-all-gotos entry (list-named-bbs entry))
 239       (in old-bb)))
 240
 241   ;; returns a list of all named bbs in the successor-tree of a given bb
 242   (define (list-named-bbs start)
 243     (let ((visited (new-empty-set)))
 244       (let loop ((start start) ;; TODO not really a loop, it's tree recursion
 245                  (named '()))
 246         (if (set-member? visited start)
 247             named
 248             (let ((succs
 249                    (apply append
 250                           (map (lambda (bb)
 251                                  (set-add! visited start)
 252                                  (loop bb named))
 253                                (bb-succs start)))))
 254               (if (bb-label-name start)
 255                   (cons (cons (bb-label-name start) start) succs)
 256                   succs))))))
 257
 258   (define (statement ast)
 259     (cond ((def-variable? ast) (def-variable ast))
 260           ((block? ast)        (block ast))
 261           ((return? ast)       (return ast))
 262           ((if? ast)           (if (null? (cddr (ast-subasts ast)))
 263                                    (if1 ast)
 264                                    (if2 ast)))
 265           ((while? ast)        (while ast))
 266           ((do-while? ast)     (do-while ast))
 267           ((for? ast)          (for ast))
 268           ((switch? ast)       (switch ast))
 269           ((break? ast)        (break ast))
 270           ((continue? ast)     (continue ast))
 271           ((goto? ast)         (goto ast))
 272           (else                (expression ast))))
 273
 274   (define (block ast)
 275     (if (block-name ast) ; named block ?
 276         (begin (let ((new (new-bb)))
 277                  (gen-goto new)
 278                  (in new))
 279                (bb-label-name-set! bb (block-name ast))))
 280     (for-each statement (ast-subasts ast)))
 281
 282   (define (move from to)
 283     (emit (new-instr 'move from #f to)))
 284
 285   (define (move-value from to)
 286     (let loop ((from (value-bytes from))
 287                (to   (value-bytes to)))
 288       (cond ((null? to))  ; done, we truncate the rest
 289             ((null? from) ; promote the value by padding
 290              (move (new-byte-lit 0) (car to))
 291              (loop from (cdr to)))
 292             (else
 293              (move (car from) (car to))
 294              (loop (cdr from) (cdr to))))))
 295
 296   (define (return-with-no-new-bb def-proc)
 297     (emit (new-return-instr def-proc)))
 298
 299   (define (return ast)
 300     (if (null? (ast-subasts ast))
 301         (return-with-no-new-bb current-def-proc)
 302         (let ((value (expression (subast1 ast))))
 303           (let ((ext-value (extend value (def-procedure-type current-def-proc))))
 304             (move-value value (def-procedure-value current-def-proc))
 305             (return-with-no-new-bb current-def-proc))))
 306     (in (new-bb)))
 307
 308   (define (if1 ast)
 309     (let* ((bb-join (new-bb))
 310            (bb-then (new-bb)))
 311       (test-expression (subast1 ast) bb-then bb-join)
 312       (in bb-then)
 313       (statement (subast2 ast))
 314       (gen-goto bb-join)
 315       (in bb-join)))
 316
 317   (define (if2 ast)
 318     (let* ((bb-join (new-bb))
 319            (bb-then (new-bb))
 320            (bb-else (new-bb)))
 321       (test-expression (subast1 ast) bb-then bb-else)
 322       (in bb-then)
 323       (statement (subast2 ast))
 324       (gen-goto bb-join)
 325       (in bb-else)
 326       (statement (subast3 ast))
 327       (gen-goto bb-join)
 328       (in bb-join)))
 329
 330   (define (while ast)
 331     (let* ((bb-cont (new-bb))
 332            (bb-exit (new-bb))
 333            (bb-body (new-bb)))
 334       (push-continue bb-cont)
 335       (push-break bb-exit)
 336       (gen-goto bb-cont)
 337       (in bb-cont)
 338       (test-expression (subast1 ast) bb-body bb-exit)
 339       (in bb-body)
 340       (statement (subast2 ast))
 341       (gen-goto bb-cont)
 342       (in bb-exit)
 343       (pop-continue)
 344       (pop-break)))
 345
 346   (define (do-while ast)
 347     (let* ((bb-body (new-bb))
 348            (bb-cont (new-bb))
 349            (bb-exit (new-bb)))
 350       (push-continue bb-cont)
 351       (push-break bb-exit)
 352       (gen-goto bb-body)
 353       (in bb-body)
 354       (statement (subast1 ast))
 355       (gen-goto bb-cont)
 356       (in bb-cont)
 357       (test-expression (subast2 ast) bb-body bb-exit)
 358       (in bb-exit)
 359       (pop-continue)
 360       (pop-break)))
 361
 362   (define (for ast)
 363     (let* ((bb-loop (new-bb))
 364            (bb-body (new-bb))
 365            (bb-cont (new-bb))
 366            (bb-exit (new-bb)))
 367       (statement (subast1 ast))
 368       (gen-goto bb-loop)
 369       (push-continue bb-cont)
 370       (push-break bb-exit)
 371       (in bb-loop)
 372       (test-expression (subast2 ast) bb-body bb-exit)
 373       (in bb-body)
 374       (statement (subast4 ast))
 375       (gen-goto bb-cont)
 376       (in bb-cont)
 377       (statement (subast3 ast))
 378       (gen-goto bb-loop)
 379       (in bb-exit)
 380       (pop-continue)
 381       (pop-break)))
 382
 383   ;; switchs with branch tables
 384   ;; since offsets are calculated using one byte, switches are limited to
 385   ;; 60 cases or so (slightly below 64)
 386   (define (switch ast)
 387     (let* ((var      (subast1 ast))
 388            (entry-bb bb)
 389            (exit-bb  (new-bb)))
 390       (push-break exit-bb)
 391       (let loop ((asts    (cdr (ast-subasts ast))) ; car is the tested variable
 392                  (bbs     '())  ; first bb of each case
 393                  (end-bbs '())  ; last bb of each case
 394                  (cases   '())) ; case labels
 395         (if (not (null? asts))
 396             (let ((x       (car asts))
 397                   (case-bb (new-bb)))
 398               (in case-bb)
 399               (block x)
 400               (if (or (null? (bb-succs case-bb))
 401                       (not (bb-label-name (car (bb-succs case-bb)))))
 402                   ;; the first block inside the body of a switch might not
 403                   ;; have a label, in which case it ill be skipped
 404                   ;; to have a valid CFG, it must still contain an instruction
 405                   (begin (gen-goto exit-bb)
 406                          (loop (cdr asts) bbs end-bbs cases))
 407                   (loop (cdr asts)
 408                         (cons case-bb bbs)
 409                         (cons bb      end-bbs)
 410                         ;; blocks create their own bb, which contains the case label
 411                         (cons (bb-label-name (car (bb-succs case-bb)))
 412                               cases))))
 413             (let ((bbs     (reverse bbs))
 414                   (end-bbs (reverse end-bbs))
 415                   (cases   (reverse cases))
 416                   (l       (length  bbs)))
 417               ;; add the case names to the bb names
 418               (for-each ;; TODO do it for all named bbs, not just switch (but, since the name is on the successor, might be lost)
 419                (lambda (bb case)
 420                  (vector-set!
 421                   (bb-label (car (bb-succs bb))) 2
 422                   (string->symbol
 423                    (string-append (symbol->string (bb-name bb))
 424                                   "$"
 425                                   (if (symbol? case)
 426                                       ;; default
 427                                       (symbol->string case)
 428                                       ;; (case n)
 429                                       (string-append
 430                                        (symbol->string (car case))
 431                                        (number->string (cadr case))))))))
 432                bbs
 433                cases)
 434               ;; handle fall-throughs
 435               (for-each
 436                (lambda (i)
 437                  (let ((case-bb (list-ref end-bbs i)))
 438                    (if (null? (bb-succs case-bb))
 439                        ;; fall through
 440                        (begin (in case-bb)
 441                               (gen-goto (if (= i (- l 1)) ; last bb
 442                                             exit-bb
 443                                             (list-ref bbs (+ i 1))))))))
 444                (iota l))
 445               (let* ((default   (memq 'default cases)) ;; TODO if default, since we can't know the domain of possible values (at least, not with enough precision for it to be interesting), revert to naive switch
 446                      ;; cases are lists (case n) and we want the numbers
 447                      (cases     (map cadr (filter list? cases)))
 448                      (case-max  (foldl max 0        cases))
 449                      (case-min  (foldl min case-max cases))
 450                      (n-entries (+ (- case-max case-min) 1)))
 451                 (if default (error "default is not supported with switch"))
 452                 (in entry-bb)
 453                 (bb-succs-set! bb
 454                                (map (lambda (i)
 455                                       (cond ((pos-in-list (+ i case-min) cases)
 456                                              => (lambda (j) (list-ref bbs j)))
 457                                             ;; no label, jump to the exit TODO would jump to default, eventually
 458                                             (else exit-bb)))
 459                                     (iota n-entries)))
 460                 ;; the branch-table virtual instruction takes the byte to check
 461                 ;; to choose the branch
 462                 (emit
 463                  (new-instr
 464                   'branch-table
 465                   ;; the cases now start from 0, so we might have to
 466                   ;; adjust the checked variable
 467                   (car (value-bytes
 468                         (expression
 469                          (if (= case-min 0)
 470                              var
 471                              (let* ((op  (operation? '(six.x-y)))
 472                                     (ast (new-oper
 473                                           (list var (new-literal 'uint8
 474                                                                  case-min))
 475                                           #f
 476                                           op)))
 477                                (expr-type-set! ast ((op-type-rule op) ast))
 478                                ast)))))
 479                   ;; working space to calculate addresses
 480                   (new-byte-cell (current-def-proc-id) #f (bb-name bb))
 481                   #f))))))
 482       (in exit-bb)
 483       (pop-break)))
 484
 485 ;;   ;; naive switch with if cascade ;; TODO revert to that if there's a case we can't handle with branch tables
 486 ;;   (define (switch ast)
 487 ;;     (let* ((var (subast1 ast))
 488 ;;         (case-list #f)
 489 ;;         (default #f)
 490 ;;         (decision-bb bb)
 491 ;;         (exit-bb (new-bb))
 492 ;;         (prev-bb decision-bb))
 493 ;;       (push-break exit-bb)
 494 ;;       (for-each (lambda (x) ; generate each case
 495 ;;                (in (new-bb)) ; this bb will be given the name of the case
 496 ;;                (add-succ decision-bb bb)
 497 ;;                ;; if the previous case didn't end in a break, fall through
 498 ;;                (if (null? (bb-succs prev-bb))
 499 ;;                    (let ((curr bb))
 500 ;;                      (in prev-bb)
 501 ;;                      (gen-goto curr)
 502 ;;                      (in curr)))
 503 ;;                (statement x)
 504 ;;                (set! prev-bb bb))
 505 ;;              (cdr (ast-subasts ast)))
 506 ;;       (if (null? (bb-succs prev-bb)) ; if the last case didn't end in a break, fall through to the exit
 507 ;;        (gen-goto exit-bb))
 508 ;;       (bb-succs-set! decision-bb (reverse (bb-succs decision-bb))) ; preserving the order is important in the absence of break
 509 ;;       (set! case-list (list-named-bbs decision-bb))
 510 ;;       (set! default (filter (lambda (x) (eq? (car x) 'default))
 511 ;;                        (list-named-bbs decision-bb)))
 512 ;;       (set! case-list (filter (lambda (x) (and (list? (car x))
 513 ;;                                           (eq? (caar x) 'case)))
 514 ;;                          case-list))
 515 ;;       (bb-succs-set! decision-bb '()) ; now that we have the list of cases we don't need the successors anymore
 516 ;;       (let loop ((case-list case-list)
 517 ;;               (decision-bb decision-bb))
 518 ;;      (in decision-bb)
 519 ;;      (if (not (null? case-list))
 520 ;;          (let* ((next-bb (new-bb))
 521 ;;                 (curr-case (car case-list))
 522 ;;                 (curr-case-id (cadar curr-case))
 523 ;;                 (curr-case-bb (cdr curr-case)))
 524 ;;            (emit (new-instr 'x==y
 525 ;;                             (car (value-bytes (expression var)))
 526 ;;                             (new-byte-lit curr-case-id) #f))
 527 ;;            (add-succ bb next-bb) ; if false, keep looking
 528 ;;            (add-succ bb curr-case-bb) ; if true, go to the case
 529 ;;            (loop (cdr case-list)
 530 ;;                  next-bb))
 531 ;;          (gen-goto (if (not (null? default))
 532 ;;                        (cdar default)
 533 ;;                        exit-bb))))
 534 ;;       (in exit-bb)
 535 ;;       (pop-break)))
 536
 537   (define (break ast)
 538     (gen-goto (car break-stack)))
 539
 540   (define (continue ast)
 541     (gen-goto (car continue-stack)))
 542
 543   ;; generates a goto with a target label. once the current function definition
 544   ;; is over, all these labels are resolved. therefore, we don't have any gotos
 545   ;; that jump from a function to another
 546   (define (goto ast)
 547     (emit (new-instr 'goto #f #f (subast1 ast))))
 548
 549   (define (gen-goto dest)
 550     (if (null? (bb-succs bb))
 551         ;; since this is an unconditional goto, we want only one
 552         (begin (add-succ bb dest)
 553                (emit (new-instr 'goto #f #f #f)))))
 554
 555   (define (test-expression ast bb-true bb-false)
 556
 557     (define (test-byte id byte1 byte2 bb-true bb-false)
 558       (define (test-lit id x y)
 559         ((case id
 560            ((x==y) =)
 561            ((x<y) <)
 562            ((x>y) >)
 563            (else (error "invalid test")))
 564          x
 565          y))
 566       (cond ((and (byte-lit? byte1) (byte-lit? byte2))
 567              (if (test-lit id (byte-lit-val byte1) (byte-lit-val byte2))
 568                  (gen-goto bb-true)
 569                  (gen-goto bb-false)))
 570             ((byte-lit? byte2)
 571              ;; since we cons each new successor at the front, true has to be
 572              ;; added last
 573              (add-succ bb bb-false)
 574              (add-succ bb bb-true)
 575              (emit (new-instr id byte1 byte2 #f)))
 576             ((byte-lit? byte1)
 577              (let ((id
 578                     (case id
 579                       ((x==y) 'x==y)
 580                       ((x<y) 'x>y)
 581                       ((x>y) 'x<y)
 582                       (else (error "invalid test")))))
 583                (add-succ bb bb-false)
 584                (add-succ bb bb-true)
 585                (emit (new-instr id byte2 byte1 #f))))
 586             (else
 587              (add-succ bb bb-false)
 588              (add-succ bb bb-true)
 589              (emit (new-instr id byte1 byte2 #f)))))
 590
 591     (define (test-value id value1 value2 bb-true bb-false)
 592          (let loop ((bytes1  (value-bytes value1)) ; lsb first
 593                     (bytes2  (value-bytes value2))
 594                     (padded1 '())
 595                     (padded2 '()))
 596            (if (not (and (null? bytes1) (null? bytes2)))
 597                ;; note: won't work with signed types, as the padding is done
 598                ;; with 0s only
 599                (loop (if (null? bytes1) bytes1 (cdr bytes1))
 600                      (if (null? bytes2) bytes2 (cdr bytes2))
 601                      (cons (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 602                            padded1)
 603                      (cons (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 604                            padded2))
 605                ;; now so the test itself, using the padded values
 606                (let ((padded1 (reverse padded1))
 607                      (padded2 (reverse padded2)))
 608                  (case id
 609                    ((x==y) ; unlike < and >, must check all bytes, so is simpler
 610                     (let loop2 ((bytes1 padded1) ;; TODO ior the xors, but increases PICOBIT's size
 611                                 (bytes2 padded2))
 612                       (let ((byte1 (car bytes1))
 613                             (byte2 (car bytes2)))
 614                         (if (null? (cdr bytes1))
 615                             (test-byte 'x==y byte1 byte2 bb-true bb-false)
 616                             (let ((bb-true2 (new-bb)))
 617                               (test-byte 'x==y byte1 byte2 bb-true2 bb-false)
 618                               (in bb-true2)
 619                               (loop2 (cdr bytes1) (cdr bytes2)))))))
 620
 621                    (else ; < and >
 622                     (if (= (length padded1) 1)
 623                         (test-byte id (car padded1) (car padded2)
 624                                    bb-true bb-false)
 625                         ;; more than one byte, we subtract, then see if we had
 626                         ;; to borrow
 627                         (let ((scratch (new-byte-cell
 628                                         (current-def-proc-id)
 629                                         "cmp-scratch" (bb-name bb))))
 630
 631                           ;; our values might contain literal bytes and sub and
 632                           ;; subb can't have literals in their first argument,
 633                           ;; allocate it somewhere if needed
 634                           (if (and (foldl (lambda (acc new)
 635                                             (or acc (byte-lit? new)))
 636                                           #f padded2)
 637                                    (eq? id 'x>y))
 638                               (let ((tmp (alloc-value
 639                                           (bytes->type (length padded2))
 640                                           (current-def-proc-id)
 641                                           #f (bb-name bb))))
 642                                 (move-value (new-value padded2) tmp)
 643                                 (set! padded2 (value-bytes tmp))))
 644                           (if (and (foldl (lambda (acc new) ;; TODO abstract both cases
 645                                             (or acc (byte-lit? new)))
 646                                           #f padded1)
 647                                    (eq? id 'x<y))
 648                               (let ((tmp (alloc-value
 649                                           (bytes->type (length padded1))
 650                                           (current-def-proc-id)
 651                                           #f (bb-name bb))))
 652                                 (move-value (new-value padded1) tmp)
 653                                 (set! padded1 (value-bytes tmp))))
 654
 655                           (let loop ((bytes1  padded1)
 656                                      (bytes2  padded2)
 657                                      (borrow? #f))
 658                             (if (not (null? bytes1))
 659                                 (let ((b1 (car bytes1))
 660                                       (b2 (car bytes2)))
 661                                   (case id
 662                                     ((x<y)
 663                                      (emit (new-instr
 664                                             (if borrow? 'subb 'sub)
 665                                             b1 b2 scratch)))
 666                                     ((x>y)
 667                                      (emit (new-instr
 668                                             (if borrow? 'subb 'sub)
 669                                             b2 b1 scratch))))
 670                                   (loop (cdr bytes1) (cdr bytes2) #t))))
 671
 672                           (add-succ bb bb-false)
 673                           (add-succ bb bb-true)
 674                           (emit (new-instr 'branch-if-carry scratch #f #f))))))))))
 675
 676     (define (test-relation id x y bb-true bb-false)
 677       (cond ((and (literal? x) (not (literal? y)))
 678              ;; literals must be in the last argument for code generation
 679              ;; flip the relation if needed
 680              (test-relation (case id
 681                               ((x==y x!=y) id) ; commutative, no change
 682                               ((x<y)       'x>y)
 683                               ((x>y)       'x<y)
 684                               ((x<=y)      'x>=y)
 685                               ((x>=y)      'x<=y)
 686                               (else (error "relation error")))
 687                             y
 688                             x
 689                             bb-true
 690                             bb-false))
 691             ((assq id '((x!=y . x==y) (x<=y . x>y) (x>=y . x<y)))
 692              ;; flip the destination blocks to have a simpler comparison
 693              =>
 694              (lambda (z) (test-relation (cdr z) x y bb-false bb-true)))
 695             (else
 696              ;; normal case
 697 ;;           ' ;; TODO use these special cases, but fall back on the current implementation for default
 698 ;;           (case id
 699 ;;             ((x==y)
 700 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 701 ;;                     (test-zero x bb-true bb-false))
 702 ;;                    ((literal? y)
 703 ;;                     (test-eq-lit x (literal-val y) bb-true bb-false))
 704 ;;                    (else
 705 ;;                     (error "unhandled case"))))
 706 ;;             ((x<y)
 707 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 708 ;;                     (test-negative x bb-true bb-false))
 709 ;;                    (else
 710 ;;                     (error "unhandled case"))))
 711 ;;             ((x>y)
 712 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 713 ;;                     (test-positive x bb-true bb-false))
 714 ;;                    (else
 715 ;;                     (error "unhandled case"))))
 716 ;;             (else
 717 ;;              (error "unexpected operator")))
 718
 719              (let* ((value1 (expression x))
 720                     (value2 (expression y)))
 721                (test-value id value1 value2 bb-true bb-false))
 722              )))
 723
 724     (define (test-zero ast bb-true bb-false)
 725
 726       (define (default)
 727         (let ((type (expr-type ast))
 728               (value (expression ast)))
 729           ;; since nonzero is true, we must swap the destinations to use ==
 730           (test-value 'x==y value (int->value 0 type) bb-false bb-true)))
 731
 732       (cond ((oper? ast)
 733              (let* ((op (oper-op ast))
 734                     (id (op-id op)))
 735                (case id
 736                  ((!x)
 737                   (test-zero (subast1 ast) bb-false bb-true))
 738                  ((x&&y)
 739                   (let ((bb-true2 (new-bb)))
 740                     (test-zero (subast1 ast) bb-true2 bb-false)
 741                     (in bb-true2)
 742                     (test-zero (subast2 ast) bb-true bb-false)))
 743                  ((|x\|\|y|)
 744                   (let ((bb-false2 (new-bb)))
 745                     (test-zero (subast1 ast) bb-true bb-false2)
 746                     (in bb-false2)
 747                     (test-zero (subast2 ast) bb-true bb-false)))
 748                  ((x==y x!=y x<y x>y x<=y x>=y)
 749                   (test-relation id
 750                                  (subast1 ast)
 751                                  (subast2 ast)
 752                                  bb-true
 753                                  bb-false))
 754                  (else (default)))))
 755             (else (default))))
 756
 757     (test-zero ast bb-true bb-false))
 758
 759   ;; checks if an expression has already been computed in the current procedure
 760   ;; TODO maybe stock all the available expressions not in the def-procedure, but in each node ? as variables are mutated, or functions called, we remove from it ? calls could really harm us, since to be conservative, all calls can be considered to mutate all globals
 761   ;; TODO if we end up doing dataflow analysis for cse, also use it for dead-code elimination, if possible
 762   (define (computed-expression? ast) ;; TODO to distinguish between global and local, look at the def-proc-id, if #f, it's global
 763     ;; TODO reject if it has side effects (++, --) or calls (or extend the analyis to calls ?), a complete mutability analysis would probably be needed for every variable in the expression... checking only in the procedure won't work, since a called function might change a global that's inside the expression in the time between 2 of its uses. maybe SSA (single static assignment) would help ? ALSO REJECT IF IT READS FROM MEMORY (since we can't really know if what we read has not changed. Or maybe consider the memory as a global for this ?)
 764     ;; TODO when we see calls and assignments, remove from the set of expressions what is not valid anymore (lhs for assignments, globals for calls)
 765     (and current-def-proc
 766          (table-ref
 767           (def-procedure-computed-expressions current-def-proc) ast #f)))
 768
 769   (define (expression ast)
 770     (let ((result
 771            (or #;
 772                (computed-expression? ast) ;; TODO breaks something in register allocation, possibly due to the ++ and -- ?
 773                (cond ((literal? ast) (literal ast))
 774                      ((ref? ast)     (ref ast))
 775                      ((oper? ast)    (oper ast))
 776                      ((call? ast)    (call ast))
 777                      (else           (error "unexpected ast" ast))))))
 778       (if current-def-proc
 779           (table-set! (def-procedure-computed-expressions current-def-proc)
 780                       ast result)) ; cache the result
 781       (do-delayed-post-incdec)
 782       result))
 783
 784   (define (literal ast)
 785     (let ((val (literal-val ast)))
 786       (int->value val (expr-type ast))))
 787
 788   (define (ref ast)
 789     (let* ((def-var (ref-def-var ast))
 790            (value (def-variable-value def-var)))
 791       value))
 792
 793   (define (add-sub id value1 value2 result)
 794     (let loop ((bytes1 (value-bytes value1)) ; car is lsb
 795                (bytes2 (value-bytes value2))
 796                (bytes3 (value-bytes result))
 797                (ignore-carry-borrow? #t))
 798       (if (not (null? bytes3))
 799           ;; if we would add or subtract 0 and not use the carry, just move
 800           ;; the value
 801           (let ((b1 (car bytes1)) (b2 (car bytes2)) (b3 (car bytes3)))
 802             (emit (new-instr
 803                    (if ignore-carry-borrow?
 804                        (case id ((x+y) 'add)  ((x-y) 'sub))
 805                        (case id ((x+y) 'addc) ((x-y) 'subb)))
 806                    b1 b2 b3))
 807             (loop (cdr bytes1) (cdr bytes2) (cdr bytes3) #f))
 808           result)))
 809
 810   (define (mul value-x value-y type result)
 811     (let* ((bytes-x (value-bytes value-x))
 812            (bytes-y (value-bytes value-y))
 813            ;; to determine the length of the operands, we ignore the padding
 814            (lx (length (filter (lambda (x) (not (and (byte-lit? x)
 815                                                      (= (byte-lit-val x) 0))))
 816                              bytes-x)))
 817            (ly (length (filter (lambda (x) (not (and (byte-lit? x)
 818                                                      (= (byte-lit-val x) 0))))
 819                              bytes-y))))
 820       ;; if this a multiplication by 2 or 4, we use additions instead
 821       ;; at this point, only y (or both x and y) can contain a literal
 822       (if (and (= ly 1)
 823                (byte-lit? (car bytes-y))
 824                (let ((v (byte-lit-val (car bytes-y))))
 825                  (or (= v 2) (= v 4))))
 826           (case (byte-lit-val (car bytes-y))
 827             ((2) (add-sub 'x+y value-x value-x result)) ; simple addition
 828             ((4) (let ((tmp (alloc-value (bytes->type
 829                                           (length (value-bytes result)))
 830                                          (current-def-proc-id)
 831                                          #f (bb-name bb))))
 832                    (add-sub 'x+y value-x value-x tmp)
 833                    (add-sub 'x+y tmp tmp result))))
 834           ;; if not, we have to do it the long way
 835           (begin
 836             ;; finds the appropriate multiplication routine (depending on the
 837             ;; length of each argument) and turns the multiplication into a
 838             ;; call to the routine
 839             ;; the arguments must be the asts of the 2 arguments (x and y) and
 840             ;; the type of the returned value, since these are what are
 841             ;; expected by the call function
 842
 843             ;; to avoid code duplication (i.e. having a routine for 8 by 16
 844             ;; multplication and one for 16 by 8), the longest operand goes first
 845             (if (> ly lx)
 846                 (let ((tmp1 y)
 847                       (tmp2 ly))
 848                   (set! y x)
 849                   (set! x tmp1)
 850                   (set! ly lx)
 851                   (set! lx tmp2)))
 852             (routine-call
 853              (string->symbol ; mul8_8, mul8_16, etc
 854               ;; for now, only unsigned multiplications are supported
 855               (string-append "__mul"
 856                              (number->string (* lx 8)) "_"
 857                              (number->string (* ly 8))))
 858              (list value-x value-y)
 859              type)))))
 860
 861   (define (mod x y result)
 862     (let* ((bytes1 (value-bytes x))
 863            (bytes2 (value-bytes y))
 864            (bytes3 (value-bytes result))
 865            (y0     (car bytes2)))
 866       ;; if y is a literal and a power of 2, we can do a bitwise and
 867       (if (and (byte-lit? y0)
 868                (let ((x (/ (log (value->int y)) (log 2))))
 869                  (= (floor x) x)))
 870           ;; bitwise and with y - 1
 871           (let ((tmp (alloc-value (bytes->type (length bytes2))
 872                                   (current-def-proc-id)
 873                                   #f (bb-name bb))))
 874             (move-value (int->value (- (value->int y) 1)
 875                                     (bytes->type (length bytes2)))
 876                         tmp)
 877             (bitwise 'x&y x tmp result))
 878           ;; TODO for the general case, try to optimise the case where division and modulo are used together, since they are calculated together
 879           (error "modulo is only supported for powers of 2"))
 880       result))
 881
 882   (define (shift id value-x value-y type result)
 883     (let ((bytes1 (value-bytes value-x))
 884           (bytes2 (value-bytes value-y))
 885           (bytes3 (value-bytes result)))
 886       ;; if the second argument is a literal and a multiple of 8, we can simply
 887       ;; move the bytes around
 888       (let ((y0 (car bytes2)))
 889         (if (and (byte-lit? y0) (= (modulo (byte-lit-val y0) 8) 0))
 890             ;; uses only the first byte, but shifting by 255 should be enough
 891             (let ((n (/ (byte-lit-val y0) 8))
 892                   (l (length bytes1))) ; same length for x and result
 893               (let loop ((i 0)
 894                          (x bytes1))
 895                 (if (< i l)
 896                     (case id
 897                       ((x<<y)
 898                        (move (if (< i n)
 899                                  (new-byte-lit 0) ; padding
 900                                  (car x))
 901                              (list-ref bytes3 i))
 902                        (loop (+ i 1) (if (< i n) x (cdr x))))
 903                       ((x>>y)
 904                        (move (if (<= l (+ i n))
 905                                  (new-byte-lit 0)
 906                                  (list-ref x (+ i n)))
 907                              (list-ref bytes3 i))
 908                        (loop (+ i 1) x)))
 909                     result)))
 910             (routine-call
 911              (string->symbol
 912               (string-append "__sh"
 913                              (case id ((x<<y) "l") ((x>>y) "r"))
 914                              (number->string (* 8 (length bytes1)))))
 915              (list value-x value-y)
 916              type)))))
 917
 918   ;; bitwise and, or, xor
 919   ;; TODO similar to add-sub and probably others, abstract multi-byte ops
 920   ;; TODO use bit set, clear and toggle for some shortcuts
 921   (define (bitwise id value1 value2 result)
 922     (let loop ((bytes1 (value-bytes value1))
 923                (bytes2 (value-bytes value2))
 924                (bytes3 (value-bytes result)))
 925       (if (not (null? bytes3)) ;; TODO check for cases like or 0, or ff, and 0, and ff, ...
 926           (begin
 927             (emit (new-instr (case id ((x&y) 'and) ((|x\|y|) 'ior) ((x^y) 'xor))
 928                              (car bytes1) (car bytes2) (car bytes3)))
 929             (loop (cdr bytes1) (cdr bytes2) (cdr bytes3)))
 930           result)))
 931
 932   (define (bitwise-negation x result)
 933     (let loop ((bytes1 (value-bytes x))
 934                (bytes2 (value-bytes result)))
 935       (if (not (null? bytes2))
 936           (begin (emit (new-instr 'not (car bytes1) #f (car bytes2)))
 937                  (loop (cdr bytes1) (cdr bytes2))))))
 938
 939   (define (do-delayed-post-incdec)
 940     (if (not (null? delayed-post-incdec))
 941         (let* ((ast (car delayed-post-incdec))
 942                (type (expr-type ast))
 943                (op (oper-op ast))
 944                (id (op-id op)))
 945           (set! delayed-post-incdec (cdr delayed-post-incdec))
 946           (let ((x (subast1 ast)))
 947             (if (not (ref? x))
 948                 (error "assignment target must be a variable"))
 949             (let ((result (def-variable-value (ref-def-var x))))
 950               ;; clobbers the original value, which is fine, since it
 951               ;; was moved somewhere else for the expression
 952               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 953                        result
 954                        (int->value 1 type)
 955                        result)))
 956           (do-delayed-post-incdec))))
 957
 958   ;; calculates an address in an array by adding the base pointer and the offset
 959   ;; and puts the answer in FSR0 so that changes to INDF0 change the array
 960   ;; location
 961   (define (calculate-address ast)
 962     ;; if we have a special FSR variable, no need to calculate the address as
 963     ;; it is already in the register
 964     (let ((base-name (array-base-name ast))
 965           (index? (eq? (op-id (oper-op ast)) 'index)))
 966       (if (not (and base-name
 967                     (memq base-name fsr-variables)))
 968           (let ((base    (expression (subast1 ast)))
 969                 ;; NB: actual addresses are 12 bits, not 16
 970                 (address (new-value (list (get-register FSR0L)
 971                                           (get-register FSR0H)))))
 972             (if index?
 973                 ;; we pad up to uint16, since it is the size of the addresses
 974                 (let ((value1 (extend base 'uint16))
 975                       (value2 (extend (expression (subast2 ast)) 'uint16)))
 976                   (add-sub 'x+y value1 value2 address))
 977                 ;; no offset with simple dereference
 978                 (move-value base address)))
 979           (error "You used the array index syntax with a FSR variable, didn't you? I told you not to."))))
 980
 981   (define (array-base-name ast)
 982     ;; returns #f if the lhs is not a direct variable reference
 983     ;; eg : *x++ ; (x+y)* ; ...
 984     (let ((lhs (subast1 ast)))
 985       (and (ref? lhs)
 986            (def-id (ref-def-var lhs)))))
 987
 988   (define (get-indf base-name)
 989     ;; INDF0 is not here, since it's already used for regular array accesses
 990     (if (eq? base-name 'SIXPIC_FSR1)
 991         (new-value (list (get-register INDF1)))
 992         (new-value (list (get-register INDF2)))))
 993
 994   (define (oper ast)
 995     (let* ((type (expr-type ast))
 996            (op (oper-op ast))
 997            (id (op-id op)))
 998
 999       (define (arith-op id x y value-x value-y)
1000         ;; since code generation does not accept literals as first
1001         ;; arguments unless both arguments are, if this is the
1002         ;; case, we either have to swap the arguments (if
1003         ;; possible) or allocate the argument somewhere
1004         (if (and (literal? x) (not (literal? y)))
1005             (if (memq id '(x+y x*y x&y |x\|y| x^y))
1006                 ;; the operator is commutative, we can swap the args
1007                 (let ((tmp value-x))
1008                   (set! value-x value-y)
1009                   (set! value-y tmp))
1010                 ;; the operator is not commutative, we have to
1011                 ;; allocate the first argument somewhere
1012                 (let ((dest (alloc-value (expr-type x)
1013                                          (current-def-proc-id)
1014                                          #f (bb-name bb))))
1015                   (move-value value-x dest)
1016                   (set! value-x dest))))
1017         (let ((result (alloc-value type
1018                                    (current-def-proc-id)
1019                                    #f (bb-name bb))))
1020           (case id
1021             ((x+y x-y)        (add-sub id value-x value-y result))
1022             ((x*y)            (mul value-x value-y type result))
1023             ((x/y)            (error "division not implemented yet")) ;; TODO optimize for powers of 2
1024             ((x%y)            (mod value-x value-y result))
1025             ((x&y |x\|y| x^y) (bitwise id value-x value-y result))
1026             ((x>>y x<<y)      (shift id value-x value-y type result)))))
1027
1028       (cond
1029        ((op1? op)
1030         (case id
1031           ((-x ~x)
1032            (let ((x (extend (expression (subast1 ast))
1033                             type))
1034                  (result (alloc-value type
1035                                       (current-def-proc-id)
1036                                       #f (bb-name bb))))
1037              (case id
1038                ((-x) (add-sub 'x-y
1039                               (int->value 0 type)
1040                               x
1041                               result))
1042                ((~x) (bitwise-negation x result)))
1043              result))
1044           ((++x --x)
1045            (let ((x (subast1 ast)))
1046              (if (not (ref? x))
1047                  (error "assignment target must be a variable"))
1048              (let ((result (def-variable-value (ref-def-var x))))
1049                (add-sub (if (eq? id '++x) 'x+y 'x-y)
1050                         result
1051                         (int->value 1 type)
1052                         result)
1053                result)))
1054           ((x++ x--)
1055            (let ((x (subast1 ast)))
1056              (if (not (ref? x))
1057                  (error "assignment target must be a variable"))
1058              ;; push-delayed-post-incdec moves the original value
1059              ;; somewhere else, and returns that location
1060              (push-delayed-post-incdec ast)))
1061           ((*x)
1062            ;; if it's a FSR variable, no adress to set
1063            (let ((base-name (array-base-name ast)))
1064              (if (and (ref? (subast1 ast)) ; do we have a FSR variable ?
1065                       base-name
1066                       (memq base-name fsr-variables))
1067                  (get-indf base-name)
1068                  (begin (calculate-address ast)
1069                         (new-value (list (get-register INDF0)))))))
1070           (else
1071            (error "unary operation error" id))))
1072
1073        ((op2? op)
1074         (case id
1075           ((x+y x-y x*y x/y x%y x&y |x\|y| x^y x>>y x<<y)
1076            (let* ((x (subast1 ast))
1077                   (y (subast2 ast)))
1078              (let* ((value-x (extend (expression x) type))
1079                     (value-y (extend (expression y) type)))
1080                (arith-op id x y value-x value-y))))
1081           ((x=y)
1082            (let* ((x       (subast1 ast))
1083                   (y       (subast2 ast))
1084                   (value-y (expression y)))
1085              (cond
1086               ;; lhs is a variable
1087               ((ref? x)
1088                (let ((ext-value-y (extend value-y type)))
1089                  (let ((result (def-variable-value (ref-def-var x))))
1090                    (move-value value-y result)
1091                    result)))
1092               ;; lhs is a pointer dereference
1093               ((and (oper? x) (eq? (op-id (oper-op x)) '*x))
1094                (let ((base-name (array-base-name x))
1095                      (val       (car (value-bytes value-y))))
1096                  (if (and (ref? (subast1 x))
1097                           base-name
1098                           (memq base-name fsr-variables))
1099                      (move val (car (value-bytes (get-indf base-name))))
1100                      (begin (calculate-address x)
1101                             (move val (get-register INDF0))))))
1102               ;; lhs is an indexed array access
1103               ((and (oper? x) (eq? (op-id (oper-op x)) 'index))
1104                ;; note: this will throw an error if SIXPIC_FSR{1,2} is
1105                ;; used. this is by design, as it would clobber the value
1106                ;; in the FSR registers, which goes against their purpose
1107                ;; of storing a user-chosen value
1108                (calculate-address x)
1109                ;; this section of memory is a byte array, only the lsb
1110                ;; of y is used
1111                (move (car (value-bytes value-y)) (get-register INDF0)))
1112               (else (error "assignment target must be a variable or an array slot")))))
1113           ((index)
1114            ;; note: throws an error if given SIXPIC_FSR{1,2}, see above
1115            (calculate-address ast)
1116            (new-value (list (get-register INDF0))))
1117           ((x+=y x-=y x*=y x/=y x%=y x&=y |x\|=y| x^=y x>>=y x<<=y)
1118            (let* ((x (subast1 ast))
1119                   (y (subast2 ast))
1120                   (value-x (extend (expression x) type))
1121                   (value-y (extend (expression y) type)))
1122              (move-value (arith-op (case id
1123                                      ((x+=y)    'x+y)
1124                                      ((x-=y)    'x-y)
1125                                      ((x*=y)    'x*y)
1126                                      ((x/=y)    'x/y)
1127                                      ((x%=y)    'x%y)
1128                                      ((x&=y)    'x&y)
1129                                      ((|x\|=y|) '|x\|y|)
1130                                      ((x^=y)    'x^=y)
1131                                      ((x>>=y)   'x>>y)
1132                                      ((x<<=y)   'x<<y))
1133                                    x y value-x value-y)
1134                          value-x)
1135              value-x))
1136           ((x==y x!=y x>y x>=y x<y x<=y x&&y |x\|\|y|)
1137            (let ((bb-start bb)
1138                  (bb-true  (new-bb))
1139                  (bb-false (new-bb))
1140                  (bb-join  (new-bb))
1141                  (result   (alloc-value type
1142                                         (current-def-proc-id)
1143                                         #f (bb-name bb))))
1144              (in bb-true)
1145              (move-value (int->value 1 type) result)
1146              (gen-goto bb-join)
1147              (in bb-false)
1148              (move-value (int->value 0 type) result)
1149              (gen-goto bb-join)
1150              (in bb-start)
1151              (test-expression ast bb-true bb-false)
1152              (in bb-join)
1153              result))
1154           (else
1155            (error "binary operation error" id))))
1156
1157        ((op3? op)
1158         (let ((bb-start bb)
1159               (bb-true  (new-bb))
1160               (bb-false (new-bb))
1161               (bb-join  (new-bb))
1162               (result   (alloc-value type
1163                                      (current-def-proc-id)
1164                                      #f (bb-name bb))))
1165           (in bb-true)
1166           (move-value (expression (subast2 ast)) result)
1167           (gen-goto bb-join)
1168           (in bb-false)
1169           (move-value (expression (subast3 ast)) result)
1170           (gen-goto bb-join)
1171           (in bb-start)
1172           (test-expression (subast1 ast) bb-true bb-false)
1173           (in bb-join)
1174           result)))))
1175
1176   ;; generates the cfg for a predefined routine and adds it to the current cfg
1177   (define (include-predefined-routine proc)
1178     (define (get-bytes var)
1179       (value-bytes (def-variable-value var)))
1180     (let ((old-proc current-def-proc) ; if we were already defining a procedure, save it
1181           (old-bb-no current-def-proc-bb-id)
1182           (id (def-id proc))
1183           (params (def-procedure-params proc))
1184           (value (def-procedure-value proc))
1185           (old-bb bb)
1186           (entry (begin (set! current-def-proc proc)
1187                         (set! current-def-proc-bb-id 0)
1188                         (new-bb)))) ;; TODO insipired from def-procedure, abstract
1189       (def-procedure-entry-set! proc entry)
1190       (in entry)
1191       (case id
1192
1193         ((rom_get)
1194          (let* ((x  (get-bytes (car params)))
1195                 (x0 (car  x))
1196                 (x1 (cadr x))
1197                 (z0 (car (value-bytes value))))
1198            ;; TODO use postinc/dec and co
1199            (emit (new-instr 'tblrd x0 x1 #f))
1200            (move (get-register TABLAT) z0)))
1201
1202         ((exit)
1203          (emit (new-instr 'sleep #f #f #f)))
1204
1205         ((uart_write) ; writes a byte ;; TODO should configure the uart
1206          (let* ((x (car (get-bytes (car params)))))
1207            (move x (get-register TXREG)))) ;; TODO this is mostly for debugging purposes, won't work on the chip
1208         ((uart_read) ; reads a byr
1209          (let ((z (car (value-bytes value))))
1210            (move (get-register RCREG) z)))
1211
1212         ((__mul8_8)
1213          (let ((x (car params))
1214                (y (cadr params))
1215                (z (value-bytes value)))
1216            ;; TODO implement literal multiplication in the simulator
1217            (emit (new-instr 'mul (car (get-bytes x)) (car (get-bytes y)) #f))
1218            (move (get-register PRODL) (car z)))) ; lsb
1219
1220         ((__mul16_8)
1221          (let* ((x  (get-bytes (car params)))
1222                 (x0 (car  x)) ; lsb
1223                 (x1 (cadr x))
1224                 (y  (get-bytes (cadr params)))
1225                 (y0 (car y))
1226                 (z  (value-bytes value))
1227                 (z0 (car  z)) ; lsb
1228                 (z1 (cadr z)))
1229            (emit (new-instr 'mul y0 x1 #f))
1230            (move (get-register PRODL) z1)
1231
1232            (emit (new-instr 'mul y0 x0 #f))
1233            (move (get-register PRODL) z0)
1234            (emit (new-instr 'add  (get-register PRODH) z1 z1))))
1235
1236         ((__mul16_16)
1237          (let* ((x  (get-bytes (car params)))
1238                 (x0 (car  x))
1239                 (x1 (cadr x))
1240                 (y  (get-bytes (cadr params)))
1241                 (y0 (car  y))
1242                 (y1 (cadr y))
1243                 (z  (value-bytes value))
1244                 (z0 (car  z))
1245                 (z1 (cadr z)))
1246
1247            (emit (new-instr 'mul x0 y0 #f))
1248            (move (get-register PRODH) z1)
1249            (move (get-register PRODL) z0)
1250
1251            (emit (new-instr 'mul x0 y1 #f))
1252            (emit (new-instr 'add  (get-register PRODL) z1 z1))
1253
1254            (emit (new-instr 'mul x1 y0 #f))
1255            (emit (new-instr 'add  (get-register PRODL) z1 z1))))
1256
1257         ((__mul32_16)
1258          (let* ((x  (get-bytes (car params)))
1259                 (x0 (car    x))
1260                 (x1 (cadr   x))
1261                 (x2 (caddr  x))
1262                 (x3 (cadddr x))
1263                 (y  (get-bytes (cadr params)))
1264                 (y0 (car  y))
1265                 (y1 (cadr y))
1266                 (z  (value-bytes value))
1267                 (z0 (car    z))
1268                 (z1 (cadr   z))
1269                 (z2 (caddr  z))
1270                 (z3 (cadddr z)))
1271
1272            (emit (new-instr 'mul x0 y0 #f))
1273            (move (get-register PRODH) z1)
1274            (move (get-register PRODL) z0)
1275
1276            (emit (new-instr 'mul x1 y1 #f))
1277            (move (get-register PRODH) z3)
1278            (move (get-register PRODL) z2)
1279
1280            (emit (new-instr 'mul x1 y0 #f))
1281            (emit (new-instr 'add  (get-register PRODL) z1 z1))
1282            (emit (new-instr 'addc (get-register PRODH) z2 z2))
1283            (emit (new-instr 'addc z3     (new-byte-lit 0) z3))
1284
1285            (emit (new-instr 'mul x0 y1 #f))
1286            (emit (new-instr 'add  (get-register PRODL) z1 z1))
1287            (emit (new-instr 'addc (get-register PRODH) z2 z2))
1288            (emit (new-instr 'addc z3     (new-byte-lit 0) z3))
1289
1290            (emit (new-instr 'mul x2 y0 #f))
1291            (emit (new-instr 'add  (get-register PRODL) z2 z2))
1292            (emit (new-instr 'addc (get-register PRODH) z3 z3))
1293
1294            (emit (new-instr 'mul x2 y1 #f))
1295            (emit (new-instr 'add  (get-register PRODL) z3 z3))
1296
1297            (emit (new-instr 'mul x3 y0 #f))
1298            (emit (new-instr 'add  (get-register PRODL) z3 z3))))
1299
1300         ((__shl8 __shr8 __shl16 __shr16 __shl32 __shr32)
1301          (let* ((id (symbol->string id))
1302                 (left-shift? (eq? (string-ref id 4) #\l))
1303                 (x (def-variable-value (car params)))
1304                 (y (def-variable-value (cadr params)))
1305                 (y0 (car (value-bytes y))) ; shift by 255 is enough
1306                 (bytes-z (value-bytes value))
1307                 (start-bb (new-bb))
1308                 (loop-bb  (new-bb))
1309                 (after-bb (new-bb)))
1310            (move-value x value)
1311            (gen-goto start-bb) ; fall through to the loop
1312            (in start-bb)
1313            ;; if we'd shift of 0, we're done
1314            (add-succ bb loop-bb) ; false
1315            (add-succ bb after-bb) ; true
1316            (emit (new-instr 'x==y y0 (new-byte-lit 0) #f))
1317            (in loop-bb)
1318            ;; clear the carry, to avoid reinserting it in the register
1319            (emit (new-instr 'clear
1320                             (get-register STATUS)
1321                             (new-byte-lit C)
1322                             #f))
1323            ;; shift for each byte, since it's a rotation using the carry,
1324            ;; what goes out from the low bytes gets into the high bytes
1325            (for-each (lambda (b)
1326                        (emit (new-instr (if left-shift? 'shl 'shr)
1327                                         b #f b)))
1328                      (if left-shift? bytes-z (reverse bytes-z)))
1329            (emit (new-instr 'sub y0 (new-byte-lit 1) y0))
1330            (gen-goto start-bb)
1331            (in after-bb))))
1332       (return-with-no-new-bb proc)
1333       (set! current-def-proc old-proc)
1334       (set! current-def-proc-bb-id old-bb-no)
1335       (resolve-all-gotos entry (list-named-bbs entry))
1336       (in old-bb)))
1337
1338   (define (call ast #!optional (evaluated-args #f))
1339     ;; note: we might call this with an ast here the arguments are already
1340     ;; evaluated (when doing a routine call)
1341     (let* ((def-proc   (call-def-proc ast))
1342            (arguments  (ast-subasts ast))
1343            (parameters (def-procedure-params def-proc)))
1344       (if (and (memq (def-id def-proc) predefined-routines)
1345                (not (def-procedure-entry def-proc)))
1346           ;; it's the first time we encounter this predefined routine, generate
1347           ;; the corresponding cfg
1348           (include-predefined-routine def-proc))
1349       ;; argument number check
1350       (if (not (= (length (if evaluated-args evaluated-args arguments))
1351                   (length parameters))) ;; TODO check at parse time ?
1352           (error (string-append "wrong number of arguments given to function "
1353                                 (symbol->string (def-id def-proc)) ": "
1354                                 (number->string (length arguments)) " given, "
1355                                 (number->string (length parameters))
1356                                 " expected")))
1357       (for-each (lambda (ast def-var)
1358                   (let ((value (if evaluated-args ast (expression ast))))
1359                     (let ((ext-value (extend value (def-variable-type def-var))))
1360                       (move-value value (def-variable-value def-var)))))
1361                 (if evaluated-args evaluated-args arguments)
1362                 parameters)
1363       (emit (new-call-instr def-proc))
1364       (let ((value (def-procedure-value def-proc)))
1365         (let ((result
1366                (alloc-value (def-procedure-type def-proc)
1367                             (current-def-proc-id)
1368                             #f (bb-name bb))))
1369           (move-value value result)
1370           result))))
1371
1372   ;; call to a predefined routine, a simple wrapper to an ordinary call
1373   ;; name is a symbol, args is a list of the evaluated arguments
1374   (define (routine-call name args type)
1375     (cond ((memp (lambda (x) (eq? (def-id x) name))
1376                  initial-cte)
1377            => (lambda (x) (call (new-call '() type (car x)) args)))
1378           (else (error "unknown routine: " name))))
1379
1380   (in (new-bb))
1381   (program ast)
1382   cfg)
1383
1384 (define (print-cfg-bbs cfg)
1385   (for-each (lambda (bb)
1386               (pp (list "BB:" (bb-name bb)
1387                         "SUCCS" (map bb-name (bb-succs bb))
1388                         "PREDS" (map bb-name (bb-preds bb))
1389                         (cond ((null? (bb-rev-instrs bb)) "EMPTY")
1390                               ((and (null? (cdr (bb-rev-instrs bb)))
1391                                      (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
1392                               (else #f)))))
1393             (cfg-bbs cfg)))