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