1 ;;;; This file implements the copy propagation phase of the compiler,
2 ;;;; which uses global flow analysis to eliminate unnecessary copying
5 ;;;; This software is part of the SBCL system. See the README file for
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.
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.
25 ;;; There are additional semantic constraints on whether a TN can be considered
26 ;;; to be a copy. See TN-IS-A-COPY-OF.
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.
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.)
37 ;;; GEN is the set of all interesting TNs that are copied in the block (whose
38 ;;; write appears in the block.)
40 ;;; OUT is (union (difference IN KILL) GEN)
42 ;;; If TN is subject to copy propagation, then return the TN it is a copy
43 ;;; of, otherwise NIL.
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
52 ;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be
53 ;;; otherwise bizarre.
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.
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))
80 (tn-primitive-type arg-tn)))
81 (let ((leaf (tn-leaf tn)))
83 (not (symbol-package (leaf-name leaf)))
84 (policy (vop-node vop)
85 (or (= speed 3) (< debug 2)))))
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))
96 (do ((vop (ir2-block-start-vop (block-info block)) (vop-next 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)
103 (do ((res (vop-results vop) (tn-ref-across res)))
105 (let ((res-tn (tn-ref-tn res)))
106 (do ((read (tn-reads res-tn) (tn-ref-next 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)
113 (sset-adjoin y kill))))))))))
115 (setf (block-out block) (copy-sset gen))
116 (setf (block-kill block) kill)
117 (setf (block-gen block) gen))
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))))
132 (defevent copy-deleted-move "Copy propagation deleted a move.")
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)))
145 (unless (sset-member original in)
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)
151 (error "Couldn't find REF?"))
152 (length (template-arg-types info))))))))
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.
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
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.
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.
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
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)))
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)))
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))
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)))
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)))))
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))
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))))
232 (let ((original-copies (make-hash-table :test 'eq)))
233 (do-blocks (block component)
234 (propagate-copies block original-copies)))