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