src/compiler/ir2opt.lisp

   1 ;;;; This file implements some optimisations at the IR2 level.
   2 ;;;; Currently, the pass converts branches to conditional moves,
   3 ;;;; deletes subsequently dead blocks and then reoptimizes jumps.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!C")
  15
  16 ;;; We track pred/succ info at the IR2-block level, extrapolating
  17 ;;; most of the data from IR1 to initialise.
  18 (declaim (type hash-table *2block-pred* *2block-succ* *label-2block*))
  19 (defvar *2block-pred*)
  20 (defvar *2block-succ*)
  21 (defvar *label-2block*)
  22
  23 (defun initialize-ir2-blocks-flow-info (component)
  24   (labels ((block-last-2block (block)
  25              (declare (type cblock block))
  26              (do ((2block (block-info block)
  27                     (ir2-block-next 2block)))
  28                  (nil)
  29                (let ((next (ir2-block-next 2block)))
  30                  (when (or (null next)
  31                            (neq block (ir2-block-block next)))
  32                    (return 2block)))))
  33            (link-2blocks (pred succ)
  34              (declare (type ir2-block pred succ))
  35              (pushnew pred (gethash succ *2block-pred*))
  36              (pushnew succ (gethash pred *2block-succ*))))
  37     (do-blocks (block component :both)
  38       (let ((succ (block-succ block))
  39             (last (block-last-2block block)))
  40         (dolist (succ succ)
  41           (link-2blocks last (block-info succ)))
  42         (do ((2block (block-info block)
  43                (ir2-block-next 2block)))
  44             ((eq 2block last))
  45           (link-2blocks 2block (ir2-block-next 2block)))))
  46     (do-ir2-blocks (2block component)
  47       (awhen (ir2-block-%label 2block)
  48         (setf (gethash it *label-2block*) 2block)))))
  49
  50 (defun update-block-succ (2block succ)
  51   (declare (type ir2-block 2block)
  52            (type list succ))
  53   (flet ((blockify (x)
  54            (etypecase x
  55              (label (or (gethash x *label-2block*)
  56                         (error "Unknown label: ~S" x)))
  57              (ir2-block x))))
  58     (setf succ (mapcar #'blockify succ)))
  59   (dolist (old (gethash 2block *2block-succ*))
  60     (setf (gethash old *2block-pred*)
  61           (remove 2block (gethash old *2block-pred*))))
  62   (setf (gethash 2block *2block-succ*) succ)
  63   (dolist (new succ)
  64     (pushnew 2block (gethash new *2block-pred*))))
  65
  66 ;;;; Conditional move insertion support code
  67 #!-sb-fluid (declaim (inline vop-name))
  68 (defun vop-name (vop &optional default)
  69   (declare (type vop vop))
  70   (let ((vop-info (vop-info vop)))
  71     (if vop-info
  72         (vop-info-name vop-info)
  73         default)))
  74
  75 (defun move-value-target (2block)
  76   (declare (type ir2-block 2block))
  77   (let* ((first  (or (ir2-block-start-vop 2block)
  78                      (return-from move-value-target)))
  79          (second (vop-next first)))
  80     (when (and (eq (vop-name first) 'move)
  81                (or (not second)
  82                    (eq (vop-name second) 'branch)))
  83       (values (tn-ref-tn (vop-args first))
  84               (tn-ref-tn (vop-results first))))))
  85
  86 ;; A conditional jump may be converted to a conditional move if
  87 ;; both branches move a value to the same TN and then continue
  88 ;; execution in the same successor block.
  89 ;;
  90 ;; The label argument is used to return possible value TNs in
  91 ;; the right order (first TN if the branch would have been taken,
  92 ;; second otherwise)
  93 (defun cmovp (label a b)
  94   (declare (type label label)
  95            (type cblock a b))
  96   (cond ((eq label (ir2-block-%label (block-info a))))
  97         ((eq label (ir2-block-%label (block-info b)))
  98          (rotatef a b))
  99         (t (return-from cmovp)))
 100   (let ((succ-a (block-succ a))
 101         (succ-b (block-succ b)))
 102     (unless (and (singleton-p succ-a)
 103                  (singleton-p succ-b)
 104                  (eq (car succ-a) (car succ-b)))
 105       (return-from cmovp))
 106     (multiple-value-bind (value-a target)
 107         (move-value-target (block-info a))
 108       (multiple-value-bind (value-b targetp)
 109           (move-value-target (block-info b))
 110         (and value-a value-b (eq target targetp)
 111              (values (block-label (car succ-a))
 112                      target value-a value-b))))))
 113
 114 ;; To convert a branch to a conditional move:
 115 ;; 1. Convert both possible values to the chosen common representation
 116 ;; 2. Execute the conditional VOP
 117 ;; 3. Execute the chosen conditional move VOP
 118 ;; 4. Convert the result from the common representation
 119 ;; 5. Jump to the successor
 120 #!-sb-fluid (declaim (inline convert-one-cmov))
 121 (defun convert-one-cmov (cmove-vop
 122                          value-if arg-if
 123                          value-else arg-else
 124                          target res
 125                          flags info
 126                          label
 127                          vop node 2block)
 128   (delete-vop vop)
 129   (flet ((load-and-coerce (dst src)
 130            (when (and dst (neq dst src))
 131              (emit-and-insert-vop node 2block
 132                                   (template-or-lose 'move)
 133                                   (reference-tn src nil)
 134                                   (reference-tn dst t)
 135                                   (ir2-block-last-vop 2block)))))
 136     (load-and-coerce arg-if   value-if)
 137     (load-and-coerce arg-else value-else))
 138   (emit-template node 2block (template-or-lose cmove-vop)
 139                  (reference-tn-list (remove nil (list arg-if arg-else))
 140                                     nil)
 141                  (reference-tn res t)
 142                  (list* flags info))
 143   (emit-move node 2block res target)
 144   (vop branch node 2block label)
 145   (update-block-succ 2block (list label)))
 146
 147 ;; Since conditional branches are always at the end of blocks,
 148 ;; it suffices to look at the last VOP in each block.
 149 (defun maybe-convert-one-cmov (2block)
 150   (let* ((block (ir2-block-block 2block))
 151          (succ (block-succ block))
 152          (a    (first succ))
 153          (b    (second succ))
 154          (vop  (or (ir2-block-last-vop 2block)
 155                    (return-from maybe-convert-one-cmov)))
 156          (node (vop-node vop)))
 157     (unless (eq (vop-name vop) 'branch-if)
 158       (return-from maybe-convert-one-cmov))
 159     (destructuring-bind (jump-target flags not-p) (vop-codegen-info vop)
 160       (multiple-value-bind (label target value-a value-b)
 161           (cmovp jump-target a b)
 162         (unless label
 163           (return-from maybe-convert-one-cmov))
 164         (multiple-value-bind (cmove-vop arg-a arg-b res info)
 165             (convert-conditional-move-p node target value-a value-b)
 166           (unless cmove-vop
 167             (return-from maybe-convert-one-cmov))
 168           (when not-p
 169             (rotatef value-a value-b)
 170             (rotatef arg-a arg-b))
 171           (convert-one-cmov cmove-vop value-a arg-a
 172                                       value-b arg-b
 173                                       target  res
 174                                       flags info
 175                             label vop node 2block))))))
 176
 177 (defun convert-cmovs (component)
 178   (do-ir2-blocks (2block component (values))
 179     (maybe-convert-one-cmov 2block)))
 180
 181 (defun delete-unused-ir2-blocks (component)
 182   (declare (type component component))
 183   (let ((live-2blocks (make-hash-table)))
 184     (labels ((mark-2block (2block)
 185                (declare (type ir2-block 2block))
 186                (when (gethash 2block live-2blocks)
 187                  (return-from mark-2block))
 188                (setf (gethash 2block live-2blocks) t)
 189                (map nil #'mark-2block (gethash 2block *2block-succ*))))
 190       (mark-2block (block-info (component-head component))))
 191
 192     (flet ((delete-2block (2block)
 193              (declare (type ir2-block 2block))
 194              (do ((vop (ir2-block-start-vop 2block)
 195                     (vop-next vop)))
 196                  ((null vop))
 197                (delete-vop vop))))
 198       (do-ir2-blocks (2block component (values))
 199         (unless (gethash 2block live-2blocks)
 200           (delete-2block 2block))))))
 201
 202 (defun delete-fall-through-jumps (component)
 203   (flet ((jump-falls-through-p (2block)
 204            (let* ((last   (or (ir2-block-last-vop 2block)
 205                               (return-from jump-falls-through-p nil)))
 206                   (target (first (vop-codegen-info last))))
 207              (unless (eq (vop-name last) 'branch)
 208                (return-from jump-falls-through-p nil))
 209              (do ((2block (ir2-block-next 2block)
 210                     (ir2-block-next 2block)))
 211                  ((null 2block) nil)
 212                (cond ((ir2-block-%trampoline-label 2block)
 213                       (return nil))
 214                      ((eq target (ir2-block-%label 2block))
 215                       (return t))
 216                      ((ir2-block-start-vop 2block)
 217                       (return nil)))))))
 218     ;; Walk the blocks in reverse emission order to catch jumps
 219     ;; that fall-through only once another jump is deleted
 220     (let ((last-2block
 221            (do-ir2-blocks (2block component (aver nil))
 222              (when (null (ir2-block-next 2block))
 223                (return 2block)))))
 224       (do ((2block last-2block
 225              (ir2-block-prev 2block)))
 226           ((null 2block)
 227              (values))
 228         (when (jump-falls-through-p 2block)
 229           (delete-vop (ir2-block-last-vop 2block)))))))
 230
 231 (defun ir2-optimize (component)
 232   (let ((*2block-pred*  (make-hash-table))
 233         (*2block-succ*  (make-hash-table))
 234         (*label-2block* (make-hash-table)))
 235     (initialize-ir2-blocks-flow-info component)
 236
 237     (convert-cmovs component)
 238     (delete-unused-ir2-blocks component)
 239     (delete-fall-through-jumps component))
 240   (values))