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 '())
   9
  10   (define (interfere x y)
  11     (if (not (memq x (byte-cell-interferes-with y)))
  12         (begin
  13           (byte-cell-interferes-with-set!
  14            x
  15            (cons y (byte-cell-interferes-with x)))
  16           (byte-cell-interferes-with-set!
  17            y
  18            (cons x (byte-cell-interferes-with y))))))
  19
  20   (define (interfere-pairwise live)
  21     (set! all-live (union all-live live))
  22     (for-each (lambda (x)
  23                 (for-each (lambda (y)
  24                             (if (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                           (list src1)))
  40                   (byte-cell-coalesceable-with-set!
  41                    src1
  42                    (union (byte-cell-coalesceable-with src1)
  43                           (list dst)))))
  44             (if (byte-cell? src2)
  45                 (begin
  46                   (byte-cell-coalesceable-with-set!
  47                    dst
  48                    (union (byte-cell-coalesceable-with dst)
  49                           (list src2)))
  50                   (byte-cell-coalesceable-with-set!
  51                    src2
  52                    (union (byte-cell-coalesceable-with src2)
  53                           (list 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              (keep 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 coalesce-candidates))))
  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 neighbours))
  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       (for-each (lambda (byte-cell2)
  99                   (let ((lst (byte-cell-interferes-with byte-cell2)))
 100                     (byte-cell-interferes-with-set!
 101                      byte-cell2
 102                      (remove byte-cell1 lst))))
 103                 neighbours))
 104
 105     (define (undelete byte-cell1 neighbours)
 106       (for-each (lambda (byte-cell2)
 107                   (let ((lst (byte-cell-interferes-with byte-cell2)))
 108                     (byte-cell-interferes-with-set!
 109                      byte-cell2
 110                      (cons byte-cell1 lst))))
 111                 neighbours))
 112
 113     (define (find-min-neighbours graph)
 114       (let loop ((lst graph) (m #f) (byte-cell #f))
 115         (if (null? lst)
 116             byte-cell
 117             (let* ((x (car lst))
 118                    (n (length (byte-cell-interferes-with x))))
 119               (if (or (not m) (< n m))
 120                   (loop (cdr lst) n x)
 121                   (loop (cdr lst) m byte-cell))))))
 122
 123     (define (alloc-reg graph)
 124       (if (not (null? graph))
 125           (let* ((byte-cell (find-min-neighbours graph))
 126                  (neighbours (byte-cell-interferes-with byte-cell)))
 127             (let ((new-graph (remove byte-cell graph)))
 128               (delete byte-cell neighbours)
 129               (alloc-reg new-graph)
 130               (undelete byte-cell neighbours))
 131             (if (not (byte-cell-adr byte-cell))
 132                 (color byte-cell)))))
 133
 134     (alloc-reg all-live)))
 135
 136
 137 (define (linearize-and-cleanup cfg)
 138
 139   (define bbs-vector (cfg->vector cfg))
 140
 141   (define todo '())
 142
 143   (define (add-todo bb)
 144     (set! todo (cons bb todo)))
 145
 146   (define rev-code '())
 147
 148   (define (emit instr)
 149     (set! rev-code (cons instr rev-code)))
 150
 151   (define (movlw val)
 152     (emit (list 'movlw val)))
 153   (define (movwf adr)
 154     (emit (list 'movwf adr)))
 155   (define (movfw adr)
 156     (emit (list 'movfw adr)))
 157   (define (movff src dst)
 158     (emit (list 'movff src dst)))
 159
 160   (define (clrf adr)
 161     (emit (list 'clrf adr)))
 162   (define (setf adr)
 163     (emit (list 'setf adr)))
 164
 165   (define (incf adr)
 166     (emit (list 'incf adr)))
 167   (define (decf adr)
 168     (emit (list 'decf adr)))
 169
 170   (define (addwf adr)
 171     (emit (list 'addwf adr)))
 172   (define (addwfc adr)
 173     (emit (list 'addwfc adr)))
 174
 175   (define (subwf adr)
 176     (emit (list 'subwf adr)))
 177   (define (subwfb adr)
 178     (emit (list 'subwfb adr)))
 179
 180   (define (mullw adr)
 181     (emit (list 'mullw adr)))
 182   (define (mulwf adr)
 183     (emit (list 'mulwf adr)))
 184
 185   (define (andwf adr)
 186     (emit (list 'andwf adr)))
 187   (define (iorwf adr)
 188     (emit (list 'iorwf adr)))
 189   (define (xorwf adr)
 190     (emit (list 'xorwf adr)))
 191
 192   (define (cpfseq adr)
 193     (emit (list 'cpfseq adr)))
 194   (define (cpfslt adr)
 195     (emit (list 'cpfslt adr)))
 196   (define (cpfsgt adr)
 197     (emit (list 'cpfsgt adr)))
 198
 199   (define (bra label)
 200     (emit (list 'bra label)))
 201
 202   (define (rcall label)
 203     (emit (list 'rcall label)))
 204
 205   (define (return)
 206     (if (and #f (and (not (null? rev-code)) ; TODO probably here for eventual inlining
 207                      (eq? (caar rev-code) 'rcall)))
 208         (let ((label (cadar rev-code)))
 209           (set! rev-code (cdr rev-code))
 210           (bra label))
 211         (emit (list 'return))))
 212
 213   (define (label lab)
 214     (if (and #f (and (not (null? rev-code)) ; TODO would probably be useful to eliminate things like : bra $2, $2:
 215              (eq? (caar rev-code) 'bra)
 216              (eq? (cadar rev-code) lab)))
 217         (begin
 218           (set! rev-code (cdr rev-code))
 219           (label lab))
 220         (emit (list 'label lab))))
 221
 222   (define (sleep)
 223     (emit (list 'sleep)))
 224
 225   (define (move-reg src dst)
 226     (cond ((= src dst))
 227           ((= src WREG)
 228            (movwf dst))
 229           ((= dst WREG)
 230            (movfw src))
 231           (else
 232 ;;         (movfw src)
 233 ;;         (movwf dst)
 234            ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
 235            ;; only 1 instruction
 236            (movff src dst))))
 237
 238   (define (bb-linearize bb)
 239     (let ((label-num (bb-label-num bb)))
 240       (let ((bb (vector-ref bbs-vector label-num)))
 241
 242         (define (move-lit n adr)
 243           (cond ((= n 0)
 244                  (clrf adr))
 245                 ((= n #xff)
 246                  (setf adr))
 247                 (else
 248                  (movlw n)
 249                  (movwf adr))))
 250
 251         (define (dump-instr instr)
 252           (cond ((call-instr? instr)
 253                  (let* ((def-proc (call-instr-def-proc instr))
 254                         (entry (def-procedure-entry def-proc)))
 255                    (if (bb? entry)
 256                        (begin
 257                          (add-todo entry)
 258                          (let ((label (bb-label entry)))
 259                            (rcall label)))
 260                        (rcall entry))))
 261                 ((return-instr? instr)
 262                  (return))
 263                 (else
 264                  (let ((src1 (instr-src1 instr))
 265                        (src2 (instr-src2 instr))
 266                        (dst (instr-dst instr)))
 267                    (if (and (or (not (byte-cell? dst))
 268                                 (byte-cell-adr dst))
 269                             (or (not (byte-cell? src1))
 270                                 (byte-cell-adr src1))
 271                             (or (not (byte-cell? src2))
 272                                 (byte-cell-adr src2)))
 273
 274                        (case (instr-id instr)
 275
 276                          ((move)
 277                           (if (byte-lit? src1)
 278                               (let ((n (byte-lit-val src1))
 279                                     (z (byte-cell-adr dst)))
 280                                 (move-lit n z))
 281                               (let ((x (byte-cell-adr src1))
 282                                     (z (byte-cell-adr dst)))
 283                                 (move-reg x z))))
 284
 285                          ((add addc sub subb)
 286                           (if (byte-lit? src2)
 287                               (let ((n (byte-lit-val src2))
 288                                     (z (byte-cell-adr dst)))
 289                                 (if (byte-lit? src1)
 290                                     (move-lit (byte-lit-val src1) z)
 291                                     (move-reg (byte-cell-adr src1) z))
 292                                 (case (instr-id instr)
 293                                   ((add)  (cond ((= n 1)    (incf z))
 294                                                 ((= n #xff) (decf z))
 295                                                 (else       (movlw n)
 296                                                             (addwf z))))
 297                                   ((addc) (movlw n) (addwfc z))
 298                                   ((sub)  (cond ((= n 1)    (decf z))
 299                                                 ((= n #xff) (incf z))
 300                                                 (else       (movlw n)
 301                                                             (subwf z))))
 302                                   ((subb) (movlw n) (subwfb z))))
 303                               (let ((x (byte-cell-adr src1))
 304                                     (y (byte-cell-adr src2))
 305                                     (z (byte-cell-adr dst)))
 306                                 (cond ((and (not (= x y))
 307                                             (= y z)
 308                                             (memq (instr-id instr)
 309                                                   '(add addc)))
 310                                        ;; since this basically swaps the
 311                                        ;; arguments, it can't be used for
 312                                        ;; subtraction
 313                                        (move-reg x WREG))
 314                                       ((and (not (= x y))
 315                                             (= y z))
 316                                        ;; for subtraction, preserves argument
 317                                        ;; order
 318                                        (move-reg y WREG)
 319                                        ;; this NEEDS to be done with movff, or
 320                                        ;; else wreg will get clobbered and this
 321                                        ;; won't work
 322                                        (move-reg x z))
 323                                       (else ;; TODO check if it could be merged with the previous case
 324                                        (move-reg x z)
 325                                        (move-reg y WREG)))
 326                                 (case (instr-id instr)
 327                                   ((add)  (addwf z))
 328                                   ((addc) (addwfc z))
 329                                   ((sub)  (subwf z))
 330                                   ((subb) (subwfb z))
 331                                   (else   (error "..."))))))
 332
 333                          ((mul) ; 8 by 8 multiplication
 334                           (if (byte-lit? src2)
 335                               ;; since multiplication is commutative, the
 336                               ;; arguments are set up so the second one will
 337                               ;; be a literal if the operator is applied on a
 338                               ;; literal and a variable
 339                               (let ((n (byte-lit-val src2)))
 340                                 (if (byte-lit? src1) ;; TODO will probably never be called with literals, since it's always inside a function
 341                                     (movlw   (byte-lit-val src1))
 342                                     (movereg (byte-cell-adr src1) WREG))
 343                                 ;; literal multiplication
 344                                 (mullw n))
 345                               (let ((x (byte-cell-adr src1))
 346                                     (y (byte-cell-adr src2)))
 347                                 (move-reg x WREG)
 348                                 (mulwf y))))
 349
 350                          ((and ior xor) ;; TODO similar to add sub and co, except that I removed the literal part
 351                           ;; no instructions for bitwise operations involving
 352                           ;; literals exist on the PIC18
 353                           (let ((x (if (byte-lit? src1)
 354                                        (byte-lit-val src1)
 355                                        (byte-cell-adr src1)))
 356                                 (y (if (byte-lit? src2)
 357                                        (byte-lit-val src2)
 358                                        (byte-cell-adr src2)))
 359                                 (z (byte-cell-adr dst)))
 360                             (cond ((byte-lit? src1)
 361                                    (if (byte-lit? src2)
 362                                        (move-lit y z)
 363                                        (move-reg y z))
 364                                    (movlw x)) ;; TODO not sure it will work
 365                                   ((and (not (= x y)) (= y z))
 366                                    (move-reg x WREG))
 367                                   (else
 368                                    (move-reg x z)
 369                                    (move-reg y WREG)))
 370                             (case (instr-id instr)
 371                               ((and) (andwf z))
 372                               ((ior) (iorwf z))
 373                               ((xor) (xorwf z))
 374                               (else (error "...")))))
 375
 376                          ((goto)
 377                           (if (null? (bb-succs bb))
 378                               ;; TODO happens more often than I'd like to admit
 379                               (error "I think you might have given me an empty source file."))
 380                           (let* ((succs (bb-succs bb))
 381                                  (dest (car succs)))
 382                             (bra (bb-label dest))
 383                             (add-todo dest)))
 384                          ((x==y x<y x>y)
 385                           (let* ((succs (bb-succs bb))
 386                                  (dest-true (car succs))
 387                                  (dest-false (cadr succs)))
 388
 389                             (define (compare flip adr)
 390                               (case (instr-id instr)
 391                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 392                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 393                                 (else (cpfseq adr)))
 394                               (bra (bb-label dest-false))
 395                               (bra (bb-label dest-true))
 396                               (add-todo dest-false)
 397                               (add-todo dest-true))
 398
 399                             (cond ((byte-lit? src1)
 400                                    (let ((n (byte-lit-val src1))
 401                                          (y (byte-cell-adr src2)))
 402                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 403                                               (eq? (instr-id instr) 'x==y))
 404                                          (special-compare-eq-lit n x)
 405                                          (begin
 406                                            (movlw n)
 407                                            (compare #t y)))))
 408                                   ((byte-lit? src2)
 409                                    (let ((x (byte-cell-adr src1))
 410                                          (n (byte-lit-val src2)))
 411                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 412                                               (eq? (instr-id instr) 'x==y))
 413                                          (special-compare-eq-lit n x) ;; TODO does not exist. the only way apart from cpfseq I see would be to load w, do a subtraction, then conditional branch, but would be larger and would take 1-2 cycles more
 414                                          (begin
 415                                            (movlw n)
 416                                            (compare #f x)))))
 417                                   (else
 418                                    (let ((x (byte-cell-adr src1))
 419                                          (y (byte-cell-adr src2)))
 420                                      (move-reg y WREG)
 421                                      (compare #f x))))))
 422                          (else
 423                           ;...
 424                           (emit (list (instr-id instr))))))))))
 425
 426         (if bb
 427             (begin
 428               (vector-set! bbs-vector label-num #f)
 429               (label (bb-label bb))
 430               (for-each dump-instr (reverse (bb-rev-instrs bb)))
 431               (for-each add-todo (bb-succs bb)))))))
 432
 433   (let ((prog-label (asm-make-label 'PROG)))
 434     (rcall prog-label)
 435     (sleep)
 436     (label prog-label))
 437
 438   (add-todo (vector-ref bbs-vector 0))
 439
 440   (let loop ()
 441     (if (null? todo)
 442         (reverse rev-code)
 443         (let ((bb (car todo)))
 444           (set! todo (cdr todo))
 445           (bb-linearize bb)
 446           (loop)))))
 447
 448
 449 (define (assembler-gen filename cfg)
 450
 451   (define (gen instr)
 452     (case (car instr)
 453       ((movlw)
 454        (movlw (cadr instr)))
 455       ((movwf)
 456        (movwf (cadr instr)))
 457       ((movfw)
 458        (movf (cadr instr) 'w))
 459       ((movff)
 460        (movff (cadr instr) (caddr instr)))
 461       ((clrf)
 462        (clrf (cadr instr)))
 463       ((setf)
 464        (setf (cadr instr)))
 465       ((incf)
 466        (incf (cadr instr)))
 467       ((decf)
 468        (decf (cadr instr)))
 469       ((addwf)
 470        (addwf (cadr instr)))
 471       ((addwfc)
 472        (addwfc (cadr instr)))
 473       ((subwf)
 474        (subwf (cadr instr)))
 475       ((subwfb)
 476        (subwfb (cadr instr)))
 477       ((mullw)
 478        (mullw (cadr instr)))
 479       ((mulwf)
 480        (mulwf (cadr instr)))
 481       ((andwf)
 482        (andwf (cadr instr)))
 483       ((iorwf)
 484        (iorwf (cadr instr)))
 485       ((xorwf)
 486        (xorwf (cadr instr)))
 487       ((cpfseq)
 488        (cpfseq (cadr instr)))
 489       ((cpfslt)
 490        (cpfslt (cadr instr)))
 491       ((cpfsgt)
 492        (cpfsgt (cadr instr)))
 493       ((bra)
 494        (bra (cadr instr)))
 495       ((rcall)
 496        (rcall (cadr instr)))
 497       ((return)
 498        (return))
 499       ((label)
 500        (asm-listing
 501         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 502        (asm-label (cadr instr)))
 503       ((sleep)
 504        (sleep))
 505       (else
 506        (error "unknown instruction" instr))))
 507
 508   (asm-begin! 0 #f)
 509
 510 ;  (pretty-print cfg)
 511
 512   (let ((code (linearize-and-cleanup cfg)))
 513 ;    (pretty-print code)
 514     (for-each gen code)))
 515
 516 (define (code-gen filename cfg)
 517   (allocate-registers cfg)
 518   (assembler-gen filename cfg)
 519 ;  (pretty-print cfg)
 520 ;  (pretty-print (reverse (bb-rev-instrs bb))) ;; TODO what ? there are no bbs here...
 521   )