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) ;; FOO pc gets clobbered, it seems... (everything gets clobbered)
 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 ((c (let loop ((l (set->list coalesce-candidates)))
 163                           (if (null? l)
 164                               #f
 165                               (let ((c (car l)))
 166                                 (if (byte-cell-adr c)
 167                                     (loop (cdr l))
 168                                     c))))))
 169                  (if (not c)
 170                      #t
 171                      (let ((c-neighbours   (byte-cell-interferes-with c)))
 172                        ;; remove all references to byte-cell and add references
 173                        ;; to c instead
 174                        (set-union! c-neighbours old-neighbours)
 175                        (undelete   c            old-neighbours)
 176                        (delete     byte-cell    old-neighbours)
 177                        (set-for-each
 178                         (lambda (cell)
 179                           (let ((s (byte-cell-coalesceable-with cell)))
 180                             (set-remove! s byte-cell)
 181                             ;; (if (not (eq? cell c)) (set-add! s c)) ;; FOO disabled for now
 182                             ))
 183                         coalesceable-with)
 184                        (byte-cell-interferes-with-set!   byte-cell
 185                                                          (new-empty-set))
 186                        (byte-cell-coalesceable-with-set! byte-cell
 187                                                          (new-empty-set))
 188                        (set-add! (byte-cell-coalesced-with c) byte-cell)
 189                        #f))))))
 190        graph)
 191       graph))
 192
 193 ;;-----------------------------------------------------------------------------
 194
 195 (define register-table (make-table))
 196 (define (allocate-registers cfg)
 197   (let ((all-live (coalesce (set->list (interference-graph cfg))))
 198         (max-adr  0)) ; to know how much ram we need
 199
 200     (define (color byte-cell)
 201       (define (set-register-table cell adr)
 202         (if #f (not (string=? (byte-cell-name cell) "__tmp")) ;; TODO DEBUG
 203             (table-set! register-table
 204                         (if (and (> adr #x5F) (< adr #xF60))
 205                             ;; not in bank 0
 206                             (+ adr #xa0)
 207                             adr)
 208                         (cons (cons (byte-cell-bb   cell)
 209                                     (byte-cell-name cell))
 210                               (table-ref register-table adr '())))))
 211       (let ((neighbours (byte-cell-interferes-with byte-cell)))
 212         (let loop1 ((adr 0))
 213           (if (and memory-divide ; the user wants his own zone
 214                    (>= adr memory-divide)) ; and we'd use it
 215               (error "register allocation would cross the memory divide") ;; TODO fallback ?
 216               (let loop2 ((lst (set->list neighbours))) ;; TODO keep using sets, but not urgent, it's not a bottleneck
 217                 (if (null? lst)
 218                     (begin (byte-cell-adr-set! byte-cell adr)
 219                            (set-register-table byte-cell adr)
 220                            (set-for-each
 221                             (lambda (cell)
 222                               (byte-cell-adr-set! cell adr)
 223                               (set-register-table cell adr))
 224                             (byte-cell-coalesced-with byte-cell)))
 225                     (if (= adr (byte-cell-adr (car lst)))
 226                         (loop1 (+ adr 1))
 227                         (loop2 (cdr lst))))))
 228           (set! max-adr (max max-adr adr)))))
 229
 230     (define (find-min-neighbours graph)
 231       (let loop ((lst graph) (m #f) (byte-cell #f))
 232         (if (null? lst)
 233             byte-cell
 234             (let* ((x (car lst))
 235                    (n (set-length (byte-cell-interferes-with x))))
 236               (if (or (not m) (< n m))
 237                   (loop (cdr lst) n x)
 238                   (loop (cdr lst) m byte-cell))))))
 239
 240     (define (alloc-reg graph)
 241       (if (not (null? graph))
 242           (let* ((byte-cell (find-min-neighbours graph))
 243                  (neighbours (byte-cell-interferes-with byte-cell)))
 244             (let ((new-graph (remove byte-cell graph)))
 245               (delete byte-cell neighbours)
 246               (alloc-reg new-graph)
 247               (undelete byte-cell neighbours))
 248             (if (not (byte-cell-adr byte-cell))
 249                 (color byte-cell)))))
 250
 251     (let loop ((l all-live)) ;; FOO DEBUG might be nice to know which bb these temporaries come from, really have a way to know where each byte cell is used
 252       (if (not (null? l))
 253           (let ((head (car l)))
 254             (if (or (string=? (byte-cell-name head) "env0$86")
 255                     (string=? (byte-cell-name head) "env1$85"))
 256                 (begin (pp (byte-cell-name head))
 257                        (for-each (lambda (x) (pp (list (byte-cell-name x) (byte-cell-bb x)))) ;; FOO does it report the right one ?
 258                                  (set->list (byte-cell-coalesced-with head)))
 259 ;;                     (let loop ((l all-live))
 260 ;;                       (if (not (null? l))
 261 ;;                           (let ((h (car l)))
 262 ;;                             (if (not (set-member? (byte-cell-interferes-with head) h))
 263 ;;                                 (pp (list N-I: (byte-cell-name h) (byte-cell-bb h)))) ;; FOO commit all changes but register-allocation.scm ALSO, I don't think it reports the right conflicts, since the reportes coalesced cells do not seem to be allocated in the same place
 264 ;;                             (loop (cdr l)))))
 265                        ))
 266 ;;          (if (not (set-empty? (set-filter (lambda (cell)
 267 ;;                                             (or (string=? (byte-cell-name cell) "env0$86")
 268 ;;                                                 (string=? (byte-cell-name cell) "env1$85")))
 269 ;;                                           (byte-cell-coalesced-with head))))
 270 ;;              (pp (list OPP: (byte-cell-name head) I: (map (lambda (x) (byte-cell-name x)) (set->list (byte-cell-coalesced-with head))))))
 271             (loop (cdr l)))))
 272
 273     (pp register-allocation:)
 274     (time (alloc-reg all-live)) ;; TODO convert find-min-neighbours and alloc-reg to use tables, not urgent since it's not a bottleneck
 275     (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))