code-generation.scm

   1 ;; adress 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
 154   (define (movwf adr)
 155     (emit (list 'movwf adr)))
 156
 157   (define (movfw adr)
 158     (emit (list 'movfw adr)))
 159
 160   (define (movff src dst)
 161     (emit (list 'movff src dst)))
 162
 163   (define (clrf adr)
 164     (emit (list 'clrf adr)))
 165
 166   (define (setf adr)
 167     (emit (list 'setf adr)))
 168
 169   (define (incf adr)
 170     (emit (list 'incf adr)))
 171
 172   (define (decf adr)
 173     (emit (list 'decf adr)))
 174
 175   (define (addwf adr)
 176     (emit (list 'addwf adr)))
 177
 178   (define (addwfc adr)
 179     (emit (list 'addwfc adr)))
 180
 181   (define (subwf adr)
 182     (emit (list 'subwf adr)))
 183
 184   (define (subwfb adr)
 185     (emit (list 'subwfb adr)))
 186
 187   (define (cpfseq adr)
 188     (emit (list 'cpfseq adr)))
 189
 190   (define (cpfslt adr)
 191     (emit (list 'cpfslt adr)))
 192
 193   (define (cpfsgt adr)
 194     (emit (list 'cpfsgt adr)))
 195
 196   (define (bra label)
 197     (emit (list 'bra label)))
 198
 199   (define (rcall label)
 200     (emit (list 'rcall label)))
 201
 202   (define (return)
 203     (if (and #f (and (not (null? rev-code)) ; TODO probably here for eventual inlining
 204                      (eq? (caar rev-code) 'rcall)))
 205         (let ((label (cadar rev-code)))
 206           (set! rev-code (cdr rev-code))
 207           (bra label))
 208         (emit (list 'return))))
 209
 210   (define (label lab)
 211     (if (and #f (and (not (null? rev-code)) ; TODO would probably be useful to eliminate things like : bra $2, $2:
 212              (eq? (caar rev-code) 'bra)
 213              (eq? (cadar rev-code) lab)))
 214         (begin
 215           (set! rev-code (cdr rev-code))
 216           (label lab))
 217         (emit (list 'label lab))))
 218
 219   (define (sleep)
 220     (emit (list 'sleep)))
 221
 222   (define (move-reg src dst)
 223     (cond ((= src dst))
 224           ((= src WREG)
 225            (movwf dst))
 226           ((= dst WREG)
 227            (movfw src))
 228           (else
 229            (movfw src)
 230            (movwf dst)
 231            ;(movff src dst) ; takes 2 cycles (as much as movfw src ; movwf dst), but takes only 1 instruction TODO not implemented in the simulator
 232            )))
 233
 234   (define (bb-linearize bb)
 235     (let ((label-num (bb-label-num bb)))
 236       (let ((bb (vector-ref bbs-vector label-num)))
 237
 238         (define (move-lit n adr)
 239           (cond ((= n 0)
 240                  (clrf adr))
 241                 ((= n #xff)
 242                  (setf adr))
 243                 (else
 244                  (movlw n)
 245                  (movwf adr))))
 246
 247         (define (dump-instr instr)
 248           (cond ((call-instr? instr)
 249                  (let* ((def-proc (call-instr-def-proc instr))
 250                         (entry (def-procedure-entry def-proc)))
 251                    (if (bb? entry)
 252                        (begin
 253                          (add-todo entry)
 254                          (let ((label (bb-label entry)))
 255                            (rcall label)))
 256                        (rcall entry))))
 257                 ((return-instr? instr)
 258                  (return))
 259                 (else
 260                  (let ((src1 (instr-src1 instr))
 261                        (src2 (instr-src2 instr))
 262                        (dst (instr-dst instr)))
 263                    (if (and (or (not (byte-cell? dst))
 264                                 (byte-cell-adr dst))
 265                             (or (not (byte-cell? src1))
 266                                 (byte-cell-adr src1))
 267                             (or (not (byte-cell? src2))
 268                                 (byte-cell-adr src2)))
 269                        (case (instr-id instr)
 270                          ((move)
 271                           (if (byte-lit? src1)
 272                               (let ((n (byte-lit-val src1))
 273                                     (z (byte-cell-adr dst)))
 274                                 (move-lit n z))
 275                               (let ((x (byte-cell-adr src1))
 276                                     (z (byte-cell-adr dst)))
 277                                 (move-reg x z))))
 278                          ((add addc sub subb)
 279                           (if (byte-lit? src2)
 280                               (let ((n (byte-lit-val src2))
 281                                     (z (byte-cell-adr dst)))
 282                                 (if (byte-lit? src1)
 283                                     (move-lit (byte-lit-val src1) z)
 284                                     (move-reg (byte-cell-adr src1) z))
 285                                 (case (instr-id instr)
 286                                   ((add)
 287                                    (cond ((= n 1)
 288                                           (incf z))
 289                                          ((= n #xff)
 290                                           (decf z))
 291                                          (else
 292                                           (movlw n)
 293                                           (addwf z))))
 294                                   ((addc)
 295                                    (movlw n)
 296                                    (addwfc z))
 297                                   ((sub)
 298                                    (cond ((= n 1)
 299                                           (decf z))
 300                                          ((= n #xff)
 301                                           (incf z))
 302                                          (else
 303                                           (movlw n)
 304                                           (subwf z))))
 305                                   ((subb)
 306                                    (movlw n)
 307                                    (subwfb z))))
 308                               (let ((x (byte-cell-adr src1))
 309                                     (y (byte-cell-adr src2))
 310                                     (z (byte-cell-adr dst)))
 311                                 (cond ((and (not (= x y)) (= y z))
 312                                        (move-reg x WREG)
 313                                        (case (instr-id instr)
 314                                          ((add)
 315                                           (addwf z))
 316                                          ((addc)
 317                                           (addwfc z))
 318                                          ((sub)
 319                                           (subwfr z))
 320                                          ((subb)
 321                                           (subwfbr z))
 322                                          (else (error "..."))))
 323                                       (else
 324                                        (move-reg x z)
 325                                        (move-reg y WREG)
 326                                        (case (instr-id instr)
 327                                          ((add)
 328                                           (addwf z))
 329                                          ((addc)
 330                                           (addwfc z))
 331                                          ((sub)
 332                                           (subwf z))
 333                                          ((subb)
 334                                           (subwfb z))
 335                                          (else (error "..."))))))))
 336                          ((goto)
 337                           (let* ((succs (bb-succs bb))
 338                                  (dest (car succs)))
 339                             (bra (bb-label dest))
 340                             (add-todo dest)))
 341                          ((x==y x<y x>y)
 342                           (let* ((succs (bb-succs bb))
 343                                  (dest-true (car succs))
 344                                  (dest-false (cadr succs)))
 345
 346                             (define (compare flip adr)
 347                               (case (instr-id instr)
 348                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 349                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 350                                 (else (cpfseq adr)))
 351                               (bra (bb-label dest-false))
 352                               (bra (bb-label dest-true))
 353                               (add-todo dest-false)
 354                               (add-todo dest-true))
 355
 356                             (cond ((byte-lit? src1)
 357                                    (let ((n (byte-lit-val src1))
 358                                          (y (byte-cell-adr src2)))
 359                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 360                                               (eq? (instr-id instr) 'x==y))
 361                                          (special-compare-eq-lit n x)
 362                                          (begin
 363                                            (movlw n)
 364                                            (compare #t y)))))
 365                                   ((byte-lit? src2)
 366                                    (let ((x (byte-cell-adr src1))
 367                                          (n (byte-lit-val src2)))
 368                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 369                                               (eq? (instr-id instr) 'x==y))
 370                                          (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
 371                                          (begin
 372                                            (movlw n)
 373                                            (compare #f x)))))
 374                                   (else
 375                                    (let ((x (byte-cell-adr src1))
 376                                          (y (byte-cell-adr src2)))
 377                                      (move-reg y WREG)
 378                                      (compare #f x))))))
 379                          (else
 380                           ;...
 381                           (emit (list (instr-id instr))))))))))
 382
 383         (if bb
 384             (begin
 385               (vector-set! bbs-vector label-num #f)
 386               (label (bb-label bb))
 387               (for-each dump-instr (reverse (bb-rev-instrs bb)))
 388               (for-each add-todo (bb-succs bb)))))))
 389
 390   (let ((prog-label (asm-make-label 'PROG)))
 391     (rcall prog-label)
 392     (sleep)
 393     (label prog-label))
 394
 395   (add-todo (vector-ref bbs-vector 0))
 396
 397   (let loop ()
 398     (if (null? todo)
 399         (reverse rev-code)
 400         (let ((bb (car todo)))
 401           (set! todo (cdr todo))
 402           (bb-linearize bb)
 403           (loop)))))
 404
 405
 406 (define (assembler-gen filename cfg)
 407
 408   (define (gen instr)
 409     (case (car instr)
 410       ((movlw)
 411        (movlw (cadr instr)))
 412       ((movwf)
 413        (movwf (cadr instr)))
 414       ((movfw)
 415        (movf (cadr instr) 'w))
 416       ((movff)
 417        (movff (cadr instr) (caddr instr)))
 418       ((clrf)
 419        (clrf (cadr instr)))
 420       ((setf)
 421        (setf (cadr instr)))
 422       ((incf)
 423        (incf (cadr instr)))
 424       ((decf)
 425        (decf (cadr instr)))
 426       ((addwf)
 427        (addwf (cadr instr)))
 428       ((addwfc)
 429        (addwfc (cadr instr)))
 430       ((subwf)
 431        (subwf (cadr instr)))
 432       ((subwfb)
 433        (subwfb (cadr instr)))
 434       ((cpfseq)
 435        (cpfseq (cadr instr)))
 436       ((cpfslt)
 437        (cpfslt (cadr instr)))
 438       ((cpfsgt)
 439        (cpfsgt (cadr instr)))
 440       ((bra)
 441        (bra (cadr instr)))
 442       ((rcall)
 443        (rcall (cadr instr)))
 444       ((return)
 445        (return))
 446       ((label)
 447        (asm-listing
 448         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 449        (asm-label (cadr instr)))
 450       ((sleep)
 451        (sleep))
 452       (else
 453        (error "unknown instruction" instr))))
 454
 455   (asm-begin! 0 #f)
 456
 457 ;  (pretty-print cfg)
 458
 459   (let ((code (linearize-and-cleanup cfg)))
 460 ;    (pretty-print code)
 461     (for-each gen code))
 462
 463   (asm-assemble)
 464
 465   '(display "------------------ GENERATED CODE\n")
 466
 467   (asm-display-listing (current-output-port))
 468
 469   (asm-write-hex-file (string-append filename ".hex")) ;; TODO move to main ?
 470
 471   (asm-end!))
 472
 473 (define (code-gen filename cfg)
 474   (allocate-registers cfg)
 475   (assembler-gen filename cfg)
 476 ;  (pretty-print cfg)
 477 ;  (pretty-print (reverse (bb-rev-instrs bb))) ;; TODO what ? there are no bbs here...
 478   )