src/compiler/copyprop.lisp

   1 ;;;; This file implements the copy propagation phase of the compiler,
   2 ;;;; which uses global flow analysis to eliminate unnecessary copying
   3 ;;;; of variables.
   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 ;;; In copy propagation, we manipulate sets of TNs. We only consider
  17 ;;; TNs whose sole write is by a MOVE VOP. This allows us to use a
  18 ;;; degenerate version of reaching definitions: since each such TN has
  19 ;;; only one definition, the TN can stand for the definition. We can
  20 ;;; get away with this simplification, since the TNs that would be
  21 ;;; subject to copy propagation are nearly always single-writer
  22 ;;; (mostly temps allocated to ensure evaluation order is perserved).
  23 ;;; Only TNs written by MOVEs are interesting, since all we do with
  24 ;;; this information is delete spurious MOVEs.
  25 ;;;
  26 ;;; There are additional semantic constraints on whether a TN can be
  27 ;;; considered to be a copy. See TN-IS-A-COPY-OF.
  28 ;;;
  29 ;;; If a TN is in the IN set for a block, that TN is a copy of a TN
  30 ;;; which still has the same value it had at the time the move was
  31 ;;; done. Any reference to a TN in the IN set can be replaced with a
  32 ;;; reference to the TN moved from. When we delete all reads of such a
  33 ;;; TN, we can delete the MOVE VOP. IN is computed as the intersection
  34 ;;; of OUT for all the predecessor blocks.
  35 ;;;
  36 ;;; In this flow analysis scheme, the KILL set is the set of all
  37 ;;; interesting TNs where the copied TN is modified by the block (in
  38 ;;; any way.)
  39 ;;;
  40 ;;; GEN is the set of all interesting TNs that are copied in the block
  41 ;;; (whose write appears in the block.)
  42 ;;;
  43 ;;; OUT is (union (difference IN KILL) GEN)
  44
  45 ;;; If TN is subject to copy propagation, then return the TN it is a copy
  46 ;;; of, otherwise NIL.
  47 ;;;
  48 ;;; We also only consider TNs where neither the TN nor the copied TN
  49 ;;; are wired or restricted. If we extended the life of a wired or
  50 ;;; restricted TN, register allocation might fail, and we can't
  51 ;;; substitute arbitrary things for references to wired or restricted
  52 ;;; TNs, since the reader may be expencting the argument to be in a
  53 ;;; particular place (as in a passing location.)
  54 ;;;
  55 ;;; The TN must be a :NORMAL TN. Other TNs might have hidden
  56 ;;; references or be otherwise bizarre.
  57 ;;;
  58 ;;; A TN is also inelegible if it has interned name, policy is such
  59 ;;; that we would dump it in the debug vars, and speed is not 3.
  60 ;;;
  61 ;;; The SCs of the TN's primitive types is a subset of the SCs of the
  62 ;;; copied TN. Moves between TNs of different primitive type SCs may
  63 ;;; need to be changed into coercions, so we can't squeeze them out.
  64 ;;; The reason for testing for subset of the SCs instead of the same
  65 ;;; primitive type is that this test lets T be substituted for LIST,
  66 ;;; POSITIVE-FIXNUM for FIXNUM, etc. Note that more SCs implies fewer
  67 ;;; possible values, or a subtype relationship, since more SCs implies
  68 ;;; more possible representations.
  69 (defun tn-is-copy-of (tn)
  70   (declare (type tn tn))
  71   (declare (inline subsetp))
  72   (let ((writes (tn-writes tn)))
  73     (and (eq (tn-kind tn) :normal)
  74          (not (tn-sc tn))               ; Not wired or restricted.
  75          (and writes (null (tn-ref-next writes)))
  76          (let ((vop (tn-ref-vop writes)))
  77            (and (eq (vop-info-name (vop-info vop)) 'move)
  78                 (let ((arg-tn (tn-ref-tn (vop-args vop))))
  79                   (and (or (not (tn-sc arg-tn))
  80                            (eq (tn-kind arg-tn) :constant))
  81                        (subsetp (primitive-type-scs
  82                                  (tn-primitive-type tn))
  83                                 (primitive-type-scs
  84                                  (tn-primitive-type arg-tn)))
  85                        (let ((leaf (tn-leaf tn)))
  86                          (or (not leaf)
  87                              (not (symbol-package (leaf-name leaf)))
  88                              (policy (vop-node vop)
  89                                      (or (= speed 3) (< debug 2)))))
  90                        arg-tn)))))))
  91
  92 ;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
  93 ;;; look for MOVE vops, and then see whether the result is a eligible
  94 ;;; copy TN. To find KILL, we must look at all VOP results, seeing
  95 ;;; whether any of the reads of the written TN are copies for eligible
  96 ;;; TNs.
  97 (defun init-copy-sets (block)
  98   (declare (type cblock block))
  99   (let ((kill (make-sset))
 100         (gen (make-sset)))
 101     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
 102         ((null vop))
 103       (unless (and (eq (vop-info-name (vop-info vop)) 'move)
 104                    (let ((y (tn-ref-tn (vop-results vop))))
 105                      (when (tn-is-copy-of y)
 106                        (sset-adjoin y gen)
 107                        t)))
 108         (do ((res (vop-results vop) (tn-ref-across res)))
 109             ((null res))
 110           (let ((res-tn (tn-ref-tn res)))
 111             (do ((read (tn-reads res-tn) (tn-ref-next read)))
 112                 ((null read))
 113               (let ((read-vop (tn-ref-vop read)))
 114                 (when (eq (vop-info-name (vop-info read-vop)) 'move)
 115                   (let ((y (tn-ref-tn (vop-results read-vop))))
 116                     (when (tn-is-copy-of y)
 117                       (sset-delete y gen)
 118                       (sset-adjoin y kill))))))))))
 119
 120     (setf (block-out block) (copy-sset gen))
 121     (setf (block-kill-sset block) kill)
 122     (setf (block-gen block) gen))
 123   (values))
 124
 125 ;;; Do the flow analysis step for copy propagation on BLOCK. We rely
 126 ;;; on OUT being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE
 127 ;;; to incrementally build the union in OUT, rather than replacing OUT
 128 ;;; each time.
 129 (defun copy-flow-analysis (block)
 130   (declare (type cblock block))
 131   (let* ((pred (block-pred block))
 132          (in (copy-sset (block-out (first pred)))))
 133     (dolist (pred-block (rest pred))
 134       (sset-intersection in (block-out pred-block)))
 135     (setf (block-in block) in)
 136     (sset-union-of-difference (block-out block)
 137                               in
 138                               (block-kill-sset block))))
 139
 140 (defevent copy-deleted-move "Copy propagation deleted a move.")
 141
 142 ;;; Return true if ARG is a reference to a TN that we can copy
 143 ;;; propagate to. In addition to dealing with copy chains (as
 144 ;;; discussed below), we also discard references that are arguments
 145 ;;; to a local call, since IR2tran introduces temps in that context
 146 ;;; to preserve parallel assignment semantics.
 147 (defun ok-copy-ref (vop arg in original-copy-of)
 148   (declare (type vop vop) (type tn arg) (type sset in)
 149            (type hash-table original-copy-of))
 150   (and (sset-member arg in)
 151        (do ((original (gethash arg original-copy-of)
 152                       (gethash original original-copy-of)))
 153            ((not original) t)
 154          (unless (sset-member original in)
 155            (return nil)))
 156        (let ((info (vop-info vop)))
 157          (not (and (eq (vop-info-move-args info) :local-call)
 158                    (>= (or (position-in #'tn-ref-across arg (vop-args vop)
 159                                         :key #'tn-ref-tn)
 160                            (error "Couldn't find REF?"))
 161                        (length (template-arg-types info))))))))
 162
 163 ;;; Make use of the result of flow analysis to eliminate copies. We
 164 ;;; scan the VOPs in block, propagating copies and keeping our IN set
 165 ;;; in sync.
 166 ;;;
 167 ;;; Original-Copy-Of is an EQ hash table that we use to keep track of
 168 ;;; renamings when there are copy chains, i.e. copies of copies. When
 169 ;;; we see copy of a copy, we enter the first copy in the table with
 170 ;;; the second copy as a key. When we see a reference to a TN in a
 171 ;;; copy chain, we can only substitute the first copied TN for the
 172 ;;; reference when all intervening copies in the copy chain are also
 173 ;;; available. Otherwise, we just leave the reference alone. It is
 174 ;;; possible that we might have been able to reference one of the
 175 ;;; intermediate copies instead, but that copy might have already been
 176 ;;; deleted, since we delete the move immediately when the references
 177 ;;; go to zero.
 178 ;;;
 179 ;;; To understand why we always can to the substitution when the copy
 180 ;;; chain recorded in the Original-Copy-Of table hits NIL, note that
 181 ;;; we make an entry in the table iff we change the arg of a copy. If
 182 ;;; an entry is not in the table, it must be that we hit a move which
 183 ;;; *originally* referenced our Copy-Of TN. If all the intervening
 184 ;;; copies reach our reference, then Copy-Of must reach the reference.
 185 ;;;
 186 ;;; Note that due to our restricting copies to single-writer TNs, it
 187 ;;; will always be the case that when the first copy in a chain
 188 ;;; reaches the reference, all intervening copies reach also reach the
 189 ;;; reference. We don't exploit this, since we have to work backward
 190 ;;; from the last copy.
 191 ;;;
 192 ;;; In this discussion, we are really only playing with the tail of
 193 ;;; the true copy chain for which all of the copies have already had
 194 ;;; PROPAGATE-COPIES done on them. But, because we do this pass in
 195 ;;; DFO, it is virtually always the case that we will process earlier
 196 ;;; copies before later ones. In perverse cases (non-reducible flow
 197 ;;; graphs), we just miss some optimization opportinities.
 198 (defun propagate-copies (block original-copy-of)
 199   (declare (type cblock block) (type hash-table original-copy-of))
 200   (let ((in (block-in block)))
 201     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
 202         ((null vop))
 203       (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
 204                             (let ((y (tn-ref-tn (vop-results vop))))
 205                               (when (tn-is-copy-of y) y)))))
 206         ;; Substitute copied TN for copy when we find a reference to a copy.
 207         ;; If the copy is left with no reads, delete the move to the copy.
 208         (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
 209             ((null arg-ref))
 210           (let* ((arg (tn-ref-tn arg-ref))
 211                  (copy-of (tn-is-copy-of arg)))
 212             (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
 213               (when this-copy
 214                 (setf (gethash this-copy original-copy-of) arg))
 215               (change-tn-ref-tn arg-ref copy-of)
 216               (when (null (tn-reads arg))
 217                 (event copy-deleted-move)
 218                 (delete-vop (tn-ref-vop (tn-writes arg)))))))
 219         ;; Kill any elements in IN that are copies of a TN we are clobbering.
 220         (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
 221             ((null res-ref))
 222           (do-sset-elements (tn in)
 223             (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
 224               (sset-delete tn in))))
 225         ;; If this VOP is a copy, add the copy TN to IN.
 226         (when this-copy (sset-adjoin this-copy in)))))
 227
 228   (values))
 229
 230 ;;; Do copy propagation on COMPONENT by initializing the flow analysis
 231 ;;; sets, doing flow analysis, and then propagating copies using the
 232 ;;; results.
 233 (defun copy-propagate (component)
 234   (setf (block-out (component-head component)) (make-sset))
 235   (do-blocks (block component)
 236     (init-copy-sets block))
 237
 238   (loop
 239     (let ((did-something nil))
 240       (do-blocks (block component)
 241         (when (copy-flow-analysis block)
 242           (setq did-something t)))
 243       (unless did-something (return))))
 244
 245   (let ((original-copies (make-hash-table :test 'eq)))
 246     (do-blocks (block component)
 247       (propagate-copies block original-copies)))
 248
 249   (values))