Remove "-HEADER-" from SYMBOL and VALUE-CELL widetag names
[sbcl.git] / src / compiler / copyprop.lisp
blob3dcb78a8d7c980d70557475fdb44559b7eae4898
1 ;;;; This file implements the copy propagation phase of the compiler,
2 ;;;; which uses global flow analysis to eliminate unnecessary copying
3 ;;;; of variables.
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.
14 (in-package "SB!C")
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)
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 we want to preserve it to facilitate
59 ;;; debugging.
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 (and
88 ;; Do we not care about preserving this this
89 ;; TN for debugging?
90 (or
91 (not (symbol-package (leaf-debug-name leaf)))
92 (policy (vop-node vop)
93 (or (= speed 3) (< debug 2))))
94 ;; arguments of local functions have hidden write
95 (not (and (lambda-var-p leaf)
96 (memq (functional-kind (lambda-var-home leaf))
97 '(nil :optional)))))))
98 arg-tn)))))))
100 (defun reads-within-block-p (tn block)
101 (do ((ref (tn-reads tn) (tn-ref-next ref)))
102 ((null ref) t)
103 (let ((vop (tn-ref-vop ref)))
104 (unless (eq (ir2-block-block (vop-block vop)) block)
105 (return)))))
107 ;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
108 ;;; look for MOVE vops, and then see whether the result is a eligible
109 ;;; copy TN. To find KILL, we must look at all VOP results, seeing
110 ;;; whether any of the reads of the written TN are copies for eligible
111 ;;; TNs.
112 (defun init-copy-sets (block)
113 (declare (type cblock block))
114 (let ((kill (make-sset))
115 (out (make-sset)))
116 (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
117 ((null vop))
118 (unless (and (eq (vop-info-name (vop-info vop)) 'move)
119 (let ((y (tn-ref-tn (vop-results vop))))
120 (when (tn-is-copy-of y)
121 (unless (reads-within-block-p y block)
122 (sset-adjoin y out))
123 t)))
124 ;; WANTED: explanation of UNLESS above.
125 (do ((res (vop-results vop) (tn-ref-across res)))
126 ((not res))
127 (let ((res-tn (tn-ref-tn res)))
128 (do ((read (tn-reads res-tn) (tn-ref-next read)))
129 ((null read))
130 (let ((read-vop (tn-ref-vop read)))
131 (when (eq (vop-info-name (vop-info read-vop)) 'move)
132 (let ((y (tn-ref-tn (vop-results read-vop))))
133 (when (tn-is-copy-of y)
134 (sset-delete y out)
135 (sset-adjoin y kill))))))))))
136 (setf (block-out block) out
137 (block-kill block) kill))
138 (values))
140 ;;; Do the flow analysis step for copy propagation on BLOCK. We rely
141 ;;; on OUT being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE
142 ;;; to incrementally build the union in OUT, rather than replacing OUT
143 ;;; each time.
144 (defun copy-flow-analysis (block)
145 (declare (type cblock block))
146 (let* ((pred (block-pred block))
147 (in (copy-sset (block-out (first pred)))))
148 (dolist (pred-block (rest pred))
149 (sset-intersection in (block-out pred-block)))
150 (setf (block-in block) in)
151 (sset-union-of-difference (block-out block)
153 (block-kill block))))
155 (defevent copy-deleted-move "Copy propagation deleted a move.")
157 ;;; Return true if ARG is a reference to a TN that we can copy
158 ;;; propagate to. In addition to dealing with copy chains (as
159 ;;; discussed below), we also discard references that are arguments
160 ;;; to a local call, since IR2tran introduces temps in that context
161 ;;; to preserve parallel assignment semantics.
162 (defun ok-copy-ref (vop arg in original-copy-of)
163 (declare (type vop vop) (type tn arg) (type sset in)
164 (type hash-table original-copy-of))
165 (and (sset-member arg in)
166 (do ((original (gethash arg original-copy-of)
167 (gethash original original-copy-of)))
168 ((not original) t)
169 (unless (sset-member original in)
170 (return nil)))
171 (let ((info (vop-info vop)))
172 (not (or (eq (vop-info-move-args info) :local-call)
173 (>= (or (position-in #'tn-ref-across arg (vop-args vop)
174 :key #'tn-ref-tn)
175 (error "Couldn't find REF?"))
176 (length (template-arg-types info))))))))
178 ;;; Make use of the result of flow analysis to eliminate copies. We
179 ;;; scan the VOPs in block, propagating copies and keeping our IN set
180 ;;; in sync.
182 ;;; Original-Copy-Of is an EQ hash table that we use to keep track of
183 ;;; renamings when there are copy chains, i.e. copies of copies. When
184 ;;; we see copy of a copy, we enter the first copy in the table with
185 ;;; the second copy as a key. When we see a reference to a TN in a
186 ;;; copy chain, we can only substitute the first copied TN for the
187 ;;; reference when all intervening copies in the copy chain are also
188 ;;; available. Otherwise, we just leave the reference alone. It is
189 ;;; possible that we might have been able to reference one of the
190 ;;; intermediate copies instead, but that copy might have already been
191 ;;; deleted, since we delete the move immediately when the references
192 ;;; go to zero.
194 ;;; To understand why we always can to the substitution when the copy
195 ;;; chain recorded in the Original-Copy-Of table hits NIL, note that
196 ;;; we make an entry in the table iff we change the arg of a copy. If
197 ;;; an entry is not in the table, it must be that we hit a move which
198 ;;; *originally* referenced our Copy-Of TN. If all the intervening
199 ;;; copies reach our reference, then Copy-Of must reach the reference.
201 ;;; Note that due to our restricting copies to single-writer TNs, it
202 ;;; will always be the case that when the first copy in a chain
203 ;;; reaches the reference, all intervening copies reach also reach the
204 ;;; reference. We don't exploit this, since we have to work backward
205 ;;; from the last copy.
207 ;;; In this discussion, we are really only playing with the tail of
208 ;;; the true copy chain for which all of the copies have already had
209 ;;; PROPAGATE-COPIES done on them. But, because we do this pass in
210 ;;; DFO, it is virtually always the case that we will process earlier
211 ;;; copies before later ones. In perverse cases (non-reducible flow
212 ;;; graphs), we just miss some optimization opportinities.
213 (defun propagate-copies (block original-copy-of)
214 (declare (type cblock block) (type hash-table original-copy-of))
215 (let ((in (block-in block)))
216 ;; Don't retain garbage
217 (setf (block-in block) nil
218 (block-out block) nil
219 (block-kill block) nil)
220 (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
221 ((null vop))
222 (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
223 (let ((y (tn-ref-tn (vop-results vop))))
224 (when (tn-is-copy-of y) y)))))
225 ;; Substitute copied TN for copy when we find a reference to a copy.
226 ;; If the copy is left with no reads, delete the move to the copy.
227 (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
228 ((null arg-ref))
229 (let* ((arg (tn-ref-tn arg-ref))
230 (copy-of (tn-is-copy-of arg)))
231 (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
232 (when this-copy
233 (setf (gethash this-copy original-copy-of) arg))
234 (change-tn-ref-tn arg-ref copy-of)
235 (when (null (tn-reads arg))
236 (event copy-deleted-move)
237 (delete-vop (tn-ref-vop (tn-writes arg)))))))
238 ;; Kill any elements in IN that are copies of a TN we are clobbering.
239 (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
240 ((null res-ref))
241 (do-sset-elements (tn in)
242 (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
243 (sset-delete tn in))))
244 ;; If this VOP is a copy, add the copy TN to IN.
245 (when this-copy (sset-adjoin this-copy in)))))
247 (values))
249 ;;; Do copy propagation on COMPONENT by initializing the flow analysis
250 ;;; sets, doing flow analysis, and then propagating copies using the
251 ;;; results.
252 (defun copy-propagate (component)
253 (setf (block-out (component-head component)) (make-sset))
254 (do-blocks (block component)
255 (init-copy-sets block))
257 (loop
258 (let ((did-something nil))
259 (do-blocks (block component)
260 (when (copy-flow-analysis block)
261 (setq did-something t)))
262 (unless did-something (return))))
264 (let ((original-copies (make-hash-table :test 'eq)))
265 (do-blocks (block component)
266 (propagate-copies block original-copies)))
268 (values))