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))) ;; TODO might cause problems eventually
 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))) ;; TODO once != works, use it and flip the target bbs TODO having != here breaks it, no idea why, == with swapped detinations works, though
 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 adress 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-adress ast)
 534     (let ((base    (ref (array-ref-id ast)))
 535           (offset  (expression (array-ref-index ast)))
 536           (adress  (alloc-value 'int16))) ;; TODO actual addresses are 12 bits, not 16
 537       (add-sub 'x+y base offset adress)
 538       (move (car  (value-bytes adress)) (get-register FSR0L)) ; lsb
 539       (move (cadr (value-bytes adress)) (get-register FSR0H)))) ; msb TODO use only 4 bits
 540
 541   (define (array-base-name ast)
 542     (def-id (ref-def-var (array-ref-id ast))))
 543
 544   (define (array-ref ast)
 545     ;; this section of memory is a byte array, only the lsb
 546     ;; of y is used
 547     (let ((base-name (array-base-name ast)))
 548       ;; if we have a special FSR variable, no need to calculate the address
 549       ;; as it is already in the register
 550       (if (not (memq base-name fsr-variables))
 551           (calculate-adress ast)))
 552     (new-value (list (get-register INDF0))))
 553
 554   (define (add-sub id value1 value2 result)
 555     (let loop ((bytes1 (value-bytes value1))
 556                (bytes2 (value-bytes value2))
 557                (bytes3 (value-bytes result))
 558                (ignore-carry-borrow? #t))
 559       (if (not (null? bytes3))
 560           (begin (emit
 561                   (new-instr (if ignore-carry-borrow?
 562                                  (case id ((x+y) 'add) ((x-y) 'sub))
 563                                  (case id ((x+y) 'addc) ((x-y) 'subb)))
 564                              (if (null? bytes1) (new-byte-lit 0) (car bytes1))
 565                              (if (null? bytes2) (new-byte-lit 0) (car bytes2))
 566                              (car bytes3)))
 567                  (loop (if (null? bytes1) bytes1 (cdr bytes1))
 568                        (if (null? bytes2) bytes2 (cdr bytes2))
 569                        (cdr bytes3)
 570                        #f)))))
 571
 572   (define (do-delayed-post-incdec)
 573     (if (not (null? delayed-post-incdec))
 574         (let* ((ast (car delayed-post-incdec))
 575                (type (expr-type ast))
 576                (op (oper-op ast))
 577                (id (op-id op)))
 578           (set! delayed-post-incdec (cdr delayed-post-incdec))
 579           (let ((x (subast1 ast)))
 580             (if (not (ref? x))
 581                 (error "assignment target must be a variable"))
 582             (let ((result (def-variable-value (ref-def-var x))))
 583               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 584                        result
 585                        (int->value 1 type)
 586                        result)))
 587           (do-delayed-post-incdec))))
 588
 589   (define (oper ast)
 590     (let* ((type (expr-type ast))
 591            (op (oper-op ast))
 592            (id (op-id op)))
 593       (let ((op (oper-op ast)))
 594         (if (op1? op)
 595             (begin
 596               (case id
 597                 ((-x)
 598                  (let ((x (subast1 ast)))
 599                    (let ((value-x (expression x)))
 600                      (let ((ext-value-x (extend value-x type)))
 601                        (let ((result (alloc-value type)))
 602                          (add-sub 'x-y
 603                                   (int->value 0 type)
 604                                   ext-value-x
 605                                   result)
 606                          result)))))
 607                 ((++x --x)
 608                  (let ((x (subast1 ast)))
 609                    (if (not (ref? x))
 610                        (error "assignment target must be a variable"))
 611                    (let ((result (def-variable-value (ref-def-var x))))
 612                      (add-sub (if (eq? id '++x) 'x+y 'x-y)
 613                               result
 614                               (int->value 1 type)
 615                               result)
 616                      result)))
 617                 ((x++ x--)
 618                  (let ((x (subast1 ast)))
 619                    (if (not (ref? x))
 620                        (error "assignment target must be a variable"))
 621                    (let ((result (def-variable-value (ref-def-var x))))
 622                      (push-delayed-post-incdec ast)
 623                      result)))
 624                 (else
 625                  (error "unary operation error" ast))))
 626             (begin
 627               (case id
 628                 ((x+y x-y x*y x/y x%y)
 629                  (let* ((x (subast1 ast))
 630                         (y (subast2 ast)))
 631                    (let* ((value-x (expression x))
 632                           (value-y (expression y)))
 633                      (let* ((ext-value-x (extend value-x type))
 634                             (ext-value-y (extend value-y type)))
 635                        (let ((result (alloc-value type)))
 636                          (cond ((or (eq? id 'x+y)
 637                                     (eq? id 'x-y))
 638                                 (add-sub id ext-value-x ext-value-y result))
 639                                ((eq? id 'x*y)
 640                                 (error "multiplication not implemented yet")) ;; TODO maybe just implement multiplication by powers of 2
 641                                ((eq? id 'x/y)
 642                                 (error "division not implemented yet")) ;; TODO implement these
 643                                ((eq? id 'x%y)
 644                                 (error "modulo not implemented yet")))
 645                          result)))))
 646                 ((x=y)
 647                  (let* ((x (subast1 ast))
 648                         (y (subast2 ast)))
 649                    (cond
 650                     ((ref? x)
 651                      (let ((value-y (expression y)))
 652                        (let ((ext-value-y (extend value-y type)))
 653                          (let ((result (def-variable-value (ref-def-var x))))
 654                            (move-value value-y result)
 655                            result))))
 656                     ((array-ref? x)
 657                      (let ((value-y   (expression y))
 658                            (base-name (array-base-name x)))
 659                        (pp (list ID: base-name))
 660                        ;; if we have a special FSR variable, no need to calculate the address
 661                        ;; as it is already in the register
 662                        (if (not (memq base-name fsr-variables))
 663                            (calculate-adress x))
 664                        ;; this section of memory is a byte array, only the lsb
 665                        ;; of y is used
 666                        (move (car (value-bytes value-y)) (get-register INDF0))))
 667                     (else (error "assignment target must be a variable or an array slot")))))
 668                 (else
 669                  (error "binary operation error" ast))))))))
 670
 671   (define (call ast)
 672     (let ((def-proc (call-def-proc ast)))
 673       (for-each (lambda (ast def-var)
 674                   (let ((value (expression ast)))
 675                     (let ((ext-value (extend value (def-variable-type def-var))))
 676                       (move-value value (def-variable-value def-var)))))
 677                 (ast-subasts ast)
 678                 (def-procedure-params def-proc))
 679       (emit (new-call-instr def-proc))
 680       (let ((value (def-procedure-value def-proc)))
 681         (let ((result (alloc-value (def-procedure-type def-proc))))
 682           (move-value value result)
 683           result))))
 684
 685   ;; remplaces empty bbs by bbs with a single goto, to have a valid CFG for optimizations
 686   (define (fill-empty-bbs)
 687     (for-each (lambda (x) (if (null? (bb-rev-instrs x))
 688                                (begin (in x)
 689                                       (emit (new-instr 'goto #f #f #f)))))
 690               (cfg-bbs cfg)))
 691
 692   (in (new-bb))
 693   (program ast)
 694   (fill-empty-bbs)
 695   cfg)
 696
 697 (define (print-cfg-bbs cfg)
 698   (for-each (lambda (bb)
 699               (pp (list "BB:" (bb-label-num bb)
 700                         "SUCCS" (map bb-label-num (bb-succs bb))
 701                         "PREDS" (map bb-label-num (bb-preds bb))
 702                         (cond ((null? (bb-rev-instrs bb)) "EMPTY")
 703                               ((and (null? (cdr (bb-rev-instrs bb)))
 704                                      (eq? (instr-id (car (bb-rev-instrs bb))) 'goto)) "SINGLE GOTO")
 705                               (else #f)))))
 706             (cfg-bbs cfg)))