cfg.scm

   1 ;;; generation of control flow graph
   2
   3 ;; special variables whose contents are located in the FSR registers
   4 ;; TODO put here ?
   5 (define fsr-variables '(SIXPIC_FSR0 SIXPIC_FSR1 SIXPIC_FSR2))
   6
   7 (define-type cfg
   8   bbs
   9   next-label-num)
  10
  11 (define (new-cfg)
  12   (make-cfg '() 0))
  13
  14 (define-type bb
  15   label-num
  16   label-name ; if the block had a label
  17   label
  18   rev-instrs
  19   unprintable:
  20   preds
  21   succs
  22   live-before)
  23
  24 (define-type instr
  25   extender: define-type-of-instr
  26   (live-before unprintable:)
  27   (live-after unprintable:)
  28   (hash unprintable:)
  29   id
  30   src1
  31   src2
  32   dst)
  33
  34 (define-type-of-instr call-instr
  35   unprintable:
  36   def-proc)
  37
  38 (define-type-of-instr return-instr
  39   unprintable:
  40   def-proc)
  41
  42 (define (new-instr id src1 src2 dst)
  43   (make-instr '() '() #f id src1 src2 dst))
  44
  45 ;; list of all conditional branching generic instructions
  46 (define conditional-instrs ;; TODO add as we add specialized instructions
  47   '(x==y x!=y x<y x>y x<=y x>=y))
  48
  49 (define (new-call-instr def-proc)
  50   (make-call-instr '() '() #f 'call #f #f #f def-proc))
  51
  52 (define (new-return-instr def-proc)
  53   (make-return-instr '() '() #f 'return #f #f #f def-proc))
  54
  55 (define (add-bb cfg)
  56   (let* ((label-num (cfg-next-label-num cfg))
  57          (bb (make-bb label-num #f #f '() '() '() '())))
  58     (bb-label-set!
  59      bb
  60      (asm-make-label
  61       (string->symbol
  62        (string-append "$"
  63                       (number->string label-num)))))
  64     (cfg-bbs-set! cfg (cons bb (cfg-bbs cfg)))
  65     (cfg-next-label-num-set! cfg (+ 1 (cfg-next-label-num cfg)))
  66     bb))
  67
  68 (define (add-instr bb instr)
  69   (let ((rev-instrs (bb-rev-instrs bb)))
  70     (bb-rev-instrs-set! bb (cons instr rev-instrs))))
  71
  72 (define (add-succ bb succ)
  73   (bb-succs-set! bb (cons succ (bb-succs bb)))
  74   (bb-preds-set! succ (cons bb (bb-preds succ))))
  75
  76 (define (generate-cfg ast)
  77
  78   (define cfg (new-cfg))
  79
  80   (define bb #f) ; current bb
  81
  82   (define (in x)
  83     (set! bb x))
  84
  85   (define (new-bb)
  86     (add-bb cfg))
  87
  88   (define (emit instr)
  89     (add-instr bb instr))
  90
  91   (define current-def-proc #f)
  92   (define break-stack '())
  93   (define continue-stack '())
  94   (define delayed-post-incdec '())
  95
  96   (define (push-break x)
  97     (set! break-stack (cons x break-stack)))
  98
  99   (define (pop-break)
 100     (set! break-stack (cdr break-stack)))
 101
 102   (define (push-continue x)
 103     (set! continue-stack (cons x continue-stack)))
 104
 105   (define (pop-continue)
 106     (set! continue-stack (cdr continue-stack)))
 107
 108   (define (push-delayed-post-incdec x)
 109     (set! delayed-post-incdec (cons x delayed-post-incdec)))
 110
 111   (define (program ast)
 112     (let loop ((asts (ast-subasts ast)))
 113       (if (not (null? asts))
 114           (let ((ast (car asts)))
 115             (if (null? (cdr asts))
 116                 (let ((value (expression ast)))
 117                   (return-with-no-new-bb value))
 118                 (begin
 119                   (toplevel ast)
 120                   (loop (cdr asts))))))))
 121
 122   (define (toplevel ast)
 123     (cond ((def-variable? ast)
 124            (def-variable ast))
 125           ((def-procedure? ast)
 126            (def-procedure ast))
 127           (else
 128            (statement ast))))
 129
 130   (define (def-variable ast)
 131     (let ((subasts (ast-subasts ast)))
 132       (if (not (null? subasts)) ; if needed, set the variable
 133           (let ((value (expression (subast1 ast))))
 134             (let ((ext-value (extend value (def-variable-type ast))))
 135               (move-value value (def-variable-value ast)))))))
 136
 137   (define (def-procedure ast)
 138
 139     ;; resolve the C gotos by setting the appropriate successor to their bb
 140     (define (resolve-all-gotos start table visited)
 141       (if (not (memq start visited))
 142           (begin (for-each (lambda (x)
 143                              (if (and (eq? (instr-id x) 'goto)
 144                                       (instr-dst x)) ; unresolved label
 145                                  (let ((target (assoc (instr-dst x) table)))
 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                              (resolve-all-gotos x table (cons start visited)))
 153                            (bb-succs start)))))
 154
 155     (let ((old-bb bb)
 156           (entry (new-bb)))
 157       (def-procedure-entry-set! ast entry)
 158       (set! current-def-proc ast)
 159       (in entry)
 160       (for-each statement (ast-subasts ast))
 161       (return-with-no-new-bb ast)
 162       (set! current-def-proc #f)
 163       (resolve-all-gotos entry (list-named-bbs entry '()) '())
 164       (in old-bb)))
 165
 166   ;; returns a list of all named bbs in the successor-tree of a given bb
 167   (define (list-named-bbs start visited)
 168     (if (not (memq start visited))
 169         (let ((succs
 170                (apply append
 171                       (map (lambda (bb) (list-named-bbs bb (cons start visited)))
 172                            (bb-succs start)))))
 173           (if (bb-label-name start)
 174               (cons (cons (bb-label-name start) start) succs)
 175               succs))
 176         '()))
 177
 178   (define (statement ast)
 179     (cond ((def-variable? ast)
 180            (def-variable ast))
 181           ((block? ast)
 182            (block ast))
 183           ((return? ast)
 184            (return ast))
 185           ((if? ast)
 186            (if (null? (cddr (ast-subasts ast)))
 187                (if1 ast)
 188                (if2 ast)))
 189           ((while? ast)
 190            (while ast))
 191           ((do-while? ast)
 192            (do-while ast))
 193           ((for? ast)
 194            (for ast))
 195           ((switch? ast)
 196            (switch ast))
 197           ((break? ast)
 198            (break ast))
 199           ((continue? ast)
 200            (continue ast))
 201           ((goto? ast)
 202            (goto ast))
 203           (else
 204            (expression ast))))
 205
 206   (define (block ast)
 207     (if (block-name ast) ; named block ?
 208         (begin (let ((old-bb bb))
 209                      (in (new-bb))
 210                      (add-succ old-bb bb))
 211                (bb-label-name-set! bb (block-name ast)) ))
 212     (for-each statement (ast-subasts ast)))
 213
 214   (define (move from to)
 215     (emit (new-instr 'move from #f to)))
 216
 217   (define (move-value from to)
 218     (let loop ((from (value-bytes from))
 219                (to   (value-bytes to)))
 220       (cond ((null? to)) ; done
 221             ((null? from) ; promote the value by padding
 222              (move (new-byte-lit 0) (car to))
 223              (loop from (cdr to)))
 224             (else
 225              (move (car from) (car to))
 226              (loop (cdr from) (cdr to))))))
 227
 228   (define (return-with-no-new-bb def-proc)
 229     (emit (new-return-instr def-proc)))
 230
 231   (define (return ast)
 232     (if (null? (ast-subasts ast))
 233         (return-with-no-new-bb current-def-proc)
 234         (let ((value (expression (subast1 ast))))
 235           (let ((ext-value (extend value (def-procedure-type current-def-proc))))
 236             (move-value value (def-procedure-value current-def-proc))
 237             (return-with-no-new-bb current-def-proc))))
 238     (in (new-bb)))
 239
 240   (define (if1 ast)
 241     (let* ((bb-join (new-bb))
 242            (bb-then (new-bb)))
 243       (test-expression (subast1 ast) bb-then bb-join)
 244       (in bb-then)
 245       (statement (subast2 ast))
 246       (in bb-join)))
 247
 248   (define (if2 ast)
 249     (let* ((bb-join (new-bb))
 250            (bb-then (new-bb))
 251            (bb-else (new-bb)))
 252       (test-expression (subast1 ast) bb-then bb-else) ;; TODO invert ?
 253       (in bb-then)
 254       (statement (subast2 ast))
 255       (gen-goto bb-join)
 256       (in bb-else)
 257       (statement (subast3 ast))
 258       (gen-goto bb-join)
 259       (in bb-join)))
 260
 261   (define (while ast)
 262     (let* ((bb-cont (new-bb))
 263            (bb-exit (new-bb))
 264            (bb-body (new-bb)))
 265       (push-continue bb-cont)
 266       (push-break bb-exit)
 267       (gen-goto bb-cont)
 268       (in bb-cont)
 269       (test-expression (subast1 ast) bb-body bb-exit)
 270       (in bb-body)
 271       (statement (subast2 ast))
 272       (gen-goto bb-cont)
 273       (in bb-exit)
 274       (pop-continue)
 275       (pop-break)))
 276
 277   (define (do-while ast)
 278     (let* ((bb-body (new-bb))
 279            (bb-cont (new-bb))
 280            (bb-exit (new-bb)))
 281       (push-continue bb-cont)
 282       (push-break bb-exit)
 283       (in bb-body)
 284       (statement (subast1 ast))
 285       (in bb-cont)
 286       (test-expression (subast2 ast) bb-body bb-exit)
 287       (in bb-exit)
 288       (pop-continue)
 289       (pop-break)))
 290
 291   (define (for ast)
 292     (let* ((bb-loop (new-bb))
 293            (bb-body (new-bb))
 294            (bb-cont (new-bb))
 295            (bb-exit (new-bb)))
 296       (statement (subast1 ast))
 297       (gen-goto bb-loop)
 298       (push-continue bb-cont)
 299       (push-break bb-exit)
 300       (in bb-loop)
 301       (test-expression (subast2 ast) bb-body bb-exit)
 302       (in bb-body)
 303       (statement (subast4 ast))
 304       (gen-goto bb-cont)
 305       (in bb-cont)
 306       (expression (subast3 ast))
 307       (gen-goto bb-loop)
 308       (in bb-exit)
 309       (pop-continue)
 310       (pop-break)))
 311
 312   (define (switch ast)
 313     (let* ((var (subast1 ast))
 314            (case-list #f)
 315            (default #f)
 316            (decision-bb bb)
 317            (exit-bb (new-bb))
 318            (prev-bb decision-bb))
 319       (push-break exit-bb)
 320       (for-each (lambda (x) ; generate each case
 321                   (in (new-bb)) ; this bb will be given the name of the case
 322                   (add-succ decision-bb bb)
 323                   (if (null? (bb-succs prev-bb)) ; if the previous case didn't end in a break, fall through
 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           (add-succ prev-bb 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)) ;; TODO what about work duplication ?
 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              (add-succ bb bb-false) ; since we cons each new successor at the front, true has to be added last
 395              (add-succ bb bb-true)
 396              (emit (new-instr id byte1 byte2 #f)))
 397             ((byte-lit? byte1)
 398              (let ((id
 399                     (case id
 400                       ((x==y) 'x==y)
 401                       ((x<y) 'x>y)
 402                       ((x>y) 'x<y)
 403                       (else (error "invalid test")))))
 404                (add-succ bb bb-false)
 405                (add-succ bb bb-true)
 406                (emit (new-instr id byte2 byte1 #f))))
 407             (else
 408              (add-succ bb bb-false)
 409              (add-succ bb bb-true)
 410              (emit (new-instr id byte1 byte2 #f))))) ;; TODO doesn't change from if we had literals, at least not now
 411
 412     (define (test-value id value1 value2 bb-true bb-false)
 413       ;; note: for multi-byte values, only x==y works properly TODO fix it, will depend on byte order, is car the lsb or msb ?
 414       (let loop ((bytes1 (value-bytes value1))
 415                  (bytes2 (value-bytes value2)))
 416         ;; TODO won't work with values of different widths
 417         (let ((byte1 (car bytes1))
 418               (byte2 (car bytes2)))
 419           (if (null? (cdr bytes1))
 420               (test-byte id byte1 byte2 bb-true bb-false)
 421               (let ((bb-true2 (new-bb)))
 422                 (test-byte id byte1 byte2 bb-true2 bb-false)
 423                 (in bb-true2)
 424                 (loop (cdr bytes1) (cdr bytes2)))))))
 425
 426     (define (test-relation id x y bb-true bb-false)
 427       (cond ((and (literal? x) (not (literal? y))) ; literals must be in the last argument for code generation
 428              (test-relation (case id
 429                               ((x==y x!=y) id)
 430                               ((x<y) 'x>y)
 431                               ((x>y) 'x<y)
 432                               ((x<=y) 'x>=y)
 433                               ((x>=y) 'x<=y)
 434                               (else (error "relation error")))
 435                             y
 436                             x
 437                             bb-true
 438                             bb-false))
 439             ((assq id '((x!=y . x==y) (x<=y . x>y) (x>=y . x<y))) ; flip the destination blocks to have a simpler comparison
 440              =>
 441              (lambda (z) (test-relation (cdr z) x y bb-false bb-true)))
 442             (else
 443 ;;           ' ;; TODO use these special cases, but fall back on the current implementation for default
 444 ;;           (case id
 445 ;;             ((x==y)
 446 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 447 ;;                     (test-zero x bb-true bb-false))
 448 ;;                    ((literal? y)
 449 ;;                     (test-eq-lit x (literal-val y) bb-true bb-false))
 450 ;;                    (else
 451 ;;                     (error "unhandled case"))))
 452 ;;             ((x<y)
 453 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 454 ;;                     (test-negative x bb-true bb-false)) ;; TODO does this exist ?
 455 ;;                    (else
 456 ;;                     (error "unhandled case"))))
 457 ;;             ((x>y)
 458 ;;              (cond ((and (literal? y) (= (literal-val y) 0))
 459 ;;                     (test-positive x bb-true bb-false))
 460 ;;                    (else
 461 ;;                     (error "unhandled case"))))
 462 ;;             (else
 463 ;;              (error "unexpected operator")))
 464
 465              (let* ((value1 (expression x))
 466                     (value2 (expression y)))
 467                (test-value id value1 value2 bb-true bb-false))
 468              )))
 469
 470     (define (test-zero ast bb-true bb-false)
 471
 472       (define (default)
 473         (let ((type (expr-type ast))
 474               (value (expression ast)))
 475           (test-value 'x==y value (int->value 0 type) bb-false bb-true)))
 476
 477       (cond ((oper? ast)
 478              (let* ((op (oper-op ast))
 479                     (id (op-id op)))
 480                (case id
 481                  ((!x)
 482                   (test-zero (subast1 ast) bb-false bb-true))
 483                  ((x&&y)
 484                   (let ((bb-true2 (new-bb)))
 485                     (test-zero (subast1 ast) bb-true2 bb-false)
 486                     (in bb-true2)
 487                     (test-zero (subast2 ast) bb-true bb-false)))
 488                  ((|x\|\|y|)
 489                   (let ((bb-false2 (new-bb)))
 490                     (test-zero (subast1 ast) bb-true bb-false2)
 491                     (in bb-false2)
 492                     (test-zero (subast2 ast) bb-true bb-false)))
 493                  ((x==y x!=y x<y x>y x<=y x>=y)
 494                   (test-relation id
 495                                  (subast1 ast)
 496                                  (subast2 ast)
 497                                  bb-true
 498                                  bb-false))
 499                  (else (default)))))
 500             (else (default))))
 501
 502     (test-zero ast bb-true bb-false))
 503
 504   (define (expression ast)
 505     (let ((result
 506            (cond ((literal? ast)
 507                   (literal ast))
 508                  ((ref? ast)
 509                   (ref ast))
 510                  ((array-ref? ast)
 511                   (array-ref ast))
 512                  ((oper? ast)
 513                   (oper ast))
 514                  ((call? ast)
 515                   (call ast))
 516                  (else
 517                   (error "unexpected ast" ast)))))
 518       (do-delayed-post-incdec)
 519       result))
 520
 521   (define (literal ast)
 522     (let ((val (literal-val ast)))
 523       (int->value val (expr-type ast))))
 524
 525   (define (ref ast)
 526     (let* ((def-var (ref-def-var ast))
 527            (value (def-variable-value def-var)))
 528       value))
 529
 530   ;; calculates an address in an array by adding the base pointer and the offset
 531   ;; and puts the answer in FSR0 so that changes to INDF0 change the array
 532   ;; location
 533   (define (calculate-address ast)
 534     ;; if we have a special FSR variable, no need to calculate the address as
 535     ;; it is already in the register
 536     (if (not (memq (array-base-name ast) fsr-variables))
 537         (let ((base    (ref (array-ref-id ast)))
 538               (offset  (expression (array-ref-index ast)))
 539               (address (new-value (list (get-register FSR0L)
 540                                         (get-register FSR0H))))) ;; TODO actual addresses are 12 bits, not 16
 541           (add-sub 'x+y base offset address))))
 542
 543   (define (array-base-name ast)
 544     (def-id (ref-def-var (array-ref-id ast)))) ;; TODO if array wasn't a special case, would cover also dereference
 545
 546   (define (array-ref ast)
 547     (calculate-address ast)
 548     (new-value (list (get-register INDF0))))
 549
 550   (define (add-sub id value1 value2 result)
 551     (let loop ((bytes1 (value-bytes value1))
 552                (bytes2 (value-bytes value2))
 553                (bytes3 (value-bytes result))
 554                (ignore-carry-borrow? #t))
 555       (if (not (null? bytes3))
 556           (begin (emit
 557                   (new-instr (if ignore-carry-borrow?
 558                                  (case id ((x+y) 'add) ((x-y) 'sub))
 559                                  (case id ((x+y) 'addc) ((x-y) 'subb)))
 560                              (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 561                              (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 562                              (car bytes3)))
 563                  (loop (if (null? bytes1) bytes1 (cdr bytes1))
 564                        (if (null? bytes2) bytes2 (cdr bytes2))
 565                        (cdr bytes3)
 566                        #f)))))
 567
 568   (define (do-delayed-post-incdec)
 569     (if (not (null? delayed-post-incdec))
 570         (let* ((ast (car delayed-post-incdec))
 571                (type (expr-type ast))
 572                (op (oper-op ast))
 573                (id (op-id op)))
 574           (set! delayed-post-incdec (cdr delayed-post-incdec))
 575           (let ((x (subast1 ast)))
 576             (if (not (ref? x))
 577                 (error "assignment target must be a variable"))
 578             (let ((result (def-variable-value (ref-def-var x))))
 579               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 580                        result
 581                        (int->value 1 type)
 582                        result)))
 583           (do-delayed-post-incdec))))
 584
 585   (define (oper ast)
 586     (let* ((type (expr-type ast))
 587            (op (oper-op ast))
 588            (id (op-id op)))
 589       (let ((op (oper-op ast)))
 590         (if (op1? op)
 591             (begin
 592               (case id
 593                 ((-x)
 594                  (let ((x (subast1 ast)))
 595                    (let ((value-x (expression x)))
 596                      (let ((ext-value-x (extend value-x type)))
 597                        (let ((result (alloc-value type)))
 598                          (add-sub 'x-y
 599                                   (int->value 0 type)
 600                                   ext-value-x
 601                                   result)
 602                          result)))))
 603                 ((++x --x)
 604                  (let ((x (subast1 ast)))
 605                    (if (not (ref? x))
 606                        (error "assignment target must be a variable"))
 607                    (let ((result (def-variable-value (ref-def-var x))))
 608                      (add-sub (if (eq? id '++x) 'x+y 'x-y)
 609                               result
 610                               (int->value 1 type)
 611                               result)
 612                      result)))
 613                 ((x++ x--) ;; TODO not sure this works properly
 614                  (let ((x (subast1 ast)))
 615                    (if (not (ref? x))
 616                        (error "assignment target must be a variable"))
 617                    (let ((result (def-variable-value (ref-def-var x))))
 618                      (push-delayed-post-incdec ast)
 619                      result)))
 620                 ((*x)
 621                  (let ((x (subast1 ast)))
 622                    ;; TODO merge (calculate-address x)
 623                    ;; TODO even if we do not merge with the other array syntax, at least merge with the set for this syntax
 624                    ;; if it's a FSR variable, no adress to set
 625                    (if (not (and (ref? x)
 626                                  (memq (def-id (ref-def-var x)) ;; TODO use array-base-name once array-refs are not special cases anymore, only diff would be to use subast1 instead of array-ref-id
 627                                        fsr-variables)))
 628                        (begin (move-value (expression x)
 629                                           (new-value (list (get-register FSR0L)
 630                                                            (get-register FSR0H))))
 631                               (new-value (list (get-register INDF0))))
 632                        (if (eq? (def-id (ref-def-var x)) 'SIXPIC_FSR1) ;; TODO ugly, fix this
 633                            (new-value (list (get-register INDF1)))
 634                            (new-value (list (get-register INDF2)))))))
 635                 (else
 636                  (error "unary operation error" ast))))
 637             (begin
 638               (case id
 639                 ((x+y x-y x*y x/y x%y)
 640                  (let* ((x (subast1 ast))
 641                         (y (subast2 ast)))
 642                    (let* ((value-x (expression x))
 643                           (value-y (expression y)))
 644                      (let* ((ext-value-x (extend value-x type))
 645                             (ext-value-y (extend value-y type)))
 646                        (let ((result (alloc-value type)))
 647                          (cond ((or (eq? id 'x+y)
 648                                     (eq? id 'x-y))
 649                                 (add-sub id ext-value-x ext-value-y result))
 650                                ((eq? id 'x*y)
 651                                 (error "multiplication not implemented yet")) ;; TODO maybe just implement multiplication by powers of 2
 652                                ((eq? id 'x/y)
 653                                 (error "division not implemented yet")) ;; TODO implement these
 654                                ((eq? id 'x%y)
 655                                 (error "modulo not implemented yet")))
 656                          result)))))
 657                 ((x=y)
 658                  (let* ((x       (subast1 ast))
 659                         (y       (subast2 ast))
 660                         (value-y (expression y)))
 661                    (cond
 662                     ((ref? x)
 663                      (let ((ext-value-y (extend value-y type))) ;; TODO useless for now, what could it have been for ?
 664                        (let ((result (def-variable-value (ref-def-var x))))
 665                          (move-value value-y result)
 666                          result)))
 667                     ((array-ref? x)
 668                      (calculate-address x)
 669                      ;; this section of memory is a byte array, only the lsb
 670                      ;; of y is used
 671                      (move (car (value-bytes value-y)) (get-register INDF0)))
 672                     ((and (oper? x) (eq? (op-id (oper-op x)) '*x))
 673                      ;; TODO not always a ref
 674                      (let ((address (subast1 x)))
 675                        (if (not (and (ref? address)
 676                                      (memq (def-id (ref-def-var address))  ;; TODO use array-base-name once array-refs are not special cases anymore, only diff would be to use subast1 instead of array-ref-id
 677                                            fsr-variables)))
 678                            (begin (move-value (expression address)
 679                                               (new-value (list (get-register FSR0L)
 680                                                                (get-register FSR0H)))) ;; TODO merge with calculate-address ?
 681                                   (move (car (value-bytes value-y)) (get-register INDF0))) ;; TODO this pattern happens at lots of places, will the merging solve this ?
 682                            (if (eq? (def-id (ref-def-var address)) 'SIXPIC_FSR1) ;; TODO ugly, fix this
 683                                (move (car (value-bytes value-y)) (get-register INDF1))
 684                                (move (car (value-bytes value-y)) (get-register INDF2))))))
 685                     (else (error "assignment target must be a variable or an array slot")))))
 686                 (else
 687                  (error "binary operation error" ast))))))))
 688
 689   (define (call ast)
 690     (let ((def-proc (call-def-proc ast)))
 691       (for-each (lambda (ast def-var)
 692                   (let ((value (expression ast)))
 693                     (let ((ext-value (extend value (def-variable-type def-var))))
 694                       (move-value value (def-variable-value def-var)))))
 695                 (ast-subasts ast)
 696                 (def-procedure-params def-proc))
 697       (emit (new-call-instr def-proc))
 698       (let ((value (def-procedure-value def-proc)))
 699         (let ((result (alloc-value (def-procedure-type def-proc))))
 700           (move-value value result)
 701           result))))
 702
 703   ;; remplaces empty bbs by bbs with a single goto, to have a valid CFG for optimizations
 704   (define (fill-empty-bbs)
 705     (for-each (lambda (x) (if (null? (bb-rev-instrs x))
 706                                (begin (in x)
 707                                       (emit (new-instr 'goto #f #f #f)))))
 708               (cfg-bbs cfg)))
 709
 710   (in (new-bb))
 711   (program ast)
 712   (fill-empty-bbs)
 713   cfg)
 714
 715 (define (print-cfg-bbs cfg)
 716   (for-each (lambda (bb)
 717               (pp (list "BB:" (bb-label-num bb)
 718                         "SUCCS" (map bb-label-num (bb-succs bb))
 719                         "PREDS" (map bb-label-num (bb-preds bb))
 720                         (cond ((null? (bb-rev-instrs bb)) "EMPTY")
 721                               ((and (null? (cdr (bb-rev-instrs bb)))
 722                                      (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
 723                               (else #f)))))
 724             (cfg-bbs cfg)))