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
)))
225 (let ((constants (ir2-component-constants component
)))
226 (setf (tn-offset res
) (fill-pointer constants
))
227 (vector-push-extend constant constants
)))
228 (push-in tn-next res
(ir2-component-constant-tns component
))
229 (setf (tn-leaf res
) constant
)
232 (defun make-load-time-value-tn (handle type
)
233 (let* ((component (component-info *component-being-compiled
*))
234 (sc (svref *backend-sc-numbers
*
235 (sc-number-or-lose 'constant
)))
236 (res (make-tn 0 :constant
(primitive-type type
) sc
))
237 (constants (ir2-component-constants component
)))
238 (setf (tn-offset res
) (fill-pointer constants
))
239 (vector-push-extend (cons :load-time-value handle
) constants
)
240 (push-in tn-next res
(ir2-component-constant-tns component
))
243 ;;; Make a TN that aliases TN for use in local call argument passing.
244 (defun make-alias-tn (tn)
245 (declare (type tn tn
))
246 (let* ((component (component-info *component-being-compiled
*))
247 (res (make-tn (incf (ir2-component-global-tn-counter component
))
248 :alias
(tn-primitive-type tn
) nil
)))
249 (setf (tn-save-tn res
) tn
)
251 (ir2-component-alias-tns component
))
254 ;;; Return a load-time constant TN with the specified KIND and INFO.
255 ;;; If the desired CONSTANTS entry already exists, then reuse it,
256 ;;; otherwise allocate a new load-time constant slot.
257 (defun make-load-time-constant-tn (kind info
)
258 (declare (type keyword kind
))
259 (let* ((component (component-info *component-being-compiled
*))
262 *backend-t-primitive-type
*
263 (svref *backend-sc-numbers
*
264 (sc-number-or-lose 'constant
))))
265 (constants (ir2-component-constants component
)))
268 ((= i
(length constants
))
269 (setf (tn-offset res
) i
)
270 (vector-push-extend (cons kind info
) constants
))
271 (let ((entry (aref constants i
)))
272 (when (and (consp entry
)
273 (eq (car entry
) kind
)
274 (or (eq (cdr entry
) info
)
276 (equal (cdr entry
) info
))))
277 (setf (tn-offset res
) i
)
280 (push-in tn-next res
(ir2-component-constant-tns component
))
285 ;;; Make a TN-REF that references TN and return it. WRITE-P should be
286 ;;; true if this is a write reference, otherwise false. All we do
287 ;;; other than calling the constructor is add the reference to the
289 (defun reference-tn (tn write-p
)
290 (declare (type tn tn
) (type boolean write-p
))
291 (let ((res (make-tn-ref tn write-p
)))
293 (push-in tn-ref-next res
(tn-writes tn
))
294 (push-in tn-ref-next res
(tn-reads tn
)))
297 ;;; Make TN-REFS to reference each TN in TNs, linked together by
298 ;;; TN-REF-ACROSS. WRITE-P is the WRITE-P value for the refs. MORE is
299 ;;; stuck in the TN-REF-ACROSS of the ref for the last TN, or returned
300 ;;; as the result if there are no TNs.
301 (defun reference-tn-list (tns write-p
&optional more
)
302 (declare (list tns
) (type boolean write-p
) (type (or tn-ref null
) more
))
304 (let* ((first (reference-tn (first tns
) write-p
))
306 (dolist (tn (rest tns
))
307 (let ((res (reference-tn tn write-p
)))
308 (setf (tn-ref-across prev
) res
)
310 (setf (tn-ref-across prev
) more
)
314 ;;; Remove Ref from the references for its associated TN.
315 (defun delete-tn-ref (ref)
316 (declare (type tn-ref ref
))
317 (if (tn-ref-write-p ref
)
318 (deletef-in tn-ref-next
(tn-writes (tn-ref-tn ref
)) ref
)
319 (deletef-in tn-ref-next
(tn-reads (tn-ref-tn ref
)) ref
))
322 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
323 ;;; old TN's refs, add ref to TN's refs, and set the TN-REF-TN.
324 (defun change-tn-ref-tn (ref tn
)
325 (declare (type tn-ref ref
) (type tn tn
))
327 (setf (tn-ref-tn ref
) tn
)
328 (if (tn-ref-write-p ref
)
329 (push-in tn-ref-next ref
(tn-writes tn
))
330 (push-in tn-ref-next ref
(tn-reads tn
)))
333 ;;;; miscellaneous utilities
335 ;;; Emit a move-like template determined at run-time, with X as the
336 ;;; argument and Y as the result. Useful for move, coerce and
337 ;;; type-check templates. If supplied, then insert before VOP,
338 ;;; otherwise insert at then end of the block. Returns the last VOP
340 (defun emit-move-template (node block template x y
&optional before
)
341 (declare (type node node
) (type ir2-block block
)
342 (type template template
) (type tn x y
))
343 (let ((arg (reference-tn x nil
))
344 (result (reference-tn y t
)))
345 (emit-and-insert-vop node block template arg result before
)))
347 ;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
348 (defun emit-load-template (node block template x y info
&optional before
)
349 (declare (type node node
) (type ir2-block block
)
350 (type template template
) (type tn x y
))
351 (let ((arg (reference-tn x nil
))
352 (result (reference-tn y t
)))
353 (emit-and-insert-vop node block template arg result before info
)))
355 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
356 (defun emit-move-arg-template (node block template x f y
&optional before
)
357 (declare (type node node
) (type ir2-block block
)
358 (type template template
) (type tn x f y
))
359 (let ((x-ref (reference-tn x nil
))
360 (f-ref (reference-tn f nil
))
361 (y-ref (reference-tn y t
)))
362 (setf (tn-ref-across x-ref
) f-ref
)
363 (emit-and-insert-vop node block template x-ref y-ref before
)))
365 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
366 (defun emit-context-template (node block template y
&optional before
)
367 (declare (type node node
) (type ir2-block block
)
368 (type template template
) (type tn y
))
369 (let ((y-ref (reference-tn y t
)))
370 (emit-and-insert-vop node block template nil y-ref before
)))
372 ;;; Return the label marking the start of Block, assigning one if necessary.
373 (defun block-label (block)
374 (declare (type cblock block
))
375 (let ((2block (block-info block
)))
376 (or (ir2-block-%label
2block
)
377 (setf (ir2-block-%label
2block
) (gen-label)))))
378 (defun block-trampoline (block)
379 (declare (type cblock block
))
380 (let ((2block (block-info block
)))
381 (or (ir2-block-%trampoline-label
2block
)
382 (setf (ir2-block-%trampoline-label
2block
) (gen-label)))))
384 ;;; Return true if Block is emitted immediately after the block ended by Node.
385 (defun drop-thru-p (node block
)
386 (declare (type node node
) (type cblock block
))
387 (let ((next-block (ir2-block-next (block-info (node-block node
)))))
388 (aver (eq node
(block-last (node-block node
))))
389 (eq next-block
(block-info block
))))
390 (defun register-drop-thru (block)
391 (declare (type cblock block
))
392 (let ((2block (block-info block
)))
393 (setf (ir2-block-dropped-thru-to 2block
) t
))
396 ;;; Insert a VOP into BLOCK, before the specified
397 ;;; BEFORE VOP. If BEFORE is NIL, insert at the end.
398 (defun insert-vop (vop block before
)
399 (declare (type vop vop
) (type ir2-block block
)
400 (type (or vop null
) before
))
402 (let ((prev (vop-prev before
)))
403 (setf (vop-prev vop
) prev
)
405 (setf (vop-next prev
) vop
)
406 (setf (ir2-block-start-vop block
) vop
))
407 (setf (vop-next vop
) before
)
408 (setf (vop-prev before
) vop
))
409 (let ((current (ir2-block-last-vop block
)))
410 (setf (vop-prev vop
) current
)
411 (setf (ir2-block-last-vop block
) vop
)
413 (setf (vop-next current
) vop
)
414 (setf (ir2-block-start-vop block
) vop
))))
417 (defun emit-and-insert-vop (node block template arg result before
419 (let ((vop (emit-vop node block template arg result info
)))
420 (insert-vop vop block before
)
423 ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
424 (defun delete-vop (vop)
425 (declare (type vop vop
))
426 (do ((ref (vop-refs vop
) (tn-ref-next-ref ref
)))
430 (let ((prev (vop-prev vop
))
431 (next (vop-next vop
))
432 (block (vop-block vop
)))
434 (setf (vop-next prev
) next
)
435 (setf (ir2-block-start-vop block
) next
))
437 (setf (vop-prev next
) prev
)
438 (setf (ir2-block-last-vop block
) prev
)))
442 ;;; Return a list of N normal TNs of the specified primitive type.
443 (defun make-n-tns (n ptype
)
444 (declare (type unsigned-byte n
) (type primitive-type ptype
))
446 collect
(make-normal-tn ptype
)))
448 ;;; Return true if X and Y are packed in the same location, false otherwise.
449 ;;; This is false if either operand is constant.
450 (defun location= (x y
)
451 (declare (type tn x y
))
452 (and (eq (sc-sb (tn-sc x
)) (sc-sb (tn-sc y
)))
453 (eql (tn-offset x
) (tn-offset y
))
454 (not (or (eq (tn-kind x
) :constant
)
455 (eq (tn-kind y
) :constant
)))))
457 ;;; Return the value of an immediate constant TN.
459 (declare (type tn tn
))
460 (aver (eq (tn-kind tn
) :constant
))
461 (constant-value (tn-leaf tn
)))
463 (defun immediate-tn-p (tn)
464 (declare (type tn tn
))
465 (let ((leaf (tn-leaf tn
)))
466 ;; Leaves with KIND :CONSTANT can have NIL as the leaf if they
467 ;; represent load time values.
469 (eq (tn-kind tn
) :constant
)
470 (eq (immediate-constant-sc (constant-value leaf
))
471 (sc-number-or-lose 'sb
!vm
::immediate
)))))
473 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
474 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
475 ;;; but since we change the SC to an unbounded one, we should always succeed in
476 ;;; packing it in that SC.
477 (defun force-tn-to-stack (tn)
478 (declare (type tn tn
))
479 (let ((sc (tn-sc tn
)))
480 (unless (and (not (sc-save-p sc
))
481 (eq (sb-kind (sc-sb sc
)) :unbounded
))
482 (dolist (alt (sc-alternate-scs sc
)
483 (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC."
485 (when (and (not (sc-save-p alt
))
486 (eq (sb-kind (sc-sb alt
)) :unbounded
))
487 (setf (tn-sc tn
) alt
)