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                        ;; if we find an unconditional goto, we can jump to its
  20                        ;; destination instead of this bb
  21                        (let* ((old-dest (car (bb-succs bb)))
  22                               (new-dest (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) ;; TODO does not seem to work with branch tables
  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 ;; remove instructions after a return or after all jumps
  70 (define (remove-instructions-after-branchs cfg)
  71   (define (process-bb bb)
  72     ;; since instructions are in erverse order, loop until we find a jump,
  73     ;; and keep everything after
  74     (let loop ((instrs (reverse (bb-rev-instrs bb)))
  75                (new-instrs '()))
  76       (if (null? instrs)
  77           (error "no jump in the bb:" bb))
  78       (let* ((head (car instrs))
  79              (op   (instr-id head)))
  80         (if (or (memq op '(return goto branch-table branch-if-carry))
  81                 (memq op conditional-instrs))
  82             (bb-rev-instrs-set! bb (cons head new-instrs))
  83             (loop (cdr instrs)
  84                   (cons head new-instrs))))))
  85   (for-each process-bb (cfg-bbs cfg)))