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