optimizations.scm

   1 (define (cfg->vector cfg)
   2   (let ((vect (make-vector (cfg-next-label-num cfg) #f)))
   3     (for-each (lambda (bb)
   4                 (vector-set! vect (bb-label-num bb) bb))
   5               (cfg-bbs cfg))
   6     vect))
   7
   8 (define (remove-branch-cascades-and-dead-code cfg)
   9   (let ((bbs-vector (cfg->vector cfg)))
  10
  11     (define (chase-branch-cascade bb seen)
  12       (if (memq bb seen)
  13           bb
  14           (let* ((rev-instrs (bb-rev-instrs bb))
  15                  (last (car rev-instrs)))
  16             (if (null? (cdr rev-instrs))
  17
  18                 (cond ((eq? (instr-id last) 'goto)
  19                        (let ((old-dest
  20                               (car (bb-succs bb))))
  21                          (let ((new-dest
  22                                 (chase-branch-cascade old-dest
  23                                                       (cons bb seen))))
  24                            new-dest)))
  25                       (else
  26                        bb))
  27
  28                 bb))))
  29
  30     (define (bb-process bb)
  31       (let* ((seen
  32               (list bb))
  33              (old-succs
  34               (bb-succs bb))
  35              (new-succs
  36               (map (lambda (x) (chase-branch-cascade x seen)) old-succs)))
  37           (for-each (lambda (old-dest new-dest)
  38                       (if (not (eq? old-dest new-dest))
  39                           (begin
  40                             (bb-succs-set! bb (replace old-dest new-dest (bb-succs bb)))
  41                             (bb-preds-set! old-dest
  42                                            (remove bb (bb-preds old-dest)))
  43                             (bb-preds-set! new-dest
  44                                            (cons bb (bb-preds new-dest))))))
  45                     old-succs
  46                     new-succs)))
  47
  48     (for-each bb-process (cfg-bbs cfg))))
  49
  50 ;------------------------------------------------------------------------------
  51
  52 ;; remove conditions whose 2 destination branches are the same, and replaces
  53 ;; them with simple jumps
  54 (define (remove-converging-branches cfg)
  55
  56   (define (bb-process bb)
  57     (let ((instrs (bb-rev-instrs bb))
  58           (succs  (bb-succs bb)))
  59       (if (and (memq (instr-id (car instrs)) conditional-instrs) ; conditional
  60                (>= (length succs) 2)
  61                (eq? (car succs) (cadr succs))) ; both destinations are the same
  62           (bb-rev-instrs-set! bb (cons (new-instr 'goto #f #f #f)
  63                                        (cdr instrs))))))
  64
  65   (for-each bb-process (cfg-bbs cfg)))
  66
  67 ;------------------------------------------------------------------------------
  68
  69 ;; removes dead instructions (instructions after a return or after all jumps)
  70 (define (remove-dead-instructions cfg)
  71
  72   (define (bb-process bb)
  73     ;; since instructions are in erverse order, loop until we find a jump,
  74     ;; and keep everything after
  75     (let loop ((instrs (reverse (bb-rev-instrs bb)))
  76                (new-instrs '()))
  77       (if (null? instrs)
  78           (error "no jump in the bb:" bb))
  79       (let* ((head (car instrs))
  80              (op   (instr-id head)))
  81         (if (or (memq op '(return goto branch-table branch-if-carry))
  82                 (memq op conditional-instrs))
  83             (bb-rev-instrs-set! bb (cons head new-instrs))
  84             (loop (cdr instrs)
  85                   (cons head new-instrs))))))
  86
  87   (for-each bb-process (cfg-bbs cfg)))