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
  88 ;------------------------------------------------------------------------------
  89
  90 (define (cfg->vector cfg)
  91   (let ((vect (make-vector (cfg-next-label-num cfg) #f)))
  92     (for-each (lambda (bb)
  93                 (vector-set! vect (bb-label-num bb) bb))
  94               (cfg-bbs cfg))
  95     vect))
  96
  97 (define (remove-branch-cascades-and-dead-code cfg)
  98   (let ((bbs-vector (cfg->vector cfg)))
  99
 100     (define (chase-branch-cascade bb seen)
 101       (if (memq bb seen)
 102           bb
 103           (let* ((rev-instrs (bb-rev-instrs bb))
 104                  (last (car rev-instrs)))
 105             (if (null? (cdr rev-instrs))
 106
 107                 (cond ((eq? (instr-id last) 'goto)
 108                        (let ((old-dest
 109                               (car (bb-succs bb))))
 110                          (let ((new-dest
 111                                 (chase-branch-cascade old-dest
 112                                                       (cons bb seen))))
 113                            new-dest)))
 114                       (else
 115                        bb))
 116
 117                 bb))))
 118
 119     (define (bb-process bb)
 120       (let* ((seen
 121               (list bb))
 122              (old-succs
 123               (bb-succs bb))
 124              (new-succs
 125               (map (lambda (x) (chase-branch-cascade x seen)) old-succs)))
 126           (for-each (lambda (old-dest new-dest)
 127                       (if (not (eq? old-dest new-dest))
 128                           (begin
 129                             (bb-succs-set! bb (replace old-dest new-dest (bb-succs bb)))
 130                             (bb-preds-set! old-dest
 131                                            (remove bb (bb-preds old-dest)))
 132                             (bb-preds-set! new-dest
 133                                            (cons bb (bb-preds old-dest))))))
 134                     old-succs
 135                     new-succs)))
 136
 137     (for-each bb-process (cfg-bbs cfg))))
 138
 139 ;------------------------------------------------------------------------------
 140
 141 ;; remove conditions whose 2 destination branches are the same, and replaces
 142 ;; them with simple jumps
 143 (define (remove-converging-branches cfg)
 144
 145   (define (bb-process bb)
 146     (let ((instrs (bb-rev-instrs bb))
 147           (succs  (bb-succs bb)))
 148       (if (and (memq (instr-id (car instrs)) conditional-instrs) ; conditional
 149                (>= (length succs) 2)
 150                (eq? (car succs) (cadr succs))) ; both destinations are the same
 151           (bb-rev-instrs-set! bb (cons (new-instr 'goto #f #f #f)
 152                                        (cdr instrs))))))
 153
 154   (for-each bb-process (cfg-bbs cfg)))
 155
 156 ;------------------------------------------------------------------------------
 157
 158 ;; removes dead instructions (instructions after a return or after all jumps)
 159 (define (remove-dead-instructions cfg)
 160
 161   (define (bb-process bb)
 162     ;; since instructions are in erverse order, loop until we find a jump,
 163     ;; and keep everything after
 164     (let loop ((instrs (reverse (bb-rev-instrs bb)))
 165                (new-instrs '()))
 166       (if (null? instrs)
 167           (error "no jump in the bb:" bb))
 168       (let* ((head (car instrs))
 169              (op   (instr-id head)))
 170         (if (or (eq? op 'return)
 171                 (eq? op 'goto)
 172                 (memq op conditional-instrs))
 173             (bb-rev-instrs-set! bb (cons head new-instrs))
 174             (loop (cdr instrs)
 175                   (cons head new-instrs))))))
 176
 177   (for-each bb-process (cfg-bbs cfg)))