1 ;;;; This file contains utilities used for creating and manipulating
2 ;;;; TNs, and some other more assorted IR2 utilities.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
18 ;;; The component that is currently being compiled. TNs are allocated
19 ;;; in this component.
20 (defvar *component-being-compiled*)
22 (defmacro do-packed-tns ((tn component &optional result) &body body)
24 "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
25 Iterate over all packed TNs allocated in Component."
26 (let ((n-component (gensym)))
27 `(let ((,n-component (component-info ,component)))
28 (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
31 (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
34 (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
39 ;;; Remove all TNs with no references from the lists of unpacked TNs. We
40 ;;; null out the Offset so that nobody will mistake deleted wired TNs for
41 ;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
42 ;;; aren't considered to be unreferenced.
43 (defun delete-unreferenced-tns (component)
44 (let* ((2comp (component-info component))
45 (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
46 :element-type 'bit :initial-element 0)))
47 (labels ((delete-some (getter setter)
49 (do ((tn (funcall getter 2comp) (tn-next tn)))
53 (and (eq (tn-kind tn) :specified-save)
54 (used-p (tn-save-tn tn))))
57 (delete-1 tn prev setter))))))
59 (or (tn-reads tn) (tn-writes tn)
60 (member (tn-kind tn) '(:component :environment))
61 (not (zerop (sbit aliases (tn-number tn))))))
62 (delete-1 (tn prev setter)
64 (setf (tn-next prev) (tn-next tn))
65 (funcall setter (tn-next tn) 2comp))
66 (setf (tn-offset tn) nil)
70 #'ir2-environment-live-tns
71 #'(setf ir2-environment-live-tns)))
74 #'ir2-environment-debug-live-tns
75 #'(setf ir2-environment-debug-live-tns)))))
76 (clear-live (tn getter setter)
77 (let ((env (environment-info (tn-environment tn))))
78 (funcall setter (delete tn (funcall getter env)) env))))
79 (declare (inline used-p delete-some delete-1 clear-live))
80 (delete-some #'ir2-component-alias-tns
81 #'(setf ir2-component-alias-tns))
82 (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
84 (setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
85 (delete-some #'ir2-component-normal-tns
86 #'(setf ir2-component-normal-tns))
87 (delete-some #'ir2-component-restricted-tns
88 #'(setf ir2-component-restricted-tns))
89 (delete-some #'ir2-component-wired-tns
90 #'(setf ir2-component-wired-tns))))
95 ;;; Create a packed TN of the specified primitive-type in the
96 ;;; *COMPONENT-BEING-COMPILED*. We use the SCs from the primitive type
97 ;;; to determine which SCs it can be packed in.
98 (defun make-normal-tn (type)
99 (declare (type primitive-type type))
100 (let* ((component (component-info *component-being-compiled*))
101 (res (make-tn (incf (ir2-component-global-tn-counter component))
103 (push-in tn-next res (ir2-component-normal-tns component))
106 ;;; Create a normal packed TN with representation indicated by SCN.
107 (defun make-representation-tn (ptype scn)
108 (declare (type primitive-type ptype) (type sc-number scn))
109 (let* ((component (component-info *component-being-compiled*))
110 (res (make-tn (incf (ir2-component-global-tn-counter component))
112 (svref *backend-sc-numbers* scn))))
113 (push-in tn-next res (ir2-component-normal-tns component))
116 ;;; Create a TN wired to a particular location in an SC. We set the Offset
117 ;;; and FSC to record where it goes, and then put it on the current component's
118 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
120 (defun make-wired-tn (ptype scn offset)
121 (declare (type (or primitive-type null) ptype)
122 (type sc-number scn) (type unsigned-byte offset))
123 (let* ((component (component-info *component-being-compiled*))
124 (res (make-tn (incf (ir2-component-global-tn-counter component))
126 (svref *backend-sc-numbers* scn))))
127 (setf (tn-offset res) offset)
128 (push-in tn-next res (ir2-component-wired-tns component))
131 ;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
132 ;;; for MAKE-WIRED-TN.
133 (defun make-restricted-tn (ptype scn)
134 (declare (type (or primitive-type null) ptype) (type sc-number scn))
135 (let* ((component (component-info *component-being-compiled*))
136 (res (make-tn (incf (ir2-component-global-tn-counter component))
138 (svref *backend-sc-numbers* scn))))
139 (push-in tn-next res (ir2-component-restricted-tns component))
142 ;;; Make TN be live throughout environment. Return TN. In the DEBUG case,
143 ;;; the TN is treated normally in blocks in the environment which reference the
144 ;;; TN, allowing targeting to/from the TN. This results in move efficient
145 ;;; code, but may result in the TN sometimes not being live when you want it.
146 (defun environment-live-tn (tn env)
147 (declare (type tn tn) (type environment env))
148 (assert (eq (tn-kind tn) :normal))
149 (setf (tn-kind tn) :environment)
150 (setf (tn-environment tn) env)
151 (push tn (ir2-environment-live-tns (environment-info env)))
153 (defun environment-debug-live-tn (tn env)
154 (declare (type tn tn) (type environment env))
155 (assert (eq (tn-kind tn) :normal))
156 (setf (tn-kind tn) :debug-environment)
157 (setf (tn-environment tn) env)
158 (push tn (ir2-environment-debug-live-tns (environment-info env)))
161 ;;; Make TN be live throughout the current component. Return TN.
162 (defun component-live-tn (tn)
163 (declare (type tn tn))
164 (assert (eq (tn-kind tn) :normal))
165 (setf (tn-kind tn) :component)
166 (push tn (ir2-component-component-tns (component-info
167 *component-being-compiled*)))
170 ;;; Specify that Save be used as the save location for TN. TN is returned.
171 (defun specify-save-tn (tn save)
172 (declare (type tn tn save))
173 (assert (eq (tn-kind save) :normal))
174 (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
175 (setf (tn-kind save) :specified-save)
176 (setf (tn-save-tn tn) save)
177 (setf (tn-save-tn save) tn)
179 (ir2-component-specified-save-tns
180 (component-info *component-being-compiled*)))
183 ;;; Create a constant TN. The implementation dependent
184 ;;; Immediate-Constant-SC function is used to determine whether the constant
185 ;;; has an immediate representation.
186 (defun make-constant-tn (constant)
187 (declare (type constant constant))
188 (let* ((component (component-info *component-being-compiled*))
189 (immed (immediate-constant-sc (constant-value constant)))
190 (sc (svref *backend-sc-numbers*
191 (or immed (sc-number-or-lose 'constant))))
192 (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
194 (let ((constants (ir2-component-constants component)))
195 (setf (tn-offset res) (fill-pointer constants))
196 (vector-push-extend constant constants)))
197 (push-in tn-next res (ir2-component-constant-tns component))
198 (setf (tn-leaf res) constant)
201 (defun make-load-time-value-tn (handle type)
202 (let* ((component (component-info *component-being-compiled*))
203 (sc (svref *backend-sc-numbers*
204 (sc-number-or-lose 'constant)))
205 (res (make-tn 0 :constant (primitive-type type) sc))
206 (constants (ir2-component-constants component)))
207 (setf (tn-offset res) (fill-pointer constants))
208 (vector-push-extend (cons :load-time-value handle) constants)
209 (push-in tn-next res (ir2-component-constant-tns component))
212 ;;; Make a TN that aliases TN for use in local call argument passing.
213 (defun make-alias-tn (tn)
214 (declare (type tn tn))
215 (let* ((component (component-info *component-being-compiled*))
216 (res (make-tn (incf (ir2-component-global-tn-counter component))
217 :alias (tn-primitive-type tn) nil)))
218 (setf (tn-save-tn res) tn)
220 (ir2-component-alias-tns component))
223 ;;; Return a load-time constant TN with the specified Kind and Info. If the
224 ;;; desired Constants entry already exists, then reuse it, otherwise allocate a
225 ;;; new load-time constant slot.
226 (defun make-load-time-constant-tn (kind info)
227 (declare (type keyword kind))
228 (let* ((component (component-info *component-being-compiled*))
231 *backend-t-primitive-type*
232 (svref *backend-sc-numbers*
233 (sc-number-or-lose 'constant))))
234 (constants (ir2-component-constants component)))
237 ((= i (length constants))
238 (setf (tn-offset res) i)
239 (vector-push-extend (cons kind info) constants))
240 (let ((entry (aref constants i)))
241 (when (and (consp entry)
242 (eq (car entry) kind)
243 (or (eq (cdr entry) info)
245 (equal (cdr entry) info))))
246 (setf (tn-offset res) i)
249 (push-in tn-next res (ir2-component-constant-tns component))
254 ;;; Make a TN-Ref that references TN and return it. Write-P should be true
255 ;;; if this is a write reference, otherwise false. All we do other than
256 ;;; calling the constructor is add the reference to the TN's references.
257 (defun reference-tn (tn write-p)
258 (declare (type tn tn) (type boolean write-p))
259 (let ((res (make-tn-ref tn write-p)))
261 (push-in tn-ref-next res (tn-writes tn))
262 (push-in tn-ref-next res (tn-reads tn)))
265 ;;; Make TN-Refs to reference each TN in TNs, linked together by
266 ;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is
267 ;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
268 ;;; result if there are no TNs.
269 (defun reference-tn-list (tns write-p &optional more)
270 (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
272 (let* ((first (reference-tn (first tns) write-p))
274 (dolist (tn (rest tns))
275 (let ((res (reference-tn tn write-p)))
276 (setf (tn-ref-across prev) res)
278 (setf (tn-ref-across prev) more)
282 ;;; Remove Ref from the references for its associated TN.
283 (defun delete-tn-ref (ref)
284 (declare (type tn-ref ref))
285 (if (tn-ref-write-p ref)
286 (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
287 (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
290 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
291 ;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
292 (defun change-tn-ref-tn (ref tn)
293 (declare (type tn-ref ref) (type tn tn))
295 (setf (tn-ref-tn ref) tn)
296 (if (tn-ref-write-p ref)
297 (push-in tn-ref-next ref (tn-writes tn))
298 (push-in tn-ref-next ref (tn-reads tn)))
301 ;;;; miscellaneous utilities
303 ;;; Emit a move-like template determined at run-time, with X as the argument
304 ;;; and Y as the result. Useful for move, coerce and type-check templates. If
305 ;;; supplied, then insert before VOP, otherwise insert at then end of the
306 ;;; block. Returns the last VOP inserted.
307 (defun emit-move-template (node block template x y &optional before)
308 (declare (type node node) (type ir2-block block)
309 (type template template) (type tn x y))
310 (let ((arg (reference-tn x nil))
311 (result (reference-tn y t)))
312 (multiple-value-bind (first last)
313 (funcall (template-emit-function template) node block template arg
315 (insert-vop-sequence first last block before)
318 ;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
319 (defun emit-load-template (node block template x y info &optional before)
320 (declare (type node node) (type ir2-block block)
321 (type template template) (type tn x y))
322 (let ((arg (reference-tn x nil))
323 (result (reference-tn y t)))
324 (multiple-value-bind (first last)
325 (funcall (template-emit-function template) node block template arg
327 (insert-vop-sequence first last block before)
330 ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
331 (defun emit-move-arg-template (node block template x f y &optional before)
332 (declare (type node node) (type ir2-block block)
333 (type template template) (type tn x f y))
334 (let ((x-ref (reference-tn x nil))
335 (f-ref (reference-tn f nil))
336 (y-ref (reference-tn y t)))
337 (setf (tn-ref-across x-ref) f-ref)
338 (multiple-value-bind (first last)
339 (funcall (template-emit-function template) node block template x-ref
341 (insert-vop-sequence first last block before)
344 ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
345 (defun emit-context-template (node block template y &optional before)
346 (declare (type node node) (type ir2-block block)
347 (type template template) (type tn y))
348 (let ((y-ref (reference-tn y t)))
349 (multiple-value-bind (first last)
350 (funcall (template-emit-function template) node block template nil
352 (insert-vop-sequence first last block before)
355 ;;; Return the label marking the start of Block, assigning one if necessary.
356 (defun block-label (block)
357 (declare (type cblock block))
358 (let ((2block (block-info block)))
359 (or (ir2-block-%label 2block)
360 (setf (ir2-block-%label 2block) (gen-label)))))
362 ;;; Return true if Block is emitted immediately after the block ended by Node.
363 (defun drop-thru-p (node block)
364 (declare (type node node) (type cblock block))
365 (let ((next-block (ir2-block-next (block-info (node-block node)))))
366 (assert (eq node (block-last (node-block node))))
367 (eq next-block (block-info block))))
369 ;;; Link a list of VOPs from First to Last into Block, Before the specified
370 ;;; VOP. If Before is NIL, insert at the end.
371 (defun insert-vop-sequence (first last block before)
372 (declare (type vop first last) (type ir2-block block)
373 (type (or vop null) before))
375 (let ((prev (vop-prev before)))
376 (setf (vop-prev first) prev)
378 (setf (vop-next prev) first)
379 (setf (ir2-block-start-vop block) first))
380 (setf (vop-next last) before)
381 (setf (vop-prev before) last))
382 (let ((current (ir2-block-last-vop block)))
383 (setf (vop-prev first) current)
384 (setf (ir2-block-last-vop block) last)
386 (setf (vop-next current) first)
387 (setf (ir2-block-start-vop block) first))))
390 ;;; Delete all of the TN-Refs associated with VOP and remove VOP from the IR2.
391 (defun delete-vop (vop)
392 (declare (type vop vop))
393 (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
397 (let ((prev (vop-prev vop))
398 (next (vop-next vop))
399 (block (vop-block vop)))
401 (setf (vop-next prev) next)
402 (setf (ir2-block-start-vop block) next))
404 (setf (vop-prev next) prev)
405 (setf (ir2-block-last-vop block) prev)))
409 ;;; Return a list of N normal TNs of the specified primitive type.
410 (defun make-n-tns (n ptype)
411 (declare (type unsigned-byte n) (type primitive-type ptype))
414 (res (make-normal-tn ptype)))
417 ;;; Return true if X and Y are packed in the same location, false otherwise.
418 ;;; This is false if either operand is constant.
419 (defun location= (x y)
420 (declare (type tn x y))
421 (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
422 (eql (tn-offset x) (tn-offset y))
423 (not (or (eq (tn-kind x) :constant)
424 (eq (tn-kind y) :constant)))))
426 ;;; Return the value of an immediate constant TN.
428 (declare (type tn tn))
429 (assert (member (tn-kind tn) '(:constant :cached-constant)))
430 (constant-value (tn-leaf tn)))
432 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
433 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
434 ;;; but since we change the SC to an unbounded one, we should always succeed in
435 ;;; packing it in that SC.
436 (defun force-tn-to-stack (tn)
437 (declare (type tn tn))
438 (let ((sc (tn-sc tn)))
439 (unless (and (not (sc-save-p sc))
440 (eq (sb-kind (sc-sb sc)) :unbounded))
441 (dolist (alt (sc-alternate-scs sc)
442 (error "SC ~S has no :unbounded :save-p NIL alternate SC."
444 (when (and (not (sc-save-p alt))
445 (eq (sb-kind (sc-sb alt)) :unbounded))
446 (setf (tn-sc tn) alt)