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.
15 ;;; The component that is currently being compiled. TNs are allocated
16 ;;; in this component.
17 (defvar *component-being-compiled
*)
19 ;;; DO-PACKED-TNS (TN-Var Component [Result]) Form*
21 ;;; Iterate over all packed TNs allocated in COMPONENT.
22 (defmacro do-packed-tns
((tn component
&optional result
) &body body
)
23 (with-unique-names (n-component tns more-tns outer inner
)
24 `(prog* ((,n-component
(component-info ,component
))
25 (,tn
(ir2-component-normal-tns ,n-component
))
26 (,tns
(ir2-component-restricted-tns ,n-component
))
27 (,more-tns
(ir2-component-wired-tns ,n-component
)))
28 (when ,tn
(go ,inner
))
29 ,outer
(when (eq ,tns
:done
) (return ,result
))
30 (shiftf ,tn
,tns
,more-tns
:done
)
31 (unless ,tn
(go ,outer
))
33 (if (setq ,tn
(tn-next ,tn
)) (go ,inner
) (go ,outer
)))))
35 (defun set-ir2-physenv-live-tns (value instance
)
36 (setf (ir2-physenv-live-tns instance
) value
))
38 (defun set-ir2-physenv-debug-live-tns (value instance
)
39 (setf (ir2-physenv-debug-live-tns instance
) value
))
41 (defun set-ir2-component-alias-tns (value instance
)
42 (setf (ir2-component-alias-tns instance
) value
))
44 (defun set-ir2-component-normal-tns (value instance
)
45 (setf (ir2-component-normal-tns instance
) value
))
47 (defun set-ir2-component-restricted-tns (value instance
)
48 (setf (ir2-component-restricted-tns instance
) value
))
50 (defun set-ir2-component-wired-tns (value instance
)
51 (setf (ir2-component-wired-tns instance
) value
))
53 ;;; Remove all TNs with no references from the lists of unpacked TNs.
54 ;;; We null out the OFFSET so that nobody will mistake deleted wired
55 ;;; TNs for properly packed TNs. We mark non-deleted alias TNs so that
56 ;;; aliased TNs aren't considered to be unreferenced.
57 (defun delete-unreferenced-tns (component)
58 (let* ((2comp (component-info component
))
59 (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp
))
60 :element-type
'bit
:initial-element
0)))
61 (labels ((delete-some (getter setter
)
63 (do ((tn (funcall getter
2comp
) (tn-next tn
)))
67 (and (eq (tn-kind tn
) :specified-save
)
68 (used-p (tn-save-tn tn
))))
71 (delete-1 tn prev setter
))))))
73 (or (tn-reads tn
) (tn-writes tn
)
74 (member (tn-kind tn
) '(:component
:environment
))
75 (not (zerop (sbit aliases
(tn-number tn
))))))
76 (delete-1 (tn prev setter
)
78 (setf (tn-next prev
) (tn-next tn
))
79 (funcall setter
(tn-next tn
) 2comp
))
80 (setf (tn-offset tn
) nil
)
84 #'ir2-physenv-live-tns
85 #'set-ir2-physenv-live-tns
))
88 #'ir2-physenv-debug-live-tns
89 #'set-ir2-physenv-debug-live-tns
))))
90 (clear-live (tn getter setter
)
91 (let ((env (physenv-info (tn-physenv tn
))))
92 (funcall setter
(delete tn
(funcall getter env
)) env
))))
93 (declare (inline used-p delete-some delete-1 clear-live
))
94 (delete-some #'ir2-component-alias-tns
95 #'set-ir2-component-alias-tns
)
96 (do ((tn (ir2-component-alias-tns 2comp
) (tn-next tn
)))
98 (setf (sbit aliases
(tn-number (tn-save-tn tn
))) 1))
99 (delete-some #'ir2-component-normal-tns
100 #'set-ir2-component-normal-tns
)
101 (delete-some #'ir2-component-restricted-tns
102 #'set-ir2-component-restricted-tns
)
103 (delete-some #'ir2-component-wired-tns
104 #'set-ir2-component-wired-tns
)))
109 ;;; Create a packed TN of the specified primitive-type in the
110 ;;; *COMPONENT-BEING-COMPILED*. We use the SCs from the primitive type
111 ;;; to determine which SCs it can be packed in.
112 (defun make-normal-tn (type)
113 (declare (type primitive-type type
))
114 (let* ((component (component-info *component-being-compiled
*))
115 (res (make-tn (incf (ir2-component-global-tn-counter component
))
117 (push-in tn-next res
(ir2-component-normal-tns component
))
120 ;;; Create a normal packed TN with representation indicated by SCN.
121 (defun make-representation-tn (ptype scn
)
122 (declare (type primitive-type ptype
) (type sc-number scn
))
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 (push-in tn-next res
(ir2-component-normal-tns component
))
130 ;;; Create a TN wired to a particular location in an SC. We set the Offset
131 ;;; and FSC to record where it goes, and then put it on the current component's
132 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
134 (defun make-wired-tn (ptype scn offset
)
135 (declare (type (or primitive-type null
) ptype
)
136 (type sc-number scn
) (type unsigned-byte offset
))
137 (let* ((component (component-info *component-being-compiled
*))
138 (res (make-tn (incf (ir2-component-global-tn-counter component
))
140 (svref *backend-sc-numbers
* scn
))))
141 (setf (tn-offset res
) offset
)
142 (push-in tn-next res
(ir2-component-wired-tns component
))
145 ;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
146 ;;; for MAKE-WIRED-TN.
147 (defun make-restricted-tn (ptype scn
)
148 (declare (type (or primitive-type null
) ptype
) (type sc-number scn
))
149 (let* ((component (component-info *component-being-compiled
*))
150 (res (make-tn (incf (ir2-component-global-tn-counter component
))
152 (svref *backend-sc-numbers
* scn
))))
153 (push-in tn-next res
(ir2-component-restricted-tns component
))
156 ;;; Make TN be live throughout PHYSENV. Return TN. In the DEBUG case,
157 ;;; the TN is treated normally in blocks in the environment which
158 ;;; reference the TN, allowing targeting to/from the TN. This results
159 ;;; in move efficient code, but may result in the TN sometimes not
160 ;;; being live when you want it.
161 (defun physenv-live-tn (tn physenv
)
162 (declare (type tn tn
) (type physenv physenv
))
163 (aver (eq (tn-kind tn
) :normal
))
164 (setf (tn-kind tn
) :environment
)
165 (setf (tn-physenv tn
) physenv
)
166 (push tn
(ir2-physenv-live-tns (physenv-info physenv
)))
168 (defun physenv-debug-live-tn (tn physenv
)
169 (declare (type tn tn
) (type physenv physenv
))
170 (aver (eq (tn-kind tn
) :normal
))
171 (setf (tn-kind tn
) :debug-environment
)
172 (setf (tn-physenv tn
) physenv
)
173 (push tn
(ir2-physenv-debug-live-tns (physenv-info physenv
)))
176 ;;; Make TN be live throughout the current component. Return TN.
177 (defun component-live-tn (tn)
178 (declare (type tn tn
))
179 (aver (eq (tn-kind tn
) :normal
))
180 (setf (tn-kind tn
) :component
)
181 (push tn
(ir2-component-component-tns (component-info
182 *component-being-compiled
*)))
185 ;;; Specify that SAVE be used as the save location for TN. TN is returned.
186 (defun specify-save-tn (tn save
)
187 (declare (type tn tn save
))
188 (aver (eq (tn-kind save
) :normal
))
189 (aver (and (not (tn-save-tn tn
)) (not (tn-save-tn save
))))
190 (setf (tn-kind save
) :specified-save
)
191 (setf (tn-save-tn tn
) save
)
192 (setf (tn-save-tn save
) tn
)
194 (ir2-component-specified-save-tns
195 (component-info *component-being-compiled
*)))
198 ;;; Create a constant TN. The implementation dependent
199 ;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the
200 ;;; constant has an immediate representation.
201 (defun make-constant-tn (constant boxedp
)
202 (declare (type constant constant
))
203 (let* ((immed (immediate-constant-sc (constant-value constant
)))
204 (use-immed-p (and immed
206 (boxed-immediate-sc-p immed
)))))
208 ;; CONSTANT-TN uses two caches, one for boxed and one for unboxed uses.
210 ;; However, in the case of USE-IMMED-P we can have the same TN for both
211 ;; uses. The first two legs here take care of that by cross-pollinating the
214 ;; Similarly, when there is no immediate SC.
215 ((and (or use-immed-p
(not immed
)) boxedp
(leaf-info constant
)))
216 ((and (or use-immed-p
(not immed
)) (not boxedp
) (constant-boxed-tn constant
)))
218 (let* ((component (component-info *component-being-compiled
*))
219 (sc (svref *backend-sc-numbers
*
222 (sc-number-or-lose 'constant
))))
223 (res (make-tn 0 :constant
(primitive-type (leaf-type constant
)) sc
)))
224 ;; Objects of type SYMBOL can be immediate but they still go in the constants
225 ;; because liveness depends on pointer tracing without looking at code-fixups.
226 (when (or (not use-immed-p
)
228 (let ((val (constant-value constant
)))
229 (and (symbolp val
) (not (sb!vm
:static-symbol-p val
)))))
230 (let ((constants (ir2-component-constants component
)))
231 (setf (tn-offset res
) (fill-pointer constants
))
232 (vector-push-extend constant constants
)))
233 (push-in tn-next res
(ir2-component-constant-tns component
))
234 (setf (tn-leaf res
) constant
)
237 (defun make-load-time-value-tn (handle type
)
238 (let* ((component (component-info *component-being-compiled
*))
239 (sc (svref *backend-sc-numbers
*
240 (sc-number-or-lose 'constant
)))
241 (res (make-tn 0 :constant
(primitive-type type
) sc
))
242 (constants (ir2-component-constants component
)))
243 (setf (tn-offset res
) (fill-pointer constants
))
244 (vector-push-extend (cons :load-time-value handle
) constants
)
245 (push-in tn-next res
(ir2-component-constant-tns component
))
248 ;;; Make a TN that aliases TN for use in local call argument passing.
249 (defun make-alias-tn (tn)
250 (declare (type tn tn
))
251 (let* ((component (component-info *component-being-compiled
*))
252 (res (make-tn (incf (ir2-component-global-tn-counter component
))
253 :alias
(tn-primitive-type tn
) nil
)))
254 (setf (tn-save-tn res
) tn
)
256 (ir2-component-alias-tns component
))
259 ;;; Return a load-time constant TN with the specified KIND and INFO.
260 ;;; If the desired CONSTANTS entry already exists, then reuse it,
261 ;;; otherwise allocate a new load-time constant slot.
262 (defun make-load-time-constant-tn (kind info
)
263 (declare (type keyword kind
))
264 (let* ((component (component-info *component-being-compiled
*))
267 *backend-t-primitive-type
*
268 (svref *backend-sc-numbers
*
269 (sc-number-or-lose 'constant
))))
270 (constants (ir2-component-constants component
)))
273 ((= i
(length constants
))
274 (setf (tn-offset res
) i
)
275 (vector-push-extend (cons kind info
) constants
))
276 (let ((entry (aref constants i
)))
277 (when (and (consp entry
)
278 (eq (car entry
) kind
)
279 (or (eq (cdr entry
) info
)
281 (equal (cdr entry
) info
))))
282 (setf (tn-offset res
) i
)
285 (push-in tn-next res
(ir2-component-constant-tns component
))
290 ;;; Make a TN-REF that references TN and return it. WRITE-P should be
291 ;;; true if this is a write reference, otherwise false. All we do
292 ;;; other than calling the constructor is add the reference to the
294 (defun reference-tn (tn write-p
)
295 (declare (type tn tn
) (type boolean write-p
))
296 (let ((res (make-tn-ref tn write-p
)))
298 (push-in tn-ref-next res
(tn-writes tn
))
299 (push-in tn-ref-next res
(tn-reads tn
)))
302 ;;; Make TN-REFS to reference each TN in TNs, linked together by
303 ;;; TN-REF-ACROSS. WRITE-P is the WRITE-P value for the refs. MORE is
304 ;;; stuck in the TN-REF-ACROSS of the ref for the last TN, or returned
305 ;;; as the result if there are no TNs.
306 (defun reference-tn-list (tns write-p
&optional more
)
307 (declare (list tns
) (type boolean write-p
) (type (or tn-ref null
) more
))
309 (let* ((first (reference-tn (first tns
) write-p
))
311 (dolist (tn (rest tns
))
312 (let ((res (reference-tn tn write-p
)))
313 (setf (tn-ref-across prev
) res
)
315 (setf (tn-ref-across prev
) more
)
319 ;;; Remove Ref from the references for its associated TN.
320 (defun delete-tn-ref (ref)
321 (declare (type tn-ref ref
))
322 (if (tn-ref-write-p ref
)
323 (deletef-in tn-ref-next
(tn-writes (tn-ref-tn ref
)) ref
)
324 (deletef-in tn-ref-next
(tn-reads (tn-ref-tn ref
)) ref
))
327 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
328 ;;; old TN's refs, add ref to TN's refs, and set the TN-REF-TN.
329 (defun change-tn-ref-tn (ref tn
)
330 (declare (type tn-ref ref
) (type tn tn
))
332 (setf (tn-ref-tn ref
) tn
)
333 (if (tn-ref-write-p ref
)
334 (push-in tn-ref-next ref
(tn-writes tn
))
335 (push-in tn-ref-next ref
(tn-reads tn
)))
338 ;;;; miscellaneous utilities
340 ;;; Emit a move-like template determined at run-time, with X as the
341 ;;; argument and Y as the result. Useful for move, coerce and
342 ;;; type-check templates. If supplied, then insert before VOP,
343 ;;; otherwise insert at then end of the block. Returns the last VOP
345 (defun emit-move-template (node block template x y
&optional before
)
346 (declare (type node node
) (type ir2-block block
)
347 (type template template
) (type tn x y
))
348 (let ((arg (reference-tn x nil
))
349 (result (reference-tn y t
)))
350 (emit-and-insert-vop node block template arg result before
)))
352 ;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
353 (defun emit-load-template (node block template x y info
&optional before
)
354 (declare (type node node
) (type ir2-block block
)
355 (type template template
) (type tn x y
))
356 (let ((arg (reference-tn x nil
))
357 (result (reference-tn y t
)))
358 (emit-and-insert-vop node block template arg result before info
)))
360 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
361 (defun emit-move-arg-template (node block template x f y
&optional before
)
362 (declare (type node node
) (type ir2-block block
)
363 (type template template
) (type tn x f y
))
364 (let ((x-ref (reference-tn x nil
))
365 (f-ref (reference-tn f nil
))
366 (y-ref (reference-tn y t
)))
367 (setf (tn-ref-across x-ref
) f-ref
)
368 (emit-and-insert-vop node block template x-ref y-ref before
)))
370 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
371 (defun emit-context-template (node block template y
&optional before
)
372 (declare (type node node
) (type ir2-block block
)
373 (type template template
) (type tn y
))
374 (let ((y-ref (reference-tn y t
)))
375 (emit-and-insert-vop node block template nil y-ref before
)))
377 ;;; Return the label marking the start of Block, assigning one if necessary.
378 (defun block-label (block)
379 (declare (type cblock block
))
380 (let ((2block (block-info block
)))
381 (or (ir2-block-%label
2block
)
382 (setf (ir2-block-%label
2block
) (gen-label)))))
383 (defun block-trampoline (block)
384 (declare (type cblock block
))
385 (let ((2block (block-info block
)))
386 (or (ir2-block-%trampoline-label
2block
)
387 (setf (ir2-block-%trampoline-label
2block
) (gen-label)))))
389 ;;; Return true if Block is emitted immediately after the block ended by Node.
390 (defun drop-thru-p (node block
)
391 (declare (type node node
) (type cblock block
))
392 (let ((next-block (ir2-block-next (block-info (node-block node
)))))
393 (aver (eq node
(block-last (node-block node
))))
394 (eq next-block
(block-info block
))))
395 (defun register-drop-thru (block)
396 (declare (type cblock block
))
397 (let ((2block (block-info block
)))
398 (setf (ir2-block-dropped-thru-to 2block
) t
))
401 ;;; Insert a VOP into BLOCK, before the specified
402 ;;; BEFORE VOP. If BEFORE is NIL, insert at the end.
403 (defun insert-vop (vop block before
)
404 (declare (type vop vop
) (type ir2-block block
)
405 (type (or vop null
) before
))
407 (let ((prev (vop-prev before
)))
408 (setf (vop-prev vop
) prev
)
410 (setf (vop-next prev
) vop
)
411 (setf (ir2-block-start-vop block
) vop
))
412 (setf (vop-next vop
) before
)
413 (setf (vop-prev before
) vop
))
414 (let ((current (ir2-block-last-vop block
)))
415 (setf (vop-prev vop
) current
)
416 (setf (ir2-block-last-vop block
) vop
)
418 (setf (vop-next current
) vop
)
419 (setf (ir2-block-start-vop block
) vop
))))
422 (defun emit-and-insert-vop (node block template arg result before
424 (let ((vop (emit-vop node block template arg result info
)))
425 (insert-vop vop block before
)
428 ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
429 (defun delete-vop (vop)
430 (declare (type vop vop
))
431 (do ((ref (vop-refs vop
) (tn-ref-next-ref ref
)))
435 (let ((prev (vop-prev vop
))
436 (next (vop-next vop
))
437 (block (vop-block vop
)))
439 (setf (vop-next prev
) next
)
440 (setf (ir2-block-start-vop block
) next
))
442 (setf (vop-prev next
) prev
)
443 (setf (ir2-block-last-vop block
) prev
)))
447 ;;; Return a list of N normal TNs of the specified primitive type.
448 (defun make-n-tns (n ptype
)
449 (declare (type unsigned-byte n
) (type primitive-type ptype
))
451 collect
(make-normal-tn ptype
)))
453 ;;; Return true if X and Y are packed in the same location, false otherwise.
454 ;;; This is false if either operand is constant.
455 (defun location= (x y
)
456 (declare (type tn x y
))
457 (and (eq (sc-sb (tn-sc x
)) (sc-sb (tn-sc y
)))
458 (eql (tn-offset x
) (tn-offset y
))
459 (not (or (eq (tn-kind x
) :constant
)
460 (eq (tn-kind y
) :constant
)))))
462 ;;; Return the value of an immediate constant TN.
464 (declare (type tn tn
))
465 (aver (eq (tn-kind tn
) :constant
))
466 (constant-value (tn-leaf tn
)))
468 (defun immediate-tn-p (tn)
469 (declare (type tn tn
))
470 (let ((leaf (tn-leaf tn
)))
471 ;; Leaves with KIND :CONSTANT can have NIL as the leaf if they
472 ;; represent load time values.
474 (eq (tn-kind tn
) :constant
)
475 (eq (immediate-constant-sc (constant-value leaf
))
476 (sc-number-or-lose 'sb
!vm
::immediate
)))))
478 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
479 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
480 ;;; but since we change the SC to an unbounded one, we should always succeed in
481 ;;; packing it in that SC.
482 (defun force-tn-to-stack (tn)
483 (declare (type tn tn
))
484 (let ((sc (tn-sc tn
)))
485 (unless (and (not (sc-save-p sc
))
486 (eq (sb-kind (sc-sb sc
)) :unbounded
))
487 (dolist (alt (sc-alternate-scs sc
)
488 (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC."
490 (when (and (not (sc-save-p alt
))
491 (eq (sb-kind (sc-sb alt
)) :unbounded
))
492 (setf (tn-sc tn
) alt
)