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              (let ((end  (ir2-block-last-vop 2block))
 132                    (move (template-or-lose 'move)))
 133                (multiple-value-bind (first last)
 134                    (funcall (template-emit-function move) node 2block
 135                             move (reference-tn src nil)
 136                             (reference-tn dst t))
 137                  (insert-vop-sequence first last 2block end))))))
 138     (load-and-coerce arg-if   value-if)
 139     (load-and-coerce arg-else value-else))
 140   (emit-template node 2block (template-or-lose cmove-vop)
 141                  (reference-tn-list (remove nil (list arg-if arg-else))
 142                                     nil)
 143                  (reference-tn res t)
 144                  (list* flags info))
 145   (emit-move node 2block res target)
 146   (vop branch node 2block label)
 147   (update-block-succ 2block (list label)))
 148
 149 ;; Since conditional branches are always at the end of blocks,
 150 ;; it suffices to look at the last VOP in each block.
 151 (defun maybe-convert-one-cmov (2block)
 152   (let* ((block (ir2-block-block 2block))
 153          (succ (block-succ block))
 154          (a    (first succ))
 155          (b    (second succ))
 156          (vop  (or (ir2-block-last-vop 2block)
 157                    (return-from maybe-convert-one-cmov)))
 158          (node (vop-node vop)))
 159     (unless (eq (vop-name vop) 'branch-if)
 160       (return-from maybe-convert-one-cmov))
 161     (destructuring-bind (jump-target flags not-p) (vop-codegen-info vop)
 162       (multiple-value-bind (label target value-a value-b)
 163           (cmovp jump-target a b)
 164         (unless label
 165           (return-from maybe-convert-one-cmov))
 166         (multiple-value-bind (cmove-vop arg-a arg-b res info)
 167             (convert-conditional-move-p node target value-a value-b)
 168           (unless cmove-vop
 169             (return-from maybe-convert-one-cmov))
 170           (when not-p
 171             (rotatef value-a value-b)
 172             (rotatef arg-a arg-b))
 173           (convert-one-cmov cmove-vop value-a arg-a
 174                                       value-b arg-b
 175                                       target  res
 176                                       flags info
 177                             label vop node 2block))))))
 178
 179 (defun convert-cmovs (component)
 180   (do-ir2-blocks (2block component (values))
 181     (maybe-convert-one-cmov 2block)))
 182
 183 (defun delete-unused-ir2-blocks (component)
 184   (declare (type component component))
 185   (let ((live-2blocks (make-hash-table)))
 186     (labels ((mark-2block (2block)
 187                (declare (type ir2-block 2block))
 188                (when (gethash 2block live-2blocks)
 189                  (return-from mark-2block))
 190                (setf (gethash 2block live-2blocks) t)
 191                (map nil #'mark-2block (gethash 2block *2block-succ*))))
 192       (mark-2block (block-info (component-head component))))
 193
 194     (flet ((delete-2block (2block)
 195              (declare (type ir2-block 2block))
 196              (do ((vop (ir2-block-start-vop 2block)
 197                     (vop-next vop)))
 198                  ((null vop))
 199                (delete-vop vop))))
 200       (do-ir2-blocks (2block component (values))
 201         (unless (gethash 2block live-2blocks)
 202           (delete-2block 2block))))))
 203
 204 (defun delete-fall-through-jumps (component)
 205   (flet ((jump-falls-through-p (2block)
 206            (let* ((last   (or (ir2-block-last-vop 2block)
 207                               (return-from jump-falls-through-p nil)))
 208                   (target (first (vop-codegen-info last))))
 209              (unless (eq (vop-name last) 'branch)
 210                (return-from jump-falls-through-p nil))
 211              (do ((2block (ir2-block-next 2block)
 212                     (ir2-block-next 2block)))
 213                  ((null 2block) nil)
 214                (cond ((ir2-block-%trampoline-label 2block)
 215                       (return nil))
 216                      ((eq target (ir2-block-%label 2block))
 217                       (return t))
 218                      ((ir2-block-start-vop 2block)
 219                       (return nil)))))))
 220     ;; Walk the blocks in reverse emission order to catch jumps
 221     ;; that fall-through only once another jump is deleted
 222     (let ((last-2block
 223            (do-ir2-blocks (2block component (aver nil))
 224              (when (null (ir2-block-next 2block))
 225                (return 2block)))))
 226       (do ((2block last-2block
 227              (ir2-block-prev 2block)))
 228           ((null 2block)
 229              (values))
 230         (when (jump-falls-through-p 2block)
 231           (delete-vop (ir2-block-last-vop 2block)))))))
 232
 233 (defun ir2-optimize (component)
 234   (let ((*2block-pred*  (make-hash-table))
 235         (*2block-succ*  (make-hash-table))
 236         (*label-2block* (make-hash-table)))
 237     (initialize-ir2-blocks-flow-info component)
 238
 239     (convert-cmovs component)
 240     (delete-unused-ir2-blocks component)
 241     (delete-fall-through-jumps component))
 242   (values))