code-generation.scm

   1 ;; address after which memory is allocated by the user, therefore not used for
   2 ;; register allocation
   3 ;; in programs, located in the SIXPIC_MEMORY_DIVIDE variable
   4 (define memory-divide #f)
   5
   6 (define (interference-graph cfg)
   7
   8   (define all-live (new-empty-set))
   9
  10   (define (interfere x y)
  11     (if (not (set-member? (byte-cell-interferes-with y) x))
  12         (begin
  13           (byte-cell-interferes-with-set!
  14            x
  15            (union (new-set y) (byte-cell-interferes-with x)))
  16           (byte-cell-interferes-with-set!
  17            y
  18            (union (new-set x) (byte-cell-interferes-with y))))))
  19
  20   (define (interfere-pairwise live)
  21     (set! all-live (union all-live live))
  22     (table-for-each (lambda (x val1)
  23                       (table-for-each (lambda (y val2)
  24                                         (if (and val1 val2 (not (eq? x y)))
  25                                             (interfere x y)))
  26                                       live))
  27                     live))
  28
  29   (define (instr-interference-graph instr)
  30     (let ((dst (instr-dst instr)))
  31       (if (byte-cell? dst)
  32           (let ((src1 (instr-src1 instr))
  33                 (src2 (instr-src2 instr)))
  34             (if (byte-cell? src1)
  35                 (begin
  36                   (byte-cell-coalesceable-with-set!
  37                    dst
  38                    (union (byte-cell-coalesceable-with dst)
  39                           (new-set src1)))
  40                   (byte-cell-coalesceable-with-set!
  41                    src1
  42                    (union (byte-cell-coalesceable-with src1)
  43                           (new-set dst)))))
  44             (if (byte-cell? src2)
  45                 (begin
  46                   (byte-cell-coalesceable-with-set!
  47                    dst
  48                    (union (byte-cell-coalesceable-with dst)
  49                           (new-set src2)))
  50                   (byte-cell-coalesceable-with-set!
  51                    src2
  52                    (union (byte-cell-coalesceable-with src2)
  53                           (new-set dst))))))))
  54     (let ((live-before (instr-live-before instr)))
  55       (interfere-pairwise live-before)))
  56
  57   (define (bb-interference-graph bb)
  58     (for-each instr-interference-graph (bb-rev-instrs bb)))
  59
  60   (analyze-liveness cfg)
  61
  62   (for-each bb-interference-graph (cfg-bbs cfg))
  63
  64   all-live)
  65
  66 (define (allocate-registers cfg)
  67   (let ((all-live (interference-graph cfg)))
  68
  69     (define (color byte-cell)
  70       (let ((coalesce-candidates ; TODO right now, no coalescing is done
  71              (set-filter byte-cell-adr
  72                          (diff (byte-cell-coalesceable-with byte-cell)
  73                                (byte-cell-interferes-with byte-cell)))))
  74         '
  75         (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
  76                   coalesce-candidates
  77 ;                  interferes-with: (byte-cell-interferes-with byte-cell)
  78 ;                  coalesceable-with: (byte-cell-coalesceable-with byte-cell)
  79                   ))
  80
  81         (if #f #;(not (null? coalesce-candidates))
  82             (let ((adr (byte-cell-adr (car (set->list coalesce-candidates))))) ;; TODO have as a set all along
  83               (byte-cell-adr-set! byte-cell adr))
  84             (let ((neighbours (byte-cell-interferes-with byte-cell)))
  85               (let loop1 ((adr 0))
  86                 (if (and memory-divide ; the user wants his own zone
  87                          (>= adr memory-divide)) ; and we'd use it
  88                     (error "register allocation would cross the memory divide") ;; TODO fallback ?
  89                     (let loop2 ((lst (set->list neighbours))) ;; TODO FOO cop out...
  90                       (if (null? lst)
  91                           (byte-cell-adr-set! byte-cell adr)
  92                           (let ((x (car lst)))
  93                             (if (= adr (byte-cell-adr x))
  94                                 (loop1 (+ adr 1))
  95                                 (loop2 (cdr lst))))))))))))
  96
  97     (define (delete byte-cell1 neighbours)
  98       (table-for-each (lambda (byte-cell2 val)
  99                         (if val
 100                             (let ((lst (byte-cell-interferes-with byte-cell2)))
 101                               (byte-cell-interferes-with-set!
 102                                byte-cell2
 103                                (diff lst (new-set byte-cell1))))))
 104                       neighbours))
 105
 106     (define (undelete byte-cell1 neighbours)
 107       (table-for-each (lambda (byte-cell2 val)
 108                         (if val
 109                             (let ((lst (byte-cell-interferes-with byte-cell2)))
 110                               (byte-cell-interferes-with-set!
 111                                byte-cell2
 112                                (union (new-set byte-cell1) lst)))))
 113                       neighbours))
 114
 115     (define (find-min-neighbours graph)
 116       (let loop ((lst graph) (m #f) (byte-cell #f))
 117         (if (null? lst)
 118             byte-cell
 119             (let* ((x (car lst))
 120                    (n (table-length (byte-cell-interferes-with x))))
 121               (if (or (not m) (< n m))
 122                   (loop (cdr lst) n x)
 123                   (loop (cdr lst) m byte-cell))))))
 124
 125     (define (alloc-reg graph)
 126       (if (not (null? graph))
 127           (let* ((byte-cell (find-min-neighbours graph))
 128                  (neighbours (byte-cell-interferes-with byte-cell)))
 129             (let ((new-graph (remove byte-cell graph)))
 130               (delete byte-cell neighbours)
 131               (alloc-reg new-graph)
 132               (undelete byte-cell neighbours))
 133             (if (not (byte-cell-adr byte-cell))
 134                 (color byte-cell)))))
 135
 136     (alloc-reg (set->list all-live)))) ;; TODO FOO BAD cop out, convert find-min-neighbors et alloc-reg to used tables
 137
 138
 139 (define (linearize-and-cleanup cfg)
 140
 141   (define bbs-vector (cfg->vector cfg))
 142
 143   (define todo '())
 144
 145   (define (add-todo bb)
 146     (set! todo (cons bb todo)))
 147
 148   (define rev-code '())
 149
 150   (define (emit instr)
 151     (set! rev-code (cons instr rev-code)))
 152
 153   (define (movlw val)
 154     (emit (list 'movlw val)))
 155   (define (movwf adr)
 156     (emit (list 'movwf adr)))
 157   (define (movfw adr)
 158     (emit (list 'movfw adr)))
 159   (define (movff src dst)
 160     (emit (list 'movff src dst)))
 161
 162   (define (clrf adr)
 163     (emit (list 'clrf adr)))
 164   (define (setf adr)
 165     (emit (list 'setf adr)))
 166
 167   (define (incf adr)
 168     (emit (list 'incf adr)))
 169   (define (decf adr)
 170     (emit (list 'decf adr)))
 171
 172   (define (addwf adr)
 173     (emit (list 'addwf adr)))
 174   (define (addwfc adr)
 175     (emit (list 'addwfc adr)))
 176
 177   (define (subwf adr)
 178     (emit (list 'subwf adr)))
 179   (define (subwfb adr)
 180     (emit (list 'subwfb adr)))
 181
 182   (define (mullw adr)
 183     (emit (list 'mullw adr)))
 184   (define (mulwf adr)
 185     (emit (list 'mulwf adr)))
 186
 187   (define (andwf adr)
 188     (emit (list 'andwf adr)))
 189   (define (iorwf adr)
 190     (emit (list 'iorwf adr)))
 191   (define (xorwf adr)
 192     (emit (list 'xorwf adr)))
 193
 194   (define (rlcf adr)
 195     (emit (list 'rlcf adr)))
 196   (define (rrcf adr)
 197     (emit (list 'rrcf adr)))
 198
 199   (define (bcf adr bit)
 200     (emit (list 'bcf adr bit)))
 201   (define (bsf adr bit)
 202     (emit (list 'bsf adr bit)))
 203   (define (btg adr bit)
 204     (emit (list 'btg adr bit)))
 205
 206   (define (comf adr)
 207     (emit (list 'comf adr)))
 208
 209   (define (cpfseq adr)
 210     (emit (list 'cpfseq adr)))
 211   (define (cpfslt adr)
 212     (emit (list 'cpfslt adr)))
 213   (define (cpfsgt adr)
 214     (emit (list 'cpfsgt adr)))
 215
 216   (define (bra label)
 217     (emit (list 'bra label)))
 218
 219   (define (rcall label)
 220     (emit (list 'rcall label)))
 221
 222   (define (return)
 223     (if (and #f (and (not (null? rev-code))
 224                      (eq? (caar rev-code) 'rcall)))
 225         (let ((label (cadar rev-code)))
 226           (set! rev-code (cdr rev-code))
 227           (bra label))
 228         (emit (list 'return))))
 229
 230   (define (label lab)
 231     (if (and #f (and (not (null? rev-code))
 232              (eq? (caar rev-code) 'bra)
 233              (eq? (cadar rev-code) lab)))
 234         (begin
 235           (set! rev-code (cdr rev-code))
 236           (label lab))
 237         (emit (list 'label lab))))
 238
 239   (define (sleep)
 240     (emit (list 'sleep)))
 241
 242   (define (move-reg src dst)
 243     (cond ((= src dst))
 244           ((= src WREG)
 245            (movwf dst))
 246           ((= dst WREG)
 247            (movfw src))
 248           (else
 249 ;;         (movfw src)
 250 ;;         (movwf dst)
 251            ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
 252            ;; only 1 instruction
 253            (movff src dst))))
 254
 255   (define (bb-linearize bb)
 256     (let ((label-num (bb-label-num bb)))
 257       (let ((bb (vector-ref bbs-vector label-num)))
 258
 259         (define (move-lit n adr)
 260           (cond ((= n 0)
 261                  (clrf adr))
 262                 ((= n #xff)
 263                  (setf adr))
 264                 (else
 265                  (movlw n)
 266                  (movwf adr))))
 267
 268         (define (dump-instr instr)
 269           (cond ((call-instr? instr)
 270                  (let* ((def-proc (call-instr-def-proc instr))
 271                         (entry (def-procedure-entry def-proc)))
 272                    (if (bb? entry)
 273                        (begin
 274                          (add-todo entry)
 275                          (let ((label (bb-label entry)))
 276                            (rcall label)))
 277                        (rcall entry))))
 278                 ((return-instr? instr)
 279                  (return))
 280                 (else
 281                  (let ((src1 (instr-src1 instr))
 282                        (src2 (instr-src2 instr))
 283                        (dst (instr-dst instr)))
 284                    (if (and (or (not (byte-cell? dst))
 285                                 (byte-cell-adr dst))
 286                             (or (not (byte-cell? src1))
 287                                 (byte-cell-adr src1))
 288                             (or (not (byte-cell? src2))
 289                                 (byte-cell-adr src2)))
 290
 291                        (case (instr-id instr)
 292
 293                          ((move)
 294                           (if (byte-lit? src1)
 295                               (let ((n (byte-lit-val src1))
 296                                     (z (byte-cell-adr dst)))
 297                                 (move-lit n z))
 298                               (let ((x (byte-cell-adr src1))
 299                                     (z (byte-cell-adr dst)))
 300                                 (move-reg x z))))
 301
 302                          ((add addc sub subb)
 303                           (if (byte-lit? src2)
 304                               (let ((n (byte-lit-val src2))
 305                                     (z (byte-cell-adr dst)))
 306                                 (if (byte-lit? src1)
 307                                     (move-lit (byte-lit-val src1) z)
 308                                     (move-reg (byte-cell-adr src1) z))
 309                                 (case (instr-id instr)
 310                                   ((add)  (cond ((= n 1)    (incf z))
 311                                                 ((= n #xff) (decf z))
 312                                                 (else       (movlw n)
 313                                                             (addwf z))))
 314                                   ((addc) (movlw n) (addwfc z))
 315                                   ((sub)  (cond ((= n 1)    (decf z))
 316                                                 ((= n #xff) (incf z))
 317                                                 (else       (movlw n)
 318                                                             (subwf z))))
 319                                   ((subb) (movlw n) (subwfb z))))
 320                               (let ((x (byte-cell-adr src1))
 321                                     (y (byte-cell-adr src2))
 322                                     (z (byte-cell-adr dst)))
 323                                 (cond ((and (not (= x y))
 324                                             (= y z)
 325                                             (memq (instr-id instr)
 326                                                   '(add addc)))
 327                                        ;; since this basically swaps the
 328                                        ;; arguments, it can't be used for
 329                                        ;; subtraction
 330                                        (move-reg x WREG))
 331                                       ((and (not (= x y))
 332                                             (= y z))
 333                                        ;; for subtraction, preserves argument
 334                                        ;; order
 335                                        (move-reg y WREG)
 336                                        ;; this NEEDS to be done with movff, or
 337                                        ;; else wreg will get clobbered and this
 338                                        ;; won't work
 339                                        (move-reg x z))
 340                                       (else ;; TODO check if it could be merged with the previous case
 341                                        (move-reg x z)
 342                                        (move-reg y WREG)))
 343                                 (case (instr-id instr)
 344                                   ((add)  (addwf z))
 345                                   ((addc) (addwfc z))
 346                                   ((sub)  (subwf z))
 347                                   ((subb) (subwfb z))
 348                                   (else   (error "..."))))))
 349
 350                          ((mul) ; 8 by 8 multiplication
 351                           (if (byte-lit? src2)
 352                               ;; since multiplication is commutative, the
 353                               ;; arguments are set up so the second one will
 354                               ;; be a literal if the operator is applied on a
 355                               ;; literal and a variable
 356                               (let ((n (byte-lit-val src2)))
 357                                 (if (byte-lit? src1)
 358                                     (movlw   (byte-lit-val src1))
 359                                     (move-reg (byte-cell-adr src1) WREG))
 360                                 ;; literal multiplication
 361                                 (mullw n))
 362                               (let ((x (byte-cell-adr src1))
 363                                     (y (byte-cell-adr src2)))
 364                                 (move-reg x WREG)
 365                                 (mulwf y))))
 366
 367                          ((and ior xor)
 368                           ;; no instructions for bitwise operations involving
 369                           ;; literals exist on the PIC18
 370                           (let ((x (if (byte-lit? src1)
 371                                        (byte-lit-val src1)
 372                                        (byte-cell-adr src1)))
 373                                 (y (if (byte-lit? src2)
 374                                        (byte-lit-val src2)
 375                                        (byte-cell-adr src2)))
 376                                 (z (byte-cell-adr dst)))
 377                             (cond ((byte-lit? src1)
 378                                    (if (byte-lit? src2)
 379                                        (move-lit y z)
 380                                        (move-reg y z))
 381                                    (movlw x))
 382                                   ((and (not (= x y)) (= y z))
 383                                    (move-reg x WREG))
 384                                   (else
 385                                    (move-reg x z)
 386                                    (move-reg y WREG)))
 387                             (case (instr-id instr)
 388                               ((and) (andwf z))
 389                               ((ior) (iorwf z))
 390                               ((xor) (xorwf z))
 391                               (else (error "...")))))
 392
 393                          ((shl shr)
 394                           (let ((x (if (byte-lit? src1)
 395                                        (byte-lit-val src1)
 396                                        (byte-cell-adr src1)))
 397                                 (z (byte-cell-adr dst)))
 398                             (cond ((byte-lit? src1) (move-lit x z))
 399                                   ((not (= x z))    (move-reg x z)))
 400                             (case (instr-id instr)
 401                               ((shl) (rlcf z))
 402                               ((shr) (rrcf z)))))
 403
 404                          ((set clear toggle)
 405                           ;; bit operations
 406                           (if (not (byte-lit? src2))
 407                               (error "bit offset must be a literal"))
 408                           (let ((x (byte-cell-adr src1))
 409                                 (y (byte-lit-val src2)))
 410                             (case (instr-id instr)
 411                               ((set)    (bsf x y))
 412                               ((clear)  (bcf x y))
 413                               ((toggle) (btg x y)))))
 414
 415                          ((not)
 416                           (let ((z (byte-cell-adr dst)))
 417                             (if (byte-lit? src1)
 418                                 (move-lit (byte-lit-val  src1) z)
 419                                 (move-reg (byte-cell-adr src1) z))
 420                             (comf z)))
 421
 422                          ((goto)
 423                           (if (null? (bb-succs bb))
 424                               (error "I think you might have given me an empty source file."))
 425                           (let* ((succs (bb-succs bb))
 426                                  (dest (car succs)))
 427                             (bra (bb-label dest))
 428                             (add-todo dest)))
 429                          ((x==y x<y x>y)
 430                           (let* ((succs (bb-succs bb))
 431                                  (dest-true (car succs))
 432                                  (dest-false (cadr succs)))
 433
 434                             (define (compare flip adr)
 435                               (case (instr-id instr)
 436                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 437                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 438                                 (else (cpfseq adr)))
 439                               (bra (bb-label dest-false))
 440                               (bra (bb-label dest-true))
 441                               (add-todo dest-false)
 442                               (add-todo dest-true))
 443
 444                             (cond ((byte-lit? src1)
 445                                    (let ((n (byte-lit-val src1))
 446                                          (y (byte-cell-adr src2)))
 447                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 448                                               (eq? (instr-id instr) 'x==y))
 449                                          (special-compare-eq-lit n x)
 450                                          (begin
 451                                            (movlw n)
 452                                            (compare #t y)))))
 453                                   ((byte-lit? src2)
 454                                    (let ((x (byte-cell-adr src1))
 455                                          (n (byte-lit-val src2)))
 456                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 457                                               (eq? (instr-id instr) 'x==y))
 458                                          (special-compare-eq-lit n x)
 459                                          (begin
 460                                            (movlw n)
 461                                            (compare #f x)))))
 462                                   (else
 463                                    (let ((x (byte-cell-adr src1))
 464                                          (y (byte-cell-adr src2)))
 465                                      (move-reg y WREG)
 466                                      (compare #f x))))))
 467                          (else
 468                           ;...
 469                           (emit (list (instr-id instr))))))))))
 470
 471         (if bb
 472             (begin
 473               (vector-set! bbs-vector label-num #f)
 474               (label (bb-label bb))
 475               (for-each dump-instr (reverse (bb-rev-instrs bb)))
 476               (for-each add-todo (bb-succs bb)))))))
 477
 478   (let ((prog-label (asm-make-label 'PROG)))
 479     (rcall prog-label)
 480     (sleep)
 481     (label prog-label))
 482
 483   (add-todo (vector-ref bbs-vector 0))
 484
 485   (let loop ()
 486     (if (null? todo)
 487         (reverse rev-code)
 488         (let ((bb (car todo)))
 489           (set! todo (cdr todo))
 490           (bb-linearize bb)
 491           (loop)))))
 492
 493
 494 (define (assembler-gen filename cfg)
 495
 496   (define (gen instr)
 497     (case (car instr)
 498       ((movlw)
 499        (movlw (cadr instr)))
 500       ((movwf)
 501        (movwf (cadr instr)))
 502       ((movfw)
 503        (movf (cadr instr) 'w))
 504       ((movff)
 505        (movff (cadr instr) (caddr instr)))
 506       ((clrf)
 507        (clrf (cadr instr)))
 508       ((setf)
 509        (setf (cadr instr)))
 510       ((incf)
 511        (incf (cadr instr)))
 512       ((decf)
 513        (decf (cadr instr)))
 514       ((addwf)
 515        (addwf (cadr instr)))
 516       ((addwfc)
 517        (addwfc (cadr instr)))
 518       ((subwf)
 519        (subwf (cadr instr)))
 520       ((subwfb)
 521        (subwfb (cadr instr)))
 522       ((mullw)
 523        (mullw (cadr instr)))
 524       ((mulwf)
 525        (mulwf (cadr instr)))
 526       ((andwf)
 527        (andwf (cadr instr)))
 528       ((iorwf)
 529        (iorwf (cadr instr)))
 530       ((xorwf)
 531        (xorwf (cadr instr)))
 532       ((rlcf)
 533        (rlcf (cadr instr)))
 534       ((rrcf)
 535        (rrcf (cadr instr)))
 536       ((bcf)
 537        (bcf (cadr instr) (caddr instr)))
 538       ((bsf)
 539        (bsf (cadr instr) (caddr instr)))
 540       ((btg)
 541        (btg (cadr instr) (caddr instr)))
 542       ((comf)
 543        (comf (cadr instr)))
 544       ((cpfseq)
 545        (cpfseq (cadr instr)))
 546       ((cpfslt)
 547        (cpfslt (cadr instr)))
 548       ((cpfsgt)
 549        (cpfsgt (cadr instr)))
 550       ((bra)
 551        (bra (cadr instr)))
 552       ((rcall)
 553        (rcall (cadr instr)))
 554       ((return)
 555        (return))
 556       ((label)
 557        (asm-listing
 558         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 559        (asm-label (cadr instr)))
 560       ((sleep)
 561        (sleep))
 562       (else
 563        (error "unknown instruction" instr))))
 564
 565   (asm-begin! 0 #f)
 566
 567 ;  (pretty-print cfg)
 568
 569   (let ((code (linearize-and-cleanup cfg)))
 570 ;    (pretty-print code)
 571     (for-each gen code)))
 572
 573 (define (code-gen filename cfg)
 574   (pp register-allocation:)
 575   (allocate-registers cfg)
 576   (pp code-generation:)
 577   (assembler-gen filename cfg))