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