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