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               ((call-instr? instr)
  14                (let ((def-proc (call-instr-def-proc instr)))
  15                  (if (not (set-empty? live-after))
  16                      (begin
  17                        (set! changed #t)
  18                        (set-union! (def-procedure-live-after-calls def-proc)
  19                                    live-after)))
  20                  (let ((live
  21                         (set-union
  22                          (set-union-multi
  23                           (map (lambda (def-var)
  24                                  (list->set
  25                                   (value-bytes (def-variable-value def-var))))
  26                                (def-procedure-params def-proc)))
  27                          (set-diff
  28                           live-after
  29                           (list->set
  30                            (value-bytes (def-procedure-value def-proc)))))))
  31                    (if (bb? (def-procedure-entry def-proc))
  32                        (set-intersection
  33                         (bb-live-before (def-procedure-entry def-proc))
  34                         live)
  35                        live))))
  36               ((return-instr? instr)
  37                (let ((def-proc (return-instr-def-proc instr)))
  38                  (let ((live
  39                         (if (def-procedure? def-proc)
  40                             (def-procedure-live-after-calls def-proc)
  41                             (list->set (value-bytes def-proc)))))
  42                    (set! live-after live)
  43                    live)))
  44               (else
  45                (let* ((src1 (instr-src1 instr))
  46                       (src2 (instr-src2 instr))
  47                       (dst  (instr-dst instr))
  48                       (use  (if (byte-cell? src1)
  49                                 (if (byte-cell? src2)
  50                                     (set-add (new-set src1) src2)
  51                                     (new-set src1))
  52                                 (if (byte-cell? src2)
  53                                     (new-set src2)
  54                                     (new-empty-set))))
  55                       (def  (if (byte-cell? dst)
  56                                 (new-set dst)
  57                                 (new-empty-set))))
  58                  (if #f
  59                      ;; (and (byte-cell? dst) ; dead instruction?
  60                      ;;      (not (set-member? live-after dst))
  61                      ;;      (not (and (byte-cell? dst) (byte-cell-adr dst))))
  62                      live-after
  63                      (set-union use
  64                                 (set-diff live-after def))))))))
  65         (instr-live-before-set! instr live-before)
  66         (instr-live-after-set!  instr live-after)
  67         live-before))
  68     (define (bb-analyze-liveness bb)
  69       (let loop ((rev-instrs (bb-rev-instrs bb))
  70                  (live-after (set-union-multi
  71                               (map bb-live-before (bb-succs bb)))))
  72         (if (null? rev-instrs)
  73             (if (not (set-equal? live-after (bb-live-before bb)))
  74                 (begin (set! changed? #t)
  75                        (bb-live-before-set! bb live-after)))
  76             (let* ((instr (car rev-instrs))
  77                    (live-before (instr-analyze-liveness instr live-after)))
  78               (loop (cdr rev-instrs)
  79                     live-before)))))
  80     (let loop ()
  81       (if changed?
  82           (begin (set! changed? #f)
  83                  (for-each bb-analyze-liveness (cfg-bbs cfg))
  84                  (loop)))))
  85
  86   (define all-live (new-empty-set))
  87   (define (bb-interference-graph bb)
  88     (define (interfere x y)
  89       (if (not (set-member? (byte-cell-interferes-with y) x))
  90           (begin (set-add! (byte-cell-interferes-with x) y)
  91                  (set-add! (byte-cell-interferes-with y) x))))
  92     (define (interfere-pairwise live)
  93       (set-union! all-live live) ;; TODO build the live set only once, if not a set already
  94       (set-for-each ;; TODO for each cell in live, do the union of live, diff itself, if live is not a set, we win so we can iterate on something better than a hash table
  95        ;; TODO since all true variables will be in the low numbers and all temps in the high numbers, we can have sparse bit vectors (if all below n is 0, don't store it) and save (or even have a bit vector that can store data by chunks, leaving empty space)
  96        (lambda (x)
  97          (set-for-each (lambda (y) (if (not (eq? x y)) (interfere x y)))
  98                        live))
  99        live))
 100     (define (instr-interference-graph instr)
 101       (let ((dst (instr-dst instr)))
 102         (if (byte-cell? dst)
 103             (let ((src1 (instr-src1 instr))
 104                   (src2 (instr-src2 instr)))
 105               (if (byte-cell? src1)
 106                   (begin (set-add! (byte-cell-coalesceable-with dst) src1)
 107                          (set-add! (byte-cell-coalesceable-with src1) dst)))
 108               (if (byte-cell? src2)
 109                   (begin (set-add! (byte-cell-coalesceable-with dst) src2)
 110                          (set-add! (byte-cell-coalesceable-with src2) dst)))
 111               (interfere-pairwise (set-add (instr-live-after instr) dst)))))
 112       (interfere-pairwise (instr-live-before instr)))
 113     (for-each instr-interference-graph (bb-rev-instrs bb)))
 114
 115   (pp analyse-liveness:)
 116   (time (analyze-liveness cfg))
 117
 118   (pp interference-graph:)
 119   (time (for-each bb-interference-graph (cfg-bbs cfg)))
 120
 121   all-live)
 122
 123 ;;-----------------------------------------------------------------------------
 124
 125 (define (allocate-registers cfg)
 126   (let ((all-live (interference-graph cfg))
 127         (max-adr  0)) ; to know how much ram we need
 128
 129     (define (color byte-cell)
 130       (let (;; (coalesce-candidates ; TODO right now, no coalescing is done
 131 ;;              (set-filter byte-cell-adr
 132 ;;                          (set-diff (byte-cell-coalesceable-with byte-cell)
 133 ;;                                 (byte-cell-interferes-with byte-cell))))
 134             )
 135 ;;         '
 136 ;;         (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
 137 ;;                   coalesce-candidates
 138 ;;                                         ;                  interferes-with: (byte-cell-interferes-with byte-cell)
 139 ;;                                         ;                  coalesceable-with: (byte-cell-coalesceable-with byte-cell)
 140 ;;                   ))
 141
 142         (if #f #;(not (null? coalesce-candidates))
 143             (let ((adr (byte-cell-adr (car (set->list coalesce-candidates))))) ;; TODO have as a set all along
 144               (byte-cell-adr-set! byte-cell adr))
 145             (let ((neighbours (byte-cell-interferes-with byte-cell)))
 146               (let loop1 ((adr 0))
 147                 (if (and memory-divide ; the user wants his own zone
 148                          (>= adr memory-divide)) ; and we'd use it
 149                     (error "register allocation would cross the memory divide") ;; TODO fallback ?
 150                     (let loop2 ((lst (set->list neighbours))) ;; TODO keep using sets, but not urgent, it's not a bottleneck
 151                       (if (null? lst)
 152                           (byte-cell-adr-set! byte-cell adr)
 153                           (let ((x (car lst)))
 154                             (if (= adr (byte-cell-adr x))
 155                                 (loop1 (+ adr 1))
 156                                 (loop2 (cdr lst)))))))
 157                 (set! max-adr (max max-adr adr)))))))
 158
 159     (define (delete byte-cell1 neighbours)
 160       (set-for-each (lambda (byte-cell2)
 161                       (set-remove! (byte-cell-interferes-with byte-cell2)
 162                                    byte-cell1))
 163                     neighbours))
 164
 165     (define (undelete byte-cell1 neighbours)
 166       (set-for-each (lambda (byte-cell2)
 167                       (set-add! (byte-cell-interferes-with byte-cell2)
 168                                 byte-cell1))
 169                     neighbours))
 170
 171     (define (find-min-neighbours graph)
 172       (let loop ((lst graph) (m #f) (byte-cell #f))
 173         (if (null? lst)
 174             byte-cell
 175             (let* ((x (car lst))
 176                    (n (set-length (byte-cell-interferes-with x))))
 177               (if (or (not m) (< n m))
 178                   (loop (cdr lst) n x)
 179                   (loop (cdr lst) m byte-cell))))))
 180
 181     (define (alloc-reg graph)
 182       (if (not (null? graph))
 183           (let* ((byte-cell (find-min-neighbours graph))
 184                  (neighbours (byte-cell-interferes-with byte-cell)))
 185             (let ((new-graph (remove byte-cell graph)))
 186               (delete byte-cell neighbours)
 187               (alloc-reg new-graph)
 188               (undelete byte-cell neighbours))
 189             (if (not (byte-cell-adr byte-cell))
 190                 (color byte-cell)))))
 191
 192     (pp register-allocation:)
 193     (time (alloc-reg (set->list all-live))) ;; TODO convert find-min-neighbors and alloc-reg to use tables, not urgent since it's not a bottleneck
 194     (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))