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