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                            ;; (if (not (eq? old-dest new-dest)) ;; TODO this seems to be a shortcut, and it broke a few things, so removed
 114                            ;;      (begin
 115                            ;; (pp (list "CASCADE" (bb-label-num bb)))
 116                            ;; (bb-succs-set! bb
 117                            ;; (remove old-dest (bb-succs bb)))
 118                            ;;  (bb-preds-set! old-dest
 119                            ;;  (remove bb (bb-preds old-dest)))))
 120                            new-dest)))
 121                       (else
 122                        bb))
 123
 124                 bb))))
 125
 126     (define (bb-process bb)
 127       (let* ((seen
 128               (list bb))
 129              (old-succs
 130               (bb-succs bb))
 131              (new-succs
 132               (map (lambda (x) (chase-branch-cascade x seen)) old-succs)))
 133           (for-each (lambda (old-dest new-dest)
 134                       (if (not (eq? old-dest new-dest))
 135                           (begin
 136                             (bb-succs-set! bb (replace old-dest new-dest (bb-succs bb)))
 137                             (bb-preds-set! old-dest
 138                                            (remove bb (bb-preds old-dest)))
 139                             (bb-preds-set! new-dest
 140                                            (cons bb (bb-preds old-dest))))))
 141                     old-succs
 142                     new-succs)))
 143
 144     (for-each bb-process (cfg-bbs cfg))))
 145
 146 ;------------------------------------------------------------------------------
 147
 148 ;; remove conditions whose 2 destination branches are the same, and replaces
 149 ;; them with simple jumps
 150 (define (remove-converging-branches cfg)
 151
 152   (define (bb-process bb)
 153     (let ((instrs (bb-rev-instrs bb))
 154           (succs  (bb-succs bb)))
 155       (if (and (memq (instr-id (car instrs)) conditional-instrs) ; conditional
 156                (>= (length succs) 2)
 157                (eq? (car succs) (cadr succs))) ; both destinations are the same
 158           (bb-rev-instrs-set! bb (cons (new-instr 'goto #f #f #f)
 159                                        (cdr instrs))))))
 160
 161   (for-each bb-process (cfg-bbs cfg)))
 162
 163 ;------------------------------------------------------------------------------
 164
 165 ;; removes dead instructions (instructions after a return or after all jumps)
 166 (define (remove-dead-instructions cfg) ;; TODO was not tested thoroughly
 167
 168   (define (bb-process bb)
 169     (let loop ((instrs (reverse (bb-rev-instrs bb)))
 170                (new-instrs '()))
 171       (let* ((head (car instrs))
 172              (op   (instr-id head)))
 173         (if (or (eq? op 'return)
 174                 (eq? op 'goto)
 175                 (memq op conditional-instrs))
 176             (bb-rev-instrs-set! bb (cons head new-instrs))
 177             (loop (cdr instrs)
 178                   (cons head new-instrs))))))
 179
 180   (for-each bb-process (cfg-bbs cfg)))