register-allocation.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 ;; the vector equivalent to all-byte-cells
   7 (define byte-cells #f)
   8
   9 (define (interference-graph cfg)
  10
  11   (define (analyze-liveness cfg)
  12     (define changed? #t)
  13     (define (instr-analyze-liveness instr live-after)
  14       (let ((live-before
  15              (cond
  16
  17               ((call-instr? instr)
  18                (let ((def-proc (call-instr-def-proc instr)))
  19                  (if (and (not (set-empty? live-after))
  20                           (not (set-equal?
  21                                 (set-intersection
  22                                  (def-procedure-live-after-calls def-proc)
  23                                  live-after)
  24                                 live-after)))
  25                      (begin
  26                        (set! changed? #t)
  27                        (set-union! (def-procedure-live-after-calls def-proc)
  28                                    live-after)))
  29                  (let ((live
  30                         (set-union
  31                          (set-union-multi
  32                           (map (lambda (def-var)
  33                                  (list->set
  34                                   (value-bytes (def-variable-value def-var))))
  35                                (def-procedure-params def-proc)))
  36                          (set-union
  37                           (set-diff
  38                            live-after
  39                            (list->set
  40                             (value-bytes (def-procedure-value def-proc))))
  41                           (bb-live-before (def-procedure-entry def-proc)))))) ;; FOO now the liveness analysis takes a whole minute
  42                    (if (bb? (def-procedure-entry def-proc))
  43                        (set-intersection ;; TODO disabling this branch saves around 12 bytes
  44                         (bb-live-before (def-procedure-entry def-proc))
  45                         live)
  46                        live))))
  47
  48               ((return-instr? instr)
  49                (let* ((def-proc (return-instr-def-proc instr))
  50                       (live
  51                        (if (def-procedure? def-proc)
  52                            (def-procedure-live-after-calls def-proc)
  53                            (list->set (value-bytes def-proc)))))
  54                  (set! live-after live)
  55                  live))
  56
  57               (else
  58                (let* ((src1 (instr-src1 instr))
  59                       (src2 (instr-src2 instr))
  60                       (dst  (instr-dst instr))
  61                       (use  (if (byte-cell? src1)
  62                                 (if (byte-cell? src2)
  63                                     (set-add (new-set src1) src2)
  64                                     (new-set src1))
  65                                 (if (byte-cell? src2)
  66                                     (new-set src2)
  67                                     (new-empty-set))))
  68                       (def  (if (byte-cell? dst)
  69                                 (new-set dst)
  70                                 (new-empty-set))))
  71                  (if #f
  72                      ;; (and (byte-cell? dst) ; dead instruction?
  73                      ;;      (not (set-member? live-after dst))
  74                      ;;      (not (and (byte-cell? dst) (byte-cell-adr dst))))
  75                      live-after
  76                      (set-union use
  77                                 (set-diff live-after def))))))))
  78
  79         (instr-live-before-set! instr live-before)
  80         (instr-live-after-set!  instr live-after)
  81         live-before))
  82     (define (bb-analyze-liveness bb)
  83       (let loop ((rev-instrs (bb-rev-instrs bb))
  84                  (live-after (set-union-multi
  85                               (map bb-live-before (bb-succs bb)))))
  86         (if (null? rev-instrs)
  87             (if (not (set-equal? live-after (bb-live-before bb)))
  88                 (begin (set! changed? #t)
  89                        (bb-live-before-set! bb live-after)))
  90             (let* ((instr (car rev-instrs))
  91                    (live-before (instr-analyze-liveness instr live-after)))
  92               (loop (cdr rev-instrs)
  93                     live-before)))))
  94     (let loop ()
  95       (if changed?
  96           (begin (set! changed? #f)
  97                  (for-each bb-analyze-liveness (cfg-bbs cfg))
  98                  (loop)))))
  99
 100 ;;-----------------------------------------------------------------------------
 101
 102   (define all-live (new-empty-set))
 103
 104   (define (bb-interference-graph bb)
 105     ;; TODO maybe building them asymetric, and then having a pass to make them symetric could be faster. I tried, but it didn't work
 106     (define (interfere x y)
 107       (bitset-add! (byte-cell-interferes-with x) (byte-cell-id y))
 108       (bitset-add! (byte-cell-interferes-with y) (byte-cell-id x)))
 109     (define (make-coalesceable-with x y)
 110       (set-add! (byte-cell-coalesceable-with x) y)
 111       (set-add! (byte-cell-coalesceable-with y) x))
 112
 113     (define (interfere-pairwise live)
 114       (set-union! all-live live)
 115       (set-for-each
 116        (lambda (x)
 117          (set-for-each
 118           (lambda (y)
 119             (if (not (eq? x y))
 120                 (bitset-add! (byte-cell-interferes-with x) (byte-cell-id y))))
 121           live))
 122        live))
 123
 124     (define (instr-interference-graph instr)
 125       (let ((dst  (instr-dst  instr))
 126             (src1 (instr-src1 instr))
 127             (src2 (instr-src2 instr)))
 128         (if (byte-cell? dst)
 129             (begin
 130               (if (and (byte-cell? src1) (not (eq? dst src1)))
 131                   (make-coalesceable-with src1 dst))
 132               (if (and (byte-cell? src2) (not (eq? dst src2)))
 133                   (make-coalesceable-with src2 dst))))
 134         (if (call-instr? instr)
 135             (let* ((before (instr-live-before instr))
 136                    (after  (instr-live-after  instr))
 137                    (diff   (set-diff before after))
 138                    (diff2  (set-diff after  before)))
 139               (interfere-pairwise diff)
 140               (set-for-each
 141                (lambda (x)
 142                  (set-for-each
 143                   (lambda (y)
 144                     (if (and (not (eq? x y)) (not (set-member? diff2 y)))
 145                         (interfere x y)))
 146                   after))
 147                diff))
 148             (if (byte-cell? dst)
 149                 (begin (set-add! all-live dst)
 150                        (set-for-each (lambda (x)
 151                                        (set-add! all-live x)
 152                                        (if (not (eq? dst x))
 153                                            (interfere dst x)))
 154                                      (instr-live-after instr)))))))
 155
 156     (for-each instr-interference-graph (bb-rev-instrs bb)))
 157
 158   ;; build a vector with all the byte-cells and initialise the bit fields
 159   (set! byte-cells (make-vector byte-cell-counter #f))
 160   (table-for-each (lambda (id cell)
 161                     (byte-cell-interferes-with-set!
 162                      cell (make-bitset byte-cell-counter))
 163                     (vector-set! byte-cells id cell))
 164                   all-byte-cells)
 165
 166   (pp analyse-liveness:)
 167   (time (analyze-liveness cfg))
 168
 169   (pp interference-graph:)
 170   (time (for-each bb-interference-graph (cfg-bbs cfg)))
 171
 172   ;; change the bitsets to sets, to speed up graph coloring
 173   (let loop ((l (- (vector-length byte-cells) 1)))
 174     (if (not (< l 0))
 175         (let* ((cell (vector-ref byte-cells l)))
 176           (if cell
 177               (byte-cell-interferes-with-set!
 178                cell
 179                (let* ((bs  (byte-cell-interferes-with cell))
 180                       (n   (fxarithmetic-shift-left (u8vector-length bs) 3))
 181                       (set (new-empty-set)))
 182                  (let loop ((i (- n 1)))
 183                    (if (>= i 0)
 184                        (begin (if (bitset-member? bs i)
 185                                   (set-add! set (vector-ref byte-cells i)))
 186                               (loop (- i 1)))
 187                        set)))))
 188           (loop (- l 1)))))
 189
 190   all-live)
 191
 192 ;;-----------------------------------------------------------------------------
 193
 194 (define (delete byte-cell1 neighbours)
 195   (set-for-each (lambda (byte-cell2)
 196                   (set-remove! (byte-cell-interferes-with byte-cell2)
 197                                byte-cell1)
 198                   (byte-cell-nb-neighbours-set!
 199                    byte-cell2 (- (byte-cell-nb-neighbours byte-cell2) 1)))
 200                 neighbours))
 201 (define (undelete byte-cell1 neighbours)
 202   (set-for-each (lambda (byte-cell2)
 203                   (set-add! (byte-cell-interferes-with byte-cell2)
 204                             byte-cell1)
 205                   (byte-cell-nb-neighbours-set!
 206                    byte-cell2 (+ (byte-cell-nb-neighbours byte-cell2) 1)))
 207                 neighbours))
 208
 209 (define (coalesce graph)
 210   (if coalesce?
 211       (keep
 212        (lambda (byte-cell)
 213          (let* ((coalesceable-with   (byte-cell-coalesceable-with byte-cell))
 214                 (old-neighbours      (byte-cell-interferes-with   byte-cell))
 215                 (coalesce-candidates (set-diff coalesceable-with
 216                                                old-neighbours)))
 217            (if (or (byte-cell-adr byte-cell) ; in a special register
 218                    (set-empty? coalesce-candidates))
 219                #t ;; keep it
 220                ;; coalesce byte-cell with another cell
 221                (let loop ((l (set->list coalesce-candidates)))
 222                  (if (null? l)
 223                      #t ; can't coalesce, keep
 224                      (let ((c (car l)))
 225                        ;; don't coalesce with a special register
 226                        (if (byte-cell-adr c)
 227                            (loop (cdr l))
 228                            (let ((c-neighbours (byte-cell-interferes-with c))
 229                                  (c-coalesced  (byte-cell-coalesced-with  c)))
 230                              ;; remove all references to byte-cell and replace
 231                              ;; them with references to c
 232                              (set-union! c-neighbours old-neighbours)
 233                              (undelete   c            old-neighbours)
 234                              (delete     byte-cell    old-neighbours)
 235                              (set-union! c-coalesced
 236                                          (byte-cell-coalesced-with byte-cell))
 237                              (set-for-each
 238                               (lambda (cell)
 239                                 (let ((s (byte-cell-coalesceable-with cell)))
 240                                   (set-remove! s byte-cell)
 241                                   #;(set-add!    s c))) ;; FOO attempt (failed)
 242                               coalesceable-with)
 243                              (byte-cell-coalesceable-with-set! byte-cell
 244                                                                (new-empty-set))
 245                              (byte-cell-interferes-with-set!   byte-cell
 246                                                                (new-empty-set))
 247                              (set-add! c-coalesced byte-cell)
 248                              #f))))))))
 249        graph)
 250       graph))
 251
 252 ;;-----------------------------------------------------------------------------
 253
 254 (define register-table         (make-table))
 255 (define reverse-register-table (make-table))
 256 (define (allocate-registers cfg)
 257   (let ((all-live (coalesce (set->list (interference-graph cfg))))
 258         (max-adr  0)) ; to know how much ram we need
 259
 260     (define (color byte-cell)
 261       (define (set-register-table cell adr)
 262         (if #f (not (string=? (byte-cell-name cell) "__tmp"))
 263             (let ((adr (if (and (> adr #x5F) (< adr #xF60)) ; not in bank 0 ;; TODO have a function for that
 264                            (+ adr #xa0)
 265                            adr)))
 266               (table-set! register-table
 267                           adr
 268                           (cons (cons (byte-cell-bb   cell)
 269                                       (byte-cell-name cell))
 270                                 (table-ref register-table adr '())))
 271               (table-set! reverse-register-table
 272                           (byte-cell-name cell) ;; TODO add the bb ?
 273                           adr))))
 274       (let ((neighbours (set->list (byte-cell-interferes-with byte-cell))))
 275         (let loop1 ((adr 0))
 276           (if (and memory-divide ; the user wants his own zone
 277                    (>= adr memory-divide)) ; and we'd use it
 278               (error "register allocation would cross the memory divide") ;; TODO fallback ?
 279               (let loop2 ((lst neighbours)) ;; TODO keep using sets, but not urgent, it's not a bottleneck
 280                 (if (null? lst)
 281                     (begin (byte-cell-adr-set! byte-cell adr)
 282                            (set-register-table byte-cell adr)
 283                            (set-for-each
 284                             (lambda (cell)
 285                               (byte-cell-adr-set! cell adr)
 286                               (set-register-table cell adr))
 287                             (byte-cell-coalesced-with byte-cell)))
 288                     (if (= adr (byte-cell-adr (car lst)))
 289                         (loop1 (+ adr 1))
 290                         (loop2 (cdr lst))))))
 291           (set! max-adr (max max-adr adr)))))
 292
 293     (define (find-min-neighbours graph)
 294       (let loop ((lst graph) (m #f) (byte-cell #f))
 295         (if (null? lst)
 296             byte-cell
 297             (let* ((x (car lst))
 298                    (n (byte-cell-nb-neighbours x)))
 299               (if (or (not m) (< n m))
 300                   (loop (cdr lst) n x)
 301                   (loop (cdr lst) m byte-cell))))))
 302
 303     (define (alloc-reg graph)
 304       (if (not (null? graph))
 305           (let* ((byte-cell  (find-min-neighbours graph))
 306                  (neighbours (byte-cell-interferes-with byte-cell)))
 307             (let ((new-graph (remove byte-cell graph)))
 308               (delete byte-cell neighbours)
 309               (alloc-reg new-graph)
 310               (undelete byte-cell neighbours))
 311             (if (not (byte-cell-adr byte-cell))
 312                 (color byte-cell)))))
 313
 314     ;; cache the number of neighbours
 315     (for-each (lambda (cell)
 316                 (byte-cell-nb-neighbours-set!
 317                  cell (set-length (byte-cell-interferes-with cell))))
 318               all-live)
 319
 320     (pp register-allocation:)
 321     (time (alloc-reg all-live))
 322     (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))