0.8.19.32:
[sbcl.git] / src / compiler / tn.lisp
1 ;;;; This file contains utilities used for creating and manipulating
2 ;;;; TNs, and some other more assorted IR2 utilities.
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!C")
14
15 ;;; The component that is currently being compiled. TNs are allocated
16 ;;; in this component.
17 (defvar *component-being-compiled*)
18
19 ;;; DO-PACKED-TNS (TN-Var Component [Result]) Declaration* Form*
20 ;;;
21 ;;; Iterate over all packed TNs allocated in COMPONENT.
22 (defmacro do-packed-tns ((tn component &optional result) &body body)
23   (let ((n-component (gensym)))
24     `(let ((,n-component (component-info ,component)))
25        (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
26            ((null ,tn))
27          ,@body)
28        (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
29            ((null ,tn))
30          ,@body)
31        (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
32            ((null ,tn)
33             ,result)
34          ,@body))))
35 \f
36 (defun set-ir2-physenv-live-tns (value instance)
37   (setf (ir2-physenv-live-tns instance) value))
38
39 (defun set-ir2-physenv-debug-live-tns (value instance)
40   (setf (ir2-physenv-debug-live-tns instance) value))
41
42 (defun set-ir2-component-alias-tns (value instance)
43   (setf (ir2-component-alias-tns instance) value))
44
45 (defun set-ir2-component-normal-tns (value instance)
46   (setf (ir2-component-normal-tns instance) value))
47
48 (defun set-ir2-component-restricted-tns (value instance)
49   (setf (ir2-component-restricted-tns instance) value))
50
51 (defun set-ir2-component-wired-tns (value instance)
52   (setf (ir2-component-wired-tns instance) value))
53
54 ;;; Remove all TNs with no references from the lists of unpacked TNs.
55 ;;; We null out the OFFSET so that nobody will mistake deleted wired
56 ;;; TNs for properly packed TNs. We mark non-deleted alias TNs so that
57 ;;; aliased TNs aren't considered to be unreferenced.
58 (defun delete-unreferenced-tns (component)
59   (let* ((2comp (component-info component))
60          (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
61                               :element-type 'bit :initial-element 0)))
62     (labels ((delete-some (getter setter)
63                (let ((prev nil))
64                  (do ((tn (funcall getter 2comp) (tn-next tn)))
65                      ((null tn))
66                    (cond
67                     ((or (used-p tn)
68                          (and (eq (tn-kind tn) :specified-save)
69                               (used-p (tn-save-tn tn))))
70                      (setq prev tn))
71                     (t
72                      (delete-1 tn prev setter))))))
73              (used-p (tn)
74                (or (tn-reads tn) (tn-writes tn)
75                    (member (tn-kind tn) '(:component :environment))
76                    (not (zerop (sbit aliases (tn-number tn))))))
77              (delete-1 (tn prev setter)
78                (if prev
79                    (setf (tn-next prev) (tn-next tn))
80                    (funcall setter (tn-next tn) 2comp))
81                (setf (tn-offset tn) nil)
82                (case (tn-kind tn)
83                  (:environment
84                   (clear-live tn
85                               #'ir2-physenv-live-tns
86                               #'set-ir2-physenv-live-tns))
87                  (:debug-environment
88                   (clear-live tn
89                               #'ir2-physenv-debug-live-tns
90                               #'set-ir2-physenv-debug-live-tns))))
91              (clear-live (tn getter setter)
92                (let ((env (physenv-info (tn-physenv tn))))
93                  (funcall setter (delete tn (funcall getter env)) env))))
94       (declare (inline used-p delete-some delete-1 clear-live))
95       (delete-some #'ir2-component-alias-tns
96                    #'set-ir2-component-alias-tns)
97       (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
98           ((null tn))
99         (setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
100       (delete-some #'ir2-component-normal-tns
101                    #'set-ir2-component-normal-tns)
102       (delete-some #'ir2-component-restricted-tns
103                    #'set-ir2-component-restricted-tns)
104       (delete-some #'ir2-component-wired-tns
105                    #'set-ir2-component-wired-tns)))
106   (values))
107 \f
108 ;;;; TN creation
109
110 ;;; Create a packed TN of the specified primitive-type in the
111 ;;; *COMPONENT-BEING-COMPILED*. We use the SCs from the primitive type
112 ;;; to determine which SCs it can be packed in.
113 (defun make-normal-tn (type)
114   (declare (type primitive-type type))
115   (let* ((component (component-info *component-being-compiled*))
116          (res (make-tn (incf (ir2-component-global-tn-counter component))
117                        :normal type nil)))
118     (push-in tn-next res (ir2-component-normal-tns component))
119     res))
120
121 ;;; Create a normal packed TN with representation indicated by SCN.
122 (defun make-representation-tn (ptype scn)
123   (declare (type primitive-type ptype) (type sc-number scn))
124   (let* ((component (component-info *component-being-compiled*))
125          (res (make-tn (incf (ir2-component-global-tn-counter component))
126                        :normal ptype
127                        (svref *backend-sc-numbers* scn))))
128     (push-in tn-next res (ir2-component-normal-tns component))
129     res))
130
131 ;;; Create a TN wired to a particular location in an SC. We set the Offset
132 ;;; and FSC to record where it goes, and then put it on the current component's
133 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
134 ;;; temporaries.
135 (defun make-wired-tn (ptype scn offset)
136   (declare (type (or primitive-type null) ptype)
137            (type sc-number scn) (type unsigned-byte offset))
138   (let* ((component (component-info *component-being-compiled*))
139          (res (make-tn (incf (ir2-component-global-tn-counter component))
140                        :normal ptype
141                        (svref *backend-sc-numbers* scn))))
142     (setf (tn-offset res) offset)
143     (push-in tn-next res (ir2-component-wired-tns component))
144     res))
145
146 ;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
147 ;;; for MAKE-WIRED-TN.
148 (defun make-restricted-tn (ptype scn)
149   (declare (type (or primitive-type null) ptype) (type sc-number scn))
150   (let* ((component (component-info *component-being-compiled*))
151          (res (make-tn (incf (ir2-component-global-tn-counter component))
152                        :normal ptype
153                        (svref *backend-sc-numbers* scn))))
154     (push-in tn-next res (ir2-component-restricted-tns component))
155     res))
156
157 ;;; Make TN be live throughout PHYSENV. Return TN. In the DEBUG case,
158 ;;; the TN is treated normally in blocks in the environment which
159 ;;; reference the TN, allowing targeting to/from the TN. This results
160 ;;; in move efficient code, but may result in the TN sometimes not
161 ;;; being live when you want it.
162 (defun physenv-live-tn (tn physenv)
163   (declare (type tn tn) (type physenv physenv))
164   (aver (eq (tn-kind tn) :normal))
165   (setf (tn-kind tn) :environment)
166   (setf (tn-physenv tn) physenv)
167   (push tn (ir2-physenv-live-tns (physenv-info physenv)))
168   tn)
169 (defun physenv-debug-live-tn (tn physenv)
170   (declare (type tn tn) (type physenv physenv))
171   (aver (eq (tn-kind tn) :normal))
172   (setf (tn-kind tn) :debug-environment)
173   (setf (tn-physenv tn) physenv)
174   (push tn (ir2-physenv-debug-live-tns (physenv-info physenv)))
175   tn)
176
177 ;;; Make TN be live throughout the current component. Return TN.
178 (defun component-live-tn (tn)
179   (declare (type tn tn))
180   (aver (eq (tn-kind tn) :normal))
181   (setf (tn-kind tn) :component)
182   (push tn (ir2-component-component-tns (component-info
183                                          *component-being-compiled*)))
184   tn)
185
186 ;;; Specify that SAVE be used as the save location for TN. TN is returned.
187 (defun specify-save-tn (tn save)
188   (declare (type tn tn save))
189   (aver (eq (tn-kind save) :normal))
190   (aver (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
191   (setf (tn-kind save) :specified-save)
192   (setf (tn-save-tn tn) save)
193   (setf (tn-save-tn save) tn)
194   (push save
195         (ir2-component-specified-save-tns
196          (component-info *component-being-compiled*)))
197   tn)
198
199 ;;; Create a constant TN. The implementation dependent
200 ;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the
201 ;;; constant has an immediate representation.
202 (defun make-constant-tn (constant)
203   (declare (type constant constant))
204   (let* ((component (component-info *component-being-compiled*))
205          (immed (immediate-constant-sc (constant-value constant)))
206          (sc (svref *backend-sc-numbers*
207                     (or immed (sc-number-or-lose 'constant))))
208          (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
209     (unless immed
210       (let ((constants (ir2-component-constants component)))
211         (setf (tn-offset res) (fill-pointer constants))
212         (vector-push-extend constant constants)))
213     (push-in tn-next res (ir2-component-constant-tns component))
214     (setf (tn-leaf res) constant)
215     res))
216
217 (defun make-load-time-value-tn (handle type)
218   (let* ((component (component-info *component-being-compiled*))
219          (sc (svref *backend-sc-numbers*
220                     (sc-number-or-lose 'constant)))
221          (res (make-tn 0 :constant (primitive-type type) sc))
222          (constants (ir2-component-constants component)))
223     (setf (tn-offset res) (fill-pointer constants))
224     (vector-push-extend (cons :load-time-value handle) constants)
225     (push-in tn-next res (ir2-component-constant-tns component))
226     res))
227
228 ;;; Make a TN that aliases TN for use in local call argument passing.
229 (defun make-alias-tn (tn)
230   (declare (type tn tn))
231   (let* ((component (component-info *component-being-compiled*))
232          (res (make-tn (incf (ir2-component-global-tn-counter component))
233                        :alias (tn-primitive-type tn) nil)))
234     (setf (tn-save-tn res) tn)
235     (push-in tn-next res
236              (ir2-component-alias-tns component))
237     res))
238
239 ;;; Return a load-time constant TN with the specified KIND and INFO.
240 ;;; If the desired CONSTANTS entry already exists, then reuse it,
241 ;;; otherwise allocate a new load-time constant slot.
242 (defun make-load-time-constant-tn (kind info)
243   (declare (type keyword kind))
244   (let* ((component (component-info *component-being-compiled*))
245          (res (make-tn 0
246                        :constant
247                        *backend-t-primitive-type*
248                        (svref *backend-sc-numbers*
249                               (sc-number-or-lose 'constant))))
250          (constants (ir2-component-constants component)))
251
252     (do ((i 0 (1+ i)))
253         ((= i (length constants))
254          (setf (tn-offset res) i)
255          (vector-push-extend (cons kind info) constants))
256       (let ((entry (aref constants i)))
257         (when (and (consp entry)
258                    (eq (car entry) kind)
259                    (or (eq (cdr entry) info)
260                        (and (consp info)
261                             (equal (cdr entry) info))))
262           (setf (tn-offset res) i)
263           (return))))
264
265     (push-in tn-next res (ir2-component-constant-tns component))
266     res))
267 \f
268 ;;;; TN referencing
269
270 ;;; Make a TN-REF that references TN and return it. WRITE-P should be
271 ;;; true if this is a write reference, otherwise false. All we do
272 ;;; other than calling the constructor is add the reference to the
273 ;;; TN's references.
274 (defun reference-tn (tn write-p)
275   (declare (type tn tn) (type boolean write-p))
276   (let ((res (make-tn-ref tn write-p)))
277     (if write-p
278         (push-in tn-ref-next res (tn-writes tn))
279         (push-in tn-ref-next res (tn-reads tn)))
280     res))
281
282 ;;; Make TN-REFS to reference each TN in TNs, linked together by
283 ;;; TN-REF-ACROSS. WRITE-P is the WRITE-P value for the refs. MORE is
284 ;;; stuck in the TN-REF-ACROSS of the ref for the last TN, or returned
285 ;;; as the result if there are no TNs.
286 (defun reference-tn-list (tns write-p &optional more)
287   (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
288   (if tns
289       (let* ((first (reference-tn (first tns) write-p))
290              (prev first))
291         (dolist (tn (rest tns))
292           (let ((res (reference-tn tn write-p)))
293             (setf (tn-ref-across prev) res)
294             (setq prev res)))
295         (setf (tn-ref-across prev) more)
296         first)
297       more))
298
299 ;;; Remove Ref from the references for its associated TN.
300 (defun delete-tn-ref (ref)
301   (declare (type tn-ref ref))
302   (if (tn-ref-write-p ref)
303       (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
304       (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
305   (values))
306
307 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
308 ;;; old TN's refs, add ref to TN's refs, and set the TN-REF-TN.
309 (defun change-tn-ref-tn (ref tn)
310   (declare (type tn-ref ref) (type tn tn))
311   (delete-tn-ref ref)
312   (setf (tn-ref-tn ref) tn)
313   (if (tn-ref-write-p ref)
314       (push-in tn-ref-next ref (tn-writes tn))
315       (push-in tn-ref-next ref (tn-reads tn)))
316   (values))
317 \f
318 ;;;; miscellaneous utilities
319
320 ;;; Emit a move-like template determined at run-time, with X as the
321 ;;; argument and Y as the result. Useful for move, coerce and
322 ;;; type-check templates. If supplied, then insert before VOP,
323 ;;; otherwise insert at then end of the block. Returns the last VOP
324 ;;; inserted.
325 (defun emit-move-template (node block template x y &optional before)
326   (declare (type node node) (type ir2-block block)
327            (type template template) (type tn x y))
328   (let ((arg (reference-tn x nil))
329         (result (reference-tn y t)))
330     (multiple-value-bind (first last)
331         (funcall (template-emit-function template) node block template arg
332                  result)
333       (insert-vop-sequence first last block before)
334       last)))
335
336 ;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
337 (defun emit-load-template (node block template x y info &optional before)
338   (declare (type node node) (type ir2-block block)
339            (type template template) (type tn x y))
340   (let ((arg (reference-tn x nil))
341         (result (reference-tn y t)))
342     (multiple-value-bind (first last)
343         (funcall (template-emit-function template) node block template arg
344                  result info)
345       (insert-vop-sequence first last block before)
346       last)))
347
348 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
349 (defun emit-move-arg-template (node block template x f y &optional before)
350   (declare (type node node) (type ir2-block block)
351            (type template template) (type tn x f y))
352   (let ((x-ref (reference-tn x nil))
353         (f-ref (reference-tn f nil))
354         (y-ref (reference-tn y t)))
355     (setf (tn-ref-across x-ref) f-ref)
356     (multiple-value-bind (first last)
357         (funcall (template-emit-function template) node block template x-ref
358                  y-ref)
359       (insert-vop-sequence first last block before)
360       last)))
361
362 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
363 (defun emit-context-template (node block template y &optional before)
364   (declare (type node node) (type ir2-block block)
365            (type template template) (type tn y))
366   (let ((y-ref (reference-tn y t)))
367     (multiple-value-bind (first last)
368         (funcall (template-emit-function template) node block template nil
369                  y-ref)
370       (insert-vop-sequence first last block before)
371       last)))
372
373 ;;; Return the label marking the start of Block, assigning one if necessary.
374 (defun block-label (block)
375   (declare (type cblock block))
376   (let ((2block (block-info block)))
377     (or (ir2-block-%label 2block)
378         (setf (ir2-block-%label 2block) (gen-label)))))
379
380 ;;; Return true if Block is emitted immediately after the block ended by Node.
381 (defun drop-thru-p (node block)
382   (declare (type node node) (type cblock block))
383   (let ((next-block (ir2-block-next (block-info (node-block node)))))
384     (aver (eq node (block-last (node-block node))))
385     (eq next-block (block-info block))))
386
387 ;;; Link a list of VOPs from First to Last into Block, Before the specified
388 ;;; VOP. If Before is NIL, insert at the end.
389 (defun insert-vop-sequence (first last block before)
390   (declare (type vop first last) (type ir2-block block)
391            (type (or vop null) before))
392   (if before
393       (let ((prev (vop-prev before)))
394         (setf (vop-prev first) prev)
395         (if prev
396             (setf (vop-next prev) first)
397             (setf (ir2-block-start-vop block) first))
398         (setf (vop-next last) before)
399         (setf (vop-prev before) last))
400       (let ((current (ir2-block-last-vop block)))
401         (setf (vop-prev first) current)
402         (setf (ir2-block-last-vop block) last)
403         (if current
404             (setf (vop-next current) first)
405             (setf (ir2-block-start-vop block) first))))
406   (values))
407
408 ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
409 (defun delete-vop (vop)
410   (declare (type vop vop))
411   (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
412       ((null ref))
413     (delete-tn-ref ref))
414
415   (let ((prev (vop-prev vop))
416         (next (vop-next vop))
417         (block (vop-block vop)))
418     (if prev
419         (setf (vop-next prev) next)
420         (setf (ir2-block-start-vop block) next))
421     (if next
422         (setf (vop-prev next) prev)
423         (setf (ir2-block-last-vop block) prev)))
424
425   (values))
426
427 ;;; Return a list of N normal TNs of the specified primitive type.
428 (defun make-n-tns (n ptype)
429   (declare (type unsigned-byte n) (type primitive-type ptype))
430   (loop repeat n
431         collect (make-normal-tn ptype)))
432
433 ;;; Return true if X and Y are packed in the same location, false otherwise.
434 ;;; This is false if either operand is constant.
435 (defun location= (x y)
436   (declare (type tn x y))
437   (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
438        (eql (tn-offset x) (tn-offset y))
439        (not (or (eq (tn-kind x) :constant)
440                 (eq (tn-kind y) :constant)))))
441
442 ;;; Return the value of an immediate constant TN.
443 (defun tn-value (tn)
444   (declare (type tn tn))
445   ;; FIXME: What is :CACHED-CONSTANT?
446   (aver (member (tn-kind tn) '(:constant :cached-constant)))
447   (constant-value (tn-leaf tn)))
448
449 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
450 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
451 ;;; but since we change the SC to an unbounded one, we should always succeed in
452 ;;; packing it in that SC.
453 (defun force-tn-to-stack (tn)
454   (declare (type tn tn))
455   (let ((sc (tn-sc tn)))
456     (unless (and (not (sc-save-p sc))
457                  (eq (sb-kind (sc-sb sc)) :unbounded))
458       (dolist (alt (sc-alternate-scs sc)
459                    (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC."
460                           (sc-name sc)))
461         (when (and (not (sc-save-p alt))
462                    (eq (sb-kind (sc-sb alt)) :unbounded))
463           (setf (tn-sc tn) alt)
464           (return)))))
465   (values))
466