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