cfg.scm

   1 ;;; generation of control flow graph
   2
   3 (define-type cfg
   4   bbs
   5   next-label-num
   6 )
   7
   8 (define (new-cfg)
   9   (make-cfg '() 0))
  10
  11 (define-type bb
  12   label-num
  13   label
  14   rev-instrs
  15   unprintable:
  16   preds
  17   succs
  18   live-before
  19 )
  20
  21 (define-type instr
  22   extender: define-type-of-instr
  23   (live-before #;unprintable:)
  24   (live-after #;unprintable:)
  25   (hash unprintable:)
  26   id
  27   src1
  28   src2
  29   dst
  30 )
  31
  32 (define-type-of-instr call-instr
  33   unprintable:
  34   def-proc
  35 )
  36
  37 (define-type-of-instr return-instr
  38   unprintable:
  39   def-proc
  40 )
  41
  42 (define (new-instr id src1 src2 dst)
  43   (make-instr '() '() #f id src1 src2 dst))
  44
  45 (define (new-call-instr def-proc)
  46   (make-call-instr '() '() #f 'call #f #f #f def-proc))
  47
  48 (define (new-return-instr def-proc)
  49   (make-return-instr '() '() #f 'return #f #f #f def-proc))
  50
  51 (define (add-bb cfg)
  52   (let* ((label-num (cfg-next-label-num cfg))
  53          (bb (make-bb label-num #f '() '() '() '())))
  54     (bb-label-set!
  55      bb
  56      (asm-make-label
  57       (string->symbol
  58        (string-append "$"
  59                       (number->string label-num)))))
  60     (cfg-bbs-set! cfg (cons bb (cfg-bbs cfg)))
  61     (cfg-next-label-num-set! cfg (+ 1 (cfg-next-label-num cfg)))
  62     bb))
  63
  64 (define (add-instr bb instr)
  65   (let ((rev-instrs (bb-rev-instrs bb)))
  66     (bb-rev-instrs-set! bb (cons instr rev-instrs))))
  67
  68 (define (add-succ bb succ)
  69   (bb-succs-set! bb (cons succ (bb-succs bb)))
  70   (bb-preds-set! succ (cons bb (bb-preds succ))))
  71
  72 (define (generate-cfg ast)
  73
  74   (define cfg (new-cfg))
  75
  76   (define bb #f) ; current bb
  77
  78   (define (in x)
  79     (set! bb x))
  80
  81   (define (new-bb)
  82     (add-bb cfg))
  83
  84   (define (emit instr)
  85     (add-instr bb instr))
  86
  87   (define current-def-proc #f)
  88   (define break-stack '())
  89   (define continue-stack '())
  90   (define delayed-post-incdec '())
  91
  92   (define (push-break x)
  93     (set! break-stack (cons x break-stack)))
  94
  95   (define (pop-break)
  96     (set! break-stack (cdr break-stack)))
  97
  98   (define (push-continue x)
  99     (set! continue-stack (cons x continue-stack)))
 100
 101   (define (pop-continue)
 102     (set! continue-stack (cdr continue-stack)))
 103
 104   (define (push-delayed-post-incdec x)
 105     (set! delayed-post-incdec (cons x delayed-post-incdec)))
 106
 107   (define (program ast)
 108     (let loop ((asts (ast-subasts ast)))
 109       (if (not (null? asts))
 110           (let ((ast (car asts)))
 111             (if (null? (cdr asts))
 112                 (let ((value (expression ast)))
 113                   (return-with-no-new-bb value))
 114                 (begin
 115                   (toplevel ast)
 116                   (loop (cdr asts))))))))
 117
 118   (define (toplevel ast)
 119     (cond ((def-variable? ast)
 120            (def-variable ast))
 121           ((def-procedure? ast)
 122            (def-procedure ast))
 123           (else
 124            (statement ast))))
 125
 126   (define (def-variable ast)
 127     (let ((subasts (ast-subasts ast)))
 128       (if (not (null? subasts))
 129           (let ((value (expression (subast1 ast))))
 130             (let ((ext-value (extend value (def-variable-type ast))))
 131               (move-value value (def-variable-value ast)))))))
 132
 133   (define (def-procedure ast)
 134     (let ((old-bb bb)
 135           (entry (new-bb)))
 136       (def-procedure-entry-set! ast entry)
 137       (set! current-def-proc ast)
 138       (in entry)
 139       (for-each statement (ast-subasts ast))
 140       (return-with-no-new-bb ast)
 141       (set! current-def-proc #f)
 142       (in old-bb)))
 143
 144   (define (statement ast) ;; TODO should labels go into statements or expressions ?
 145     (cond ((def-variable? ast)
 146            (def-variable ast))
 147           ((block? ast)
 148            (block ast))
 149           ((return? ast)
 150            (return ast))
 151           ((if? ast)
 152            (if (null? (cddr (ast-subasts ast)))
 153                (if1 ast)
 154                (if2 ast)))
 155           ((while? ast)
 156            (while ast))
 157           ((do-while? ast)
 158            (do-while ast))
 159           ((for? ast)
 160            (for ast))
 161           (else
 162            (expression ast))))
 163
 164   (define (block ast)
 165     (for-each statement (ast-subasts ast)))
 166
 167   (define (move from to)
 168     (emit (new-instr 'move from #f to)))
 169
 170   (define (move-value from to)
 171     (for-each move
 172               (value-bytes from)
 173               (value-bytes to)))
 174
 175   (define (return-with-no-new-bb def-proc)
 176     (emit (new-return-instr def-proc)))
 177
 178   (define (return ast)
 179     (if (null? (ast-subasts ast))
 180         (return-with-no-new-bb current-def-proc)
 181         (let ((value (expression (subast1 ast))))
 182           (let ((ext-value (extend value (def-procedure-type current-def-proc))))
 183             (move-value value (def-procedure-value current-def-proc))
 184             (return-with-no-new-bb current-def-proc))))
 185     (in (new-bb)))
 186
 187   (define (if1 ast)
 188     (let* ((bb-join (new-bb))
 189            (bb-then (new-bb)))
 190       (test-expression (subast1 ast) bb-then bb-join)
 191       (in bb-then)
 192       (statement (subast2 ast))
 193       (in bb-join)))
 194
 195   (define (if2 ast)
 196     (let* ((bb-join (new-bb))
 197            (bb-then (new-bb))
 198            (bb-else (new-bb)))
 199       (test-expression (subast1 ast) bb-then bb-else)
 200       (in bb-then)
 201       (statement (subast2 ast))
 202       (goto bb-join)
 203       (in bb-else)
 204       (statement (subast3 ast))
 205       (goto bb-join)
 206       (in bb-join)))
 207
 208   (define (while ast)
 209     (let* ((bb-cont (new-bb))
 210            (bb-exit (new-bb))
 211            (bb-body (new-bb)))
 212       (push-continue bb-cont)
 213       (push-break bb-exit)
 214       (goto bb-cont)
 215       (in bb-cont)
 216       (test-expression (subast1 ast) bb-body bb-exit)
 217       (in bb-body)
 218       (statement (subast2 ast))
 219       (goto bb-cont)
 220       (in bb-exit)
 221       (pop-continue)
 222       (pop-break)))
 223
 224   (define (do-while ast)
 225     (let* ((bb-body (new-bb))
 226            (bb-cont (new-bb))
 227            (bb-exit (new-bb)))
 228       (push-continue bb-cont)
 229       (push-break bb-exit)
 230       (in bb-body)
 231       (statement (subast1 ast))
 232       (in bb-cont)
 233       (test-expression (subast2 ast) bb-body bb-exit)
 234       (in bb-exit)
 235       (pop-continue)
 236       (pop-break)))
 237
 238   (define (for ast)
 239     (let* ((bb-loop (new-bb))
 240            (bb-body (new-bb))
 241            (bb-cont (new-bb))
 242            (bb-exit (new-bb)))
 243       (statement (subast1 ast))
 244       (goto bb-loop)
 245       (push-continue bb-cont)
 246       (push-break bb-exit)
 247       (in bb-loop)
 248       (test-expression (subast2 ast) bb-body bb-exit)
 249       (in bb-body)
 250       (statement (subast4 ast))
 251       (goto bb-cont)
 252       (in bb-cont)
 253       (expression (subast3 ast))
 254       (goto bb-loop)
 255       (in bb-exit)
 256       (pop-continue)
 257       (pop-break)))
 258
 259   (define (goto dest)
 260     (add-succ bb dest)
 261     (emit (new-instr 'goto #f #f #f)))
 262
 263   (define (test-expression ast bb-true bb-false)
 264
 265     (define (test-lit id x y)
 266       ((case id
 267          ((x==y) =)
 268          ((x<y) <)
 269          ((x>y) >)
 270          (else (error "...")))
 271        x
 272        y))
 273
 274     (define (test-byte id byte1 byte2 bb-true bb-false)
 275       (cond ((and (byte-lit? byte1) (byte-lit? byte2))
 276              (if (test-lit id (byte-lit-val byte1) (byte-lit-val byte2))
 277                  (goto bb-true)
 278                  (goto bb-false)))
 279             ((byte-lit? byte2)
 280              (add-succ bb bb-true)
 281              (add-succ bb bb-false)
 282              (emit (new-instr id byte1 byte2 #f)))
 283             ((byte-lit? byte1)
 284              (let ((id
 285                     (case id
 286                       ((x==y) 'x==y)
 287                       ((x<y) 'x>y)
 288                       ((x>y) 'x<y)
 289                       (else (error "...")))))
 290                (add-succ bb bb-true)
 291                (add-succ bb bb-false)
 292                (emit (new-instr id byte2 byte1 #f))))
 293             (else
 294              (add-succ bb bb-true)
 295              (add-succ bb bb-false)
 296              (emit (new-instr id byte1 byte2 #f)))))
 297
 298     (define (test-value id value1 value2 bb-true bb-false)
 299       ; note: for multi-byte values, only x==y works properly
 300       (let* ((bytes1 (value-bytes value1))
 301              (bytes2 (value-bytes value2)))
 302         (let loop ((bytes1 bytes1) (bytes2 bytes2))
 303           (let ((byte1 (car bytes1))
 304                 (byte2 (car bytes2)))
 305             (if (null? (cdr bytes1))
 306                 (test-byte id byte1 byte2 bb-true bb-false)
 307                 (let ((bb-true2 (new-bb)))
 308                   (test-byte id byte1 byte2 bb-true2 bb-false)
 309                   (in bb-true2)
 310                   (loop (cdr bytes1) (cdr bytes2))))))))
 311
 312     (define (test-relation id x y bb-true bb-false)
 313       (cond ((and (literal? x) (not (literal? y)))
 314              (compare (case id
 315                         ((x==y x!=y) id)
 316                         ((x<y) 'x>y)
 317                         ((x>y) 'x<y)
 318                         ((x<=y) 'x>=y)
 319                         ((x>=y) 'x<=y)
 320                         (else (error "relation error")))
 321                       y
 322                       x
 323                       bb-true
 324                       bb-false))
 325             ((assq id '((x!=y . x==y) (x<=y . x>y) (x>=y . x<y)))
 326              =>
 327              (lambda (z) (compare (cdr z) x y bb-false bb-true)))
 328             (else
 329 '
 330              (case id
 331                ((x==y)
 332                 (cond ((and (literal? y) (= (literal-val y) 0))
 333                        (test-zero x bb-true bb-false))
 334                       ((literal? y)
 335                        (test-eq-lit x (literal-val y) bb-true bb-false))
 336                       (else
 337                        (error "unhandled case"))))
 338                ((x<y)
 339                 (cond ((and (literal? y) (= (literal-val y) 0))
 340                        (test-negative x bb-true bb-false))
 341                       (else
 342                        (error "unhandled case"))))
 343                ((x>y)
 344                 (cond ((and (literal? y) (= (literal-val y) 0))
 345                        (test-positive x bb-true bb-false))
 346                       (else
 347                        (error "unhandled case"))))
 348                (else
 349                 (error "unexpected operator")))
 350
 351              (let* ((value1 (expression x))
 352                     (value2 (expression y)))
 353                (test-value id value1 value2 bb-true bb-false))
 354 )))
 355
 356     (define (test-zero ast bb-true bb-false)
 357
 358       (define (default)
 359         (let ((type (expr-type ast))
 360               (value (expression ast)))
 361           (test-equal value (int->value 0 type) bb-true bb-false)))
 362
 363       (cond ((oper? ast)
 364              (let* ((op (oper-op ast))
 365                     (id (op-id op)))
 366                (case id
 367                  ((!x)
 368                   (test-zero (subast1 ast) bb-false bb-true))
 369                  ((x&&y)
 370                   ...)
 371                  ((|x\|\|y|)
 372                   ...)
 373                  (else
 374                   (test-relation id
 375                                  (subast1 ast)
 376                                  (subast2 ast)
 377                                  bb-true
 378                                  bb-false)))))
 379             (else
 380              (default))))
 381
 382     (test-zero ast bb-false bb-true))
 383
 384   (define (expression ast)
 385     (let ((result
 386            (cond ((literal? ast)
 387                   (literal ast))
 388                  ((ref? ast)
 389                   (ref ast))
 390                  ((oper? ast)
 391                   (oper ast))
 392                  ((call? ast)
 393                   (call ast))
 394                  (else
 395                   (error "unexpected ast" ast)))))
 396       (do-delayed-post-incdec)
 397       result))
 398
 399   (define (literal ast)
 400     (let ((val (literal-val ast)))
 401       (int->value val (expr-type ast))))
 402
 403   (define (ref ast)
 404     (let* ((def-var (ref-def-var ast))
 405            (value (def-variable-value def-var)))
 406       value))
 407
 408   (define (add-sub id value1 value2 result)
 409     (let loop ((bytes1 (value-bytes value1))
 410                (bytes2 (value-bytes value2))
 411                (bytes3 (value-bytes result))
 412                (ignore-carry-borrow? #t))
 413       (if (not (null? bytes1))
 414           (let ((byte1 (car bytes1))
 415                 (byte2 (car bytes2))
 416                 (byte3 (car bytes3)))
 417             (emit
 418              (new-instr (if ignore-carry-borrow?
 419                             (case id ((x+y) 'add) ((x-y) 'sub))
 420                             (case id ((x+y) 'addc) ((x-y) 'subb)))
 421                         byte1
 422                         byte2
 423                         byte3))
 424             (loop (cdr bytes1)
 425                   (cdr bytes2)
 426                   (cdr bytes3)
 427                   #f)))))
 428
 429   (define (do-delayed-post-incdec)
 430     (if (not (null? delayed-post-incdec))
 431         (let* ((ast (car delayed-post-incdec))
 432                (type (expr-type ast))
 433                (op (oper-op ast))
 434                (id (op-id op)))
 435           (set! delayed-post-incdec (cdr delayed-post-incdec))
 436           (let ((x (subast1 ast)))
 437             (if (not (ref? x))
 438                 (error "assignment target must be a variable"))
 439             (let ((result (def-variable-value (ref-def-var x))))
 440               (add-sub (if (eq? id 'x++) 'x+y 'x-y)
 441                        result
 442                        (int->value 1 type)
 443                        result)))
 444           (do-delayed-post-incdec))))
 445
 446   (define (oper ast)
 447     (let* ((type (expr-type ast))
 448            (op (oper-op ast))
 449            (id (op-id op)))
 450       (let ((op (oper-op ast)))
 451         (if (op1? op)
 452             (begin
 453               (case id
 454                 ((-x)
 455                  (let ((x (subast1 ast)))
 456                    (let ((value-x (expression x)))
 457                      (let ((ext-value-x (extend value-x type)))
 458                        (let ((result (alloc-value type)))
 459                          (add-sub 'x-y
 460                                   (int->value 0 type)
 461                                   ext-value-x
 462                                   result)
 463                          result)))))
 464                 ((++x --x)
 465                  (let ((x (subast1 ast)))
 466                    (if (not (ref? x))
 467                        (error "assignment target must be a variable"))
 468                    (let ((result (def-variable-value (ref-def-var x))))
 469                      (add-sub (if (eq? id '++x) 'x+y 'x-y)
 470                               result
 471                               (int->value 1 type)
 472                               result)
 473                      result)))
 474                 ((x++ x--)
 475                  (let ((x (subast1 ast)))
 476                    (if (not (ref? x))
 477                        (error "assignment target must be a variable"))
 478                    (let ((result (def-variable-value (ref-def-var x))))
 479                      (push-delayed-post-incdec ast)
 480                      result)))
 481                 (else
 482                  (error "unary operation error" ast))))
 483             (begin
 484               (case id
 485                 ((x+y x-y x*y x/y x%y)
 486                  (let* ((x (subast1 ast))
 487                         (y (subast2 ast)))
 488                    (let* ((value-x (expression x))
 489                           (value-y (expression y)))
 490                      (let* ((ext-value-x (extend value-x type))
 491                             (ext-value-y (extend value-y type)))
 492                        (let ((result (alloc-value type)))
 493                          (if (or (eq? id 'x+y)
 494                                  (eq? id 'x-y))
 495                              (add-sub id ext-value-x ext-value-y result)
 496                              (error "..."))
 497                          result)))))
 498                 ((x=y)
 499                  (let* ((x (subast1 ast))
 500                         (y (subast2 ast)))
 501                    (if (not (ref? x))
 502                        (error "assignment target must be a variable"))
 503                    (let ((value-y (expression y)))
 504                      (let ((ext-value-y (extend value-y type)))
 505                        (let ((result (def-variable-value (ref-def-var x))))
 506                          (move-value value-y result)
 507                          result)))))
 508                 (else
 509                  (error "binary operation error" ast))))))))
 510
 511   (define (call ast)
 512     (let ((def-proc (call-def-proc ast)))
 513       (for-each (lambda (ast def-var)
 514                   (let ((value (expression ast)))
 515                     (let ((ext-value (extend value (def-variable-type def-var))))
 516                       (move-value value (def-variable-value def-var)))))
 517                 (ast-subasts ast)
 518                 (def-procedure-params def-proc))
 519       (emit (new-call-instr def-proc))
 520       (let ((value (def-procedure-value def-proc)))
 521         (let ((result (alloc-value (def-procedure-type def-proc))))
 522           (move-value value result)
 523           result))))
 524
 525   (in (new-bb))
 526   (program ast)
 527   cfg)