optimizations.scm

   1 (define (analyze-liveness cfg)
   2
   3   (define changed? #t)
   4
   5   (define (instr-analyze-liveness instr live-after)
   6     (let ((live-before
   7            (cond ((call-instr? instr)
   8                   (let ((def-proc (call-instr-def-proc instr)))
   9                     (let* ((old
  10                             (def-procedure-live-after-calls def-proc))
  11                            (new
  12                             (union old
  13                                    live-after)))
  14                       (if (not (set-equal? old new))
  15                           (begin
  16                             (set! changed? #t)
  17                             (def-procedure-live-after-calls-set! def-proc new))))
  18                     (let ((live
  19                            (union
  20                             (union-multi
  21                              (map (lambda (def-var)
  22                                     (value-bytes (def-variable-value def-var)))
  23                                   (def-procedure-params def-proc)))
  24                             (diff live-after
  25                                   (value-bytes (def-procedure-value def-proc))))))
  26                       (if (bb? (def-procedure-entry def-proc))
  27                           (intersection
  28                            (bb-live-before (def-procedure-entry def-proc))
  29                            live)
  30                           live))))
  31                  ((return-instr? instr)
  32                                         ;(pp (list 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                                (value-bytes def-proc))))
  38                       (let ((live (keep byte-cell? live)))
  39                                         ;(pp (list live: live))
  40                         (set! live-after live)
  41                         live)))
  42                   )
  43                  (else
  44                                         ;(pp (list instr: instr))
  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                                       (union (list src1) (list src2))
  51                                       (list src1))
  52                                   (if (byte-cell? src2)
  53                                       (list src2)
  54                                       '())))
  55                          (def (if (byte-cell? dst)
  56                                   (list dst)
  57                                   '())))
  58                     (if #f #;(and (byte-cell? dst) ; dead instruction?
  59                              (not (memq dst live-after))
  60                              (not (and (byte-cell? dst) (byte-cell-adr dst))))
  61                         live-after
  62                         (union use (diff live-after def))))))))
  63       (instr-live-before-set! instr live-before)
  64       (instr-live-after-set! instr live-after)
  65       live-before))
  66
  67   (define (bb-analyze-liveness bb)
  68     (let loop ((rev-instrs (bb-rev-instrs bb))
  69                (live-after (union-multi (map bb-live-before (bb-succs bb)))))
  70       (if (null? rev-instrs)
  71           (if (not (set-equal? live-after (bb-live-before bb)))
  72               (begin
  73                 (set! changed? #t)
  74                 (bb-live-before-set! bb live-after)))
  75           (let* ((instr (car rev-instrs))
  76                  (live-before (instr-analyze-liveness instr live-after)))
  77             (loop (cdr rev-instrs)
  78                   live-before)))))
  79
  80   (let loop ()
  81     (if changed?
  82         (begin
  83           (set! changed? #f)
  84           (for-each bb-analyze-liveness (cfg-bbs cfg))
  85           (loop)))))
  86
  87 (define (interference-graph cfg)
  88
  89   (define all-live '())
  90
  91   (define (interfere x y)
  92     (if (not (memq x (byte-cell-interferes-with y)))
  93         (begin
  94           (byte-cell-interferes-with-set!
  95            x
  96            (cons y (byte-cell-interferes-with x)))
  97           (byte-cell-interferes-with-set!
  98            y
  99            (cons x (byte-cell-interferes-with y))))))
 100
 101   (define (interfere-pairwise live)
 102     (set! all-live (union all-live live))
 103     (for-each (lambda (x)
 104                 (for-each (lambda (y)
 105                             (if (not (eq? x y))
 106                                 (interfere x y)))
 107                           live))
 108               live))
 109
 110   (define (instr-interference-graph instr)
 111     (let ((dst (instr-dst instr)))
 112       (if (byte-cell? dst)
 113           (let ((src1 (instr-src1 instr))
 114                 (src2 (instr-src2 instr)))
 115             (if (byte-cell? src1)
 116                 (begin
 117                   (byte-cell-coalesceable-with-set!
 118                    dst
 119                    (union (byte-cell-coalesceable-with dst)
 120                           (list src1)))
 121                   (byte-cell-coalesceable-with-set!
 122                    src1
 123                    (union (byte-cell-coalesceable-with src1)
 124                           (list dst)))))
 125             (if (byte-cell? src2)
 126                 (begin
 127                   (byte-cell-coalesceable-with-set!
 128                    dst
 129                    (union (byte-cell-coalesceable-with dst)
 130                           (list src2)))
 131                   (byte-cell-coalesceable-with-set!
 132                    src2
 133                    (union (byte-cell-coalesceable-with src2)
 134                           (list dst))))))))
 135     (let ((live-before (instr-live-before instr)))
 136       (interfere-pairwise live-before)))
 137
 138   (define (bb-interference-graph bb)
 139     (for-each instr-interference-graph (bb-rev-instrs bb)))
 140
 141   (analyze-liveness cfg)
 142
 143   (for-each bb-interference-graph (cfg-bbs cfg))
 144
 145   all-live)
 146
 147 (define (allocate-registers cfg)
 148   (let ((all-live (interference-graph cfg)))
 149
 150     (define (color byte-cell)
 151       (let ((coalesce-candidates
 152              (keep byte-cell-adr
 153                    (diff (byte-cell-coalesceable-with byte-cell)
 154                          (byte-cell-interferes-with byte-cell)))))
 155         '
 156         (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
 157                   coalesce-candidates
 158 ;                  interferes-with: (byte-cell-interferes-with byte-cell)
 159 ;                  coalesceable-with: (byte-cell-coalesceable-with byte-cell)
 160 ))
 161
 162         (if #f #;(not (null? coalesce-candidates))
 163             (let ((adr (byte-cell-adr (car coalesce-candidates))))
 164               (byte-cell-adr-set! byte-cell adr))
 165             (let ((neighbours (byte-cell-interferes-with byte-cell)))
 166               (let loop1 ((adr 0))
 167                 (let loop2 ((lst neighbours))
 168                   (if (null? lst)
 169                       (byte-cell-adr-set! byte-cell adr)
 170                       (let ((x (car lst)))
 171                         (if (= adr (byte-cell-adr x))
 172                             (loop1 (+ adr 1))
 173                             (loop2 (cdr lst)))))))))))
 174
 175     (define (delete byte-cell1 neighbours)
 176       (for-each (lambda (byte-cell2)
 177                   (let ((lst (byte-cell-interferes-with byte-cell2)))
 178                     (byte-cell-interferes-with-set!
 179                      byte-cell2
 180                      (remove byte-cell1 lst))))
 181                 neighbours))
 182
 183     (define (undelete byte-cell1 neighbours)
 184       (for-each (lambda (byte-cell2)
 185                   (let ((lst (byte-cell-interferes-with byte-cell2)))
 186                     (byte-cell-interferes-with-set!
 187                      byte-cell2
 188                      (cons byte-cell1 lst))))
 189                 neighbours))
 190
 191     (define (find-min-neighbours graph)
 192       (let loop ((lst graph) (m #f) (byte-cell #f))
 193         (if (null? lst)
 194             byte-cell
 195             (let* ((x (car lst))
 196                    (n (length (byte-cell-interferes-with x))))
 197               (if (or (not m) (< n m))
 198                   (loop (cdr lst) n x)
 199                   (loop (cdr lst) m byte-cell))))))
 200
 201     (define (alloc-reg graph)
 202       (if (not (null? graph))
 203           (let* ((byte-cell (find-min-neighbours graph))
 204                  (neighbours (byte-cell-interferes-with byte-cell)))
 205             (let ((new-graph (remove byte-cell graph)))
 206               (delete byte-cell neighbours)
 207               (alloc-reg new-graph)
 208               (undelete byte-cell neighbours))
 209             (if (not (byte-cell-adr byte-cell))
 210                 (color byte-cell)))))
 211
 212     (alloc-reg all-live)))
 213
 214 ;------------------------------------------------------------------------------
 215
 216 (define (cfg->vector cfg)
 217   (let ((vect (make-vector (cfg-next-label-num cfg) #f)))
 218     (for-each (lambda (bb)
 219                 (vector-set! vect (bb-label-num bb) bb))
 220               (cfg-bbs cfg))
 221     vect))
 222
 223 (define (remove-branch-cascades-and-dead-code cfg)
 224   (let ((bbs-vector (cfg->vector cfg)))
 225
 226     (define (chase-branch-cascade bb seen)
 227       (if (memq bb seen)
 228           bb
 229           (let* ((rev-instrs (bb-rev-instrs bb))
 230                  (last (car rev-instrs)))
 231             (if (null? (cdr rev-instrs))
 232
 233                 (cond ((eq? (instr-id last) 'goto)
 234                        (let ((old-dest
 235                               (car (bb-succs bb))))
 236                          (let ((new-dest
 237                                 (chase-branch-cascade old-dest
 238                                                       (cons bb seen))))
 239                            ;; (if (not (eq? old-dest new-dest)) ;; TODO this seems to be a shortcut, and it broke a few things, so removed
 240 ;;                                (begin
 241 ;;                               (pp (list "CASCADE" (bb-label-num bb)))
 242 ;;                                  (bb-succs-set! bb
 243 ;;                                                 (remove old-dest (bb-succs bb)))
 244 ;;                                  (bb-preds-set! old-dest
 245 ;;                                                 (remove bb (bb-preds old-dest)))))
 246                            new-dest)))
 247                       (else
 248                        bb))
 249
 250                 bb))))
 251
 252     (define (bb-process bb)
 253       (let* ((seen
 254               (list bb))
 255              (old-succs
 256               (bb-succs bb))
 257              (new-succs
 258               (map (lambda (x) (chase-branch-cascade x seen)) old-succs)))
 259           (for-each (lambda (old-dest new-dest)
 260                       (if (not (eq? old-dest new-dest))
 261                           (begin
 262                             (bb-succs-set! bb (replace old-dest new-dest (bb-succs bb)))
 263                             (bb-preds-set! old-dest
 264                                            (remove bb (bb-preds old-dest)))
 265                             (bb-preds-set! new-dest
 266                                            (cons bb (bb-preds old-dest))))))
 267                     old-succs
 268                     new-succs)))
 269
 270     (for-each bb-process (cfg-bbs cfg))))
 271
 272 ;------------------------------------------------------------------------------
 273
 274 ;; remove conditions whose 2 destination branches are the same, and replaces
 275 ;; them with simple jumps
 276 (define (remove-useless-conditions cfg)
 277
 278   (define (bb-process bb)
 279     (let ((instrs (bb-rev-instrs bb))
 280           (succs  (bb-succs bb)))
 281       (if (and (memq (instr-id (car instrs)) conditional-instrs) ; conditional
 282                (>= (length succs) 2)
 283                (eq? (car succs) (cadr succs))) ; both destinations are the same
 284           (bb-rev-instrs-set! bb (cons (new-instr 'goto #f #f #f)
 285                                        (cdr instrs))))))
 286
 287   (for-each bb-process (cfg-bbs cfg)))