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 (define (interference-graph cfg)
   7
   8   (define (analyze-liveness cfg)
   9     (define changed? #t)
  10     (define (instr-analyze-liveness instr live-after)
  11       (let ((live-before
  12              (cond
  13
  14               ((call-instr? instr)
  15                (let ((def-proc (call-instr-def-proc instr)))
  16                  (if (and (not (set-empty? live-after))
  17                           (not (set-equal?
  18                                 (set-intersection
  19                                  (def-procedure-live-after-calls def-proc)
  20                                  live-after)
  21                                 live-after)))
  22                      (begin
  23                        (set! changed? #t)
  24                        (set-union! (def-procedure-live-after-calls def-proc)
  25                                    live-after)))
  26                  (let ((live
  27                         (set-union
  28                          (set-union-multi
  29                           (map (lambda (def-var)
  30                                  (list->set
  31                                   (value-bytes (def-variable-value def-var))))
  32                                (def-procedure-params def-proc)))
  33                          (set-diff
  34                           live-after
  35                           (list->set
  36                            (value-bytes (def-procedure-value def-proc)))))))
  37                    (if (bb? (def-procedure-entry def-proc))
  38                        (set-intersection ;; TODO disabling this branch saves around 12 bytes
  39                         (bb-live-before (def-procedure-entry def-proc))
  40                         live)
  41                        live))))
  42
  43               ((return-instr? instr)
  44                (let ((def-proc (return-instr-def-proc instr)))
  45                  (let ((live
  46                         (if (def-procedure? def-proc)
  47                             (def-procedure-live-after-calls def-proc)
  48                             (list->set (value-bytes def-proc)))))
  49                    (set! live-after live)
  50                    live)))
  51
  52               (else
  53                (let* ((src1 (instr-src1 instr))
  54                       (src2 (instr-src2 instr))
  55                       (dst  (instr-dst instr))
  56                       (use  (if (byte-cell? src1)
  57                                 (if (byte-cell? src2)
  58                                     (set-add (new-set src1) src2)
  59                                     (new-set src1))
  60                                 (if (byte-cell? src2)
  61                                     (new-set src2)
  62                                     (new-empty-set))))
  63                       (def  (if (byte-cell? dst)
  64                                 (new-set dst)
  65                                 (new-empty-set))))
  66                  (if #f
  67                      ;; (and (byte-cell? dst) ; dead instruction?
  68                      ;;      (not (set-member? live-after dst))
  69                      ;;      (not (and (byte-cell? dst) (byte-cell-adr dst))))
  70                      live-after
  71                      (set-union use
  72                                 (set-diff live-after def))))))))
  73
  74         (instr-live-before-set! instr live-before)
  75         (instr-live-after-set!  instr live-after)
  76         live-before))
  77     (define (bb-analyze-liveness bb)
  78       (let loop ((rev-instrs (bb-rev-instrs bb))
  79                  (live-after (set-union-multi
  80                               (map bb-live-before (bb-succs bb)))))
  81         (if (null? rev-instrs)
  82             (if (not (set-equal? live-after (bb-live-before bb)))
  83                 (begin (set! changed? #t)
  84                        (bb-live-before-set! bb live-after)))
  85             (let* ((instr (car rev-instrs))
  86                    (live-before (instr-analyze-liveness instr live-after)))
  87               (loop (cdr rev-instrs)
  88                     live-before)))))
  89     (let loop ()
  90       (if changed?
  91           (begin (set! changed? #f)
  92                  (for-each bb-analyze-liveness (cfg-bbs cfg))
  93                  (loop)))))
  94
  95 ;;-----------------------------------------------------------------------------
  96
  97   (define all-live (new-empty-set))
  98
  99   (define (bb-interference-graph bb)
 100
 101     (define (interfere x y)
 102       (if (not (set-member? (byte-cell-interferes-with y) x)) ;; TODO is this check worth it ?
 103           (begin (set-add!  (byte-cell-interferes-with x) y)
 104                  (set-add!  (byte-cell-interferes-with y) x))))
 105
 106     (define (interfere-pairwise live)
 107       (set-union! all-live live)
 108       (set-for-each (lambda (x)
 109                       (set-for-each (lambda (y)
 110                                       (if (not (eq? x y)) (interfere x y)))
 111                                     live))
 112                     live))
 113
 114     (define (instr-interference-graph instr)
 115       (let ((dst (instr-dst instr)))
 116         (if (byte-cell? dst)
 117             (let ((src1 (instr-src1 instr))
 118                   (src2 (instr-src2 instr)))
 119               (if (and (byte-cell? src1) (not (eq? dst src1))) ;; FOO not sure this fixes anything, but if I remove it, loops infinitely in shl16 (which does no shifting) problem is probably elsewhere, though
 120                   (begin (set-add! (byte-cell-coalesceable-with dst) src1)
 121                          (set-add! (byte-cell-coalesceable-with src1) dst)))
 122               (if (and (byte-cell? src2) (not (eq? dst src2)))
 123                   (begin (set-add! (byte-cell-coalesceable-with dst) src2)
 124                          (set-add! (byte-cell-coalesceable-with src2) dst)))
 125               (interfere-pairwise (set-add (instr-live-after instr) dst)))))
 126       (interfere-pairwise (instr-live-before instr)))
 127     (for-each instr-interference-graph (bb-rev-instrs bb)))
 128
 129   (pp analyse-liveness:)
 130   (time (analyze-liveness cfg))
 131
 132   (pp interference-graph:)
 133   (time (for-each bb-interference-graph (cfg-bbs cfg)))
 134
 135   all-live)
 136
 137 ;;-----------------------------------------------------------------------------
 138
 139 (define (delete byte-cell1 neighbours)
 140   (set-for-each (lambda (byte-cell2)
 141                   (set-remove! (byte-cell-interferes-with byte-cell2)
 142                                byte-cell1))
 143                 neighbours))
 144 (define (undelete byte-cell1 neighbours)
 145   (set-for-each (lambda (byte-cell2)
 146                   (set-add! (byte-cell-interferes-with byte-cell2)
 147                             byte-cell1))
 148                 neighbours))
 149
 150 (define (coalesce graph)
 151   (if coalesce?
 152       (keep
 153        (lambda (byte-cell)
 154          (let* ((coalesceable-with   (byte-cell-coalesceable-with byte-cell))
 155                 (old-neighbours      (byte-cell-interferes-with   byte-cell))
 156                 (coalesce-candidates (set-diff coalesceable-with
 157                                                old-neighbours)))
 158            (if (or (byte-cell-adr byte-cell) ; in a special register
 159                    (set-empty? coalesce-candidates))
 160                #t ;; keep it
 161                ;; coalesce byte-cell with another cell
 162                (let loop ((l (set->list coalesce-candidates)))
 163                  (if (null? l)
 164                      #t ; can't coalesce, keep
 165                      (let ((c (car l)))
 166                        ;; don't coalesce with a special register
 167                        (if (byte-cell-adr c)
 168                            (loop (cdr l))
 169                            (let ((c-neighbours (byte-cell-interferes-with c))
 170                                  (c-coalesced  (byte-cell-coalesced-with  c)))
 171                              ;; remove all references to byte-cell and replace
 172                              ;; them with references to c
 173                              (set-union! c-neighbours old-neighbours)
 174                              (undelete   c            old-neighbours)
 175                              (delete     byte-cell    old-neighbours)
 176                              (set-union! c-coalesced
 177                                          (byte-cell-coalesced-with byte-cell))
 178                              (set-for-each
 179                               (lambda (cell)
 180                                 (let ((s (byte-cell-coalesceable-with cell)))
 181                                   (set-remove! s byte-cell)))
 182                               coalesceable-with)
 183                              (byte-cell-coalesceable-with-set! byte-cell
 184                                                                (new-empty-set))
 185                              (byte-cell-interferes-with-set!   byte-cell
 186                                                                (new-empty-set))
 187                              (set-add! c-coalesced byte-cell)
 188                              #f))))))))
 189        graph)
 190       graph))
 191
 192 ;;-----------------------------------------------------------------------------
 193
 194 (define register-table (make-table))
 195 (define (allocate-registers cfg)
 196   (let ((all-live (coalesce (set->list (interference-graph cfg))))
 197         (max-adr  0)) ; to know how much ram we need
 198
 199     (define (color byte-cell)
 200       (define (set-register-table cell adr)
 201         (if #f (not (string=? (byte-cell-name cell) "__tmp")) ;; FOO DEBUG
 202             (let ((adr (if (and (> adr #x5F) (< adr #xF60)) ; not in bank 0 ;; TODO have a function for that
 203                            (+ adr #xa0)
 204                            adr)))
 205               (table-set! register-table
 206                           adr
 207                           (cons (cons (byte-cell-bb   cell)
 208                                       (byte-cell-name cell))
 209                                 (table-ref register-table adr '()))))))
 210       (let ((neighbours (byte-cell-interferes-with byte-cell)))
 211         (let loop1 ((adr 0))
 212           (if (and memory-divide ; the user wants his own zone
 213                    (>= adr memory-divide)) ; and we'd use it
 214               (error "register allocation would cross the memory divide") ;; TODO fallback ?
 215               (let loop2 ((lst (set->list neighbours))) ;; TODO keep using sets, but not urgent, it's not a bottleneck
 216                 (if (null? lst)
 217                     (begin (byte-cell-adr-set! byte-cell adr)
 218                            (set-register-table byte-cell adr)
 219                            (set-for-each
 220                             (lambda (cell)
 221                               (byte-cell-adr-set! cell adr)
 222                               (set-register-table cell adr))
 223                             (byte-cell-coalesced-with byte-cell)))
 224                     (if (= adr (byte-cell-adr (car lst)))
 225                         (loop1 (+ adr 1))
 226                         (loop2 (cdr lst))))))
 227           (set! max-adr (max max-adr adr)))))
 228
 229     (define (find-min-neighbours graph)
 230       (let loop ((lst graph) (m #f) (byte-cell #f))
 231         (if (null? lst)
 232             byte-cell
 233             (let* ((x (car lst))
 234                    (n (set-length (byte-cell-interferes-with x))))
 235               (if (or (not m) (< n m))
 236                   (loop (cdr lst) n x)
 237                   (loop (cdr lst) m byte-cell))))))
 238
 239     (define (alloc-reg graph)
 240       (if (not (null? graph))
 241           (let* ((byte-cell (find-min-neighbours graph))
 242                  (neighbours (byte-cell-interferes-with byte-cell)))
 243             (let ((new-graph (remove byte-cell graph)))
 244               (delete byte-cell neighbours)
 245               (alloc-reg new-graph)
 246               (undelete byte-cell neighbours))
 247             (if (not (byte-cell-adr byte-cell))
 248                 (color byte-cell)))))
 249
 250     (pp register-allocation:)
 251     (time (alloc-reg all-live)) ;; TODO convert find-min-neighbours and alloc-reg to use tables, not urgent since it's not a bottleneck
 252     (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))