/[cmucl]/src/compiler/tn.lisp
ViewVC logotype

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Wed Aug 25 00:16:40 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.18: +2 -2 lines
Fix compiler warnings.
1 wlott 1.1 ;;; -*- Package: C; Log: C.Log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.12 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.19 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/tn.lisp,v 1.19 1993/08/25 00:16:40 ram Exp $")
11 ram 1.12 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file contains utilities used for creating and manipulating TNs, and
15     ;;; some other more assorted IR2 utilities.
16     ;;;
17     ;;; Written by Rob MacLachlan
18     ;;;
19 ram 1.19 (in-package "C")
20 wlott 1.1
21 wlott 1.10 (export '(make-normal-tn make-representation-tn make-wired-tn
22     make-restricted-tn environment-live-tn
23     environment-debug-live-tn component-live-tn specify-save-tn
24     make-constant-tn make-alias-tn make-load-time-constant-tn
25 hallgren 1.17 make-n-tns location= tn-value force-tn-to-stack
26     *compile-component*))
27 wlott 1.10
28 wlott 1.1 ;;; The component that is currently being compiled. TNs are allocated in this
29     ;;; component.
30     ;;;
31     (defvar *compile-component*)
32    
33    
34     ;;; Do-Packed-TNs -- Interface
35     ;;;
36     (defmacro do-packed-tns ((tn component &optional result) &body body)
37     "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
38     Iterate over all packed TNs allocated in Component."
39     (let ((n-component (gensym)))
40     `(let ((,n-component (component-info ,component)))
41     (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
42     ((null ,tn))
43     ,@body)
44     (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
45     ((null ,tn))
46     ,@body)
47     (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
48     ((null ,tn)
49     ,result)
50     ,@body))))
51    
52    
53     ;;; Delete-Unreferenced-TNs -- Interface
54     ;;;
55     ;;; Remove all TNs with no references from the lists of unpacked TNs. We
56     ;;; null out the Offset so that nobody will mistake deleted wired TNs for
57 ram 1.14 ;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
58     ;;; aren't considered to be unreferenced.
59 wlott 1.1 ;;;
60     (defun delete-unreferenced-tns (component)
61 ram 1.14 (let* ((2comp (component-info component))
62     (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
63     :element-type 'bit :initial-element 0)))
64 ram 1.13 (labels ((delete-some (getter setter)
65     (let ((prev nil))
66     (do ((tn (funcall getter 2comp) (tn-next tn)))
67     ((null tn))
68 ram 1.14 (cond
69     ((or (used-p tn)
70     (and (eq (tn-kind tn) :specified-save)
71     (used-p (tn-save-tn tn))))
72     (setq prev tn))
73     (t
74     (delete-1 tn prev setter))))))
75     (used-p (tn)
76     (or (tn-reads tn) (tn-writes tn)
77     (member (tn-kind tn) '(:component :environment))
78     (not (zerop (sbit aliases (tn-number tn))))))
79 ram 1.13 (delete-1 (tn prev setter)
80     (if prev
81     (setf (tn-next prev) (tn-next tn))
82     (funcall setter (tn-next tn) 2comp))
83     (setf (tn-offset tn) nil)
84     (case (tn-kind tn)
85     (:environment
86     (clear-live tn #'ir2-environment-live-tns
87     #'(setf ir2-environment-live-tns)))
88     (:debug-environment
89     (clear-live tn #'ir2-environment-debug-live-tns
90     #'(setf ir2-environment-debug-live-tns)))))
91     (clear-live (tn getter setter)
92     (let ((env (environment-info (tn-environment tn))))
93     (funcall setter (delete tn (funcall getter env)) env))))
94 ram 1.14 (declare (inline used-p delete-some delete-1 clear-live))
95     (delete-some #'ir2-component-alias-tns
96     #'(setf 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 ram 1.13 (delete-some #'ir2-component-normal-tns
101     #'(setf ir2-component-normal-tns))
102     (delete-some #'ir2-component-restricted-tns
103     #'(setf ir2-component-restricted-tns))
104     (delete-some #'ir2-component-wired-tns
105 ram 1.14 #'(setf ir2-component-wired-tns))))
106 wlott 1.1 (undefined-value))
107    
108    
109     ;;;; TN Creation:
110    
111     ;;; Make-Normal-TN -- Interface
112     ;;;
113     ;;; Create a packed TN of the specified primitive-type in the
114     ;;; *Compile-Component*. We use the SCs from the primitive type to determine
115     ;;; which SCs it can be packed in.
116     ;;;
117     (defun make-normal-tn (type)
118     (declare (type primitive-type type))
119     (let* ((component (component-info *compile-component*))
120     (res (make-tn (incf (ir2-component-global-tn-counter component))
121 ram 1.2 :normal type nil)))
122 wlott 1.1 (push-in tn-next res (ir2-component-normal-tns component))
123     res))
124    
125    
126 ram 1.2 ;;; MAKE-REPRESENTATION-TN -- Interface
127 wlott 1.1 ;;;
128 ram 1.2 ;;; Create a normal packed TN with representation indicated by SCN.
129 wlott 1.1 ;;;
130 ram 1.5 (defun make-representation-tn (ptype scn)
131     (declare (type primitive-type ptype) (type sc-number scn))
132 wlott 1.1 (let* ((component (component-info *compile-component*))
133     (res (make-tn (incf (ir2-component-global-tn-counter component))
134 wlott 1.10 :normal ptype
135     (svref (backend-sc-numbers *backend*) scn))))
136 ram 1.2 (push-in tn-next res (ir2-component-normal-tns component))
137 wlott 1.1 res))
138    
139    
140     ;;; Make-Wired-TN -- Interface
141     ;;;
142     ;;; Create a TN wired to a particular location in an SC. We set the Offset
143     ;;; and FSC to record where it goes, and then put it on the current component's
144 ram 1.5 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
145     ;;; temporaries.
146 wlott 1.1 ;;;
147 ram 1.5 (defun make-wired-tn (ptype scn offset)
148     (declare (type (or primitive-type null) ptype)
149     (type sc-number scn) (type unsigned-byte offset))
150 wlott 1.1 (let* ((component (component-info *compile-component*))
151     (res (make-tn (incf (ir2-component-global-tn-counter component))
152 wlott 1.10 :normal ptype
153     (svref (backend-sc-numbers *backend*) scn))))
154 wlott 1.1 (setf (tn-offset res) offset)
155     (push-in tn-next res (ir2-component-wired-tns component))
156 ram 1.5 res))
157    
158    
159     ;;; Make-Restricted-TN -- Interface
160     ;;;
161     ;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
162     ;;; for MAKE-WIRED-TN.
163     ;;;
164     (defun make-restricted-tn (ptype scn)
165     (declare (type (or primitive-type null) ptype) (type sc-number scn))
166     (let* ((component (component-info *compile-component*))
167     (res (make-tn (incf (ir2-component-global-tn-counter component))
168 wlott 1.10 :normal ptype
169     (svref (backend-sc-numbers *backend*) scn))))
170 ram 1.5 (push-in tn-next res (ir2-component-restricted-tns component))
171 wlott 1.1 res))
172    
173    
174 ram 1.8 ;;; ENVIRONMENT-LIVE-TN, ENVIRONMENT-DEBUG-LIVE-TN -- Interface
175 wlott 1.1 ;;;
176 ram 1.8 ;;; Make TN be live throughout environment. Return TN. In the DEBUG case,
177     ;;; the TN is treated normally in blocks in the environment which reference the
178     ;;; TN, allowing targeting to/from the TN. This results in move efficient
179     ;;; code, but may result in the TN sometimes not being live when you want it.
180 wlott 1.1 ;;;
181 ram 1.2 (defun environment-live-tn (tn env)
182     (declare (type tn tn) (type environment env))
183     (assert (eq (tn-kind tn) :normal))
184     (setf (tn-kind tn) :environment)
185 ram 1.8 (setf (tn-environment tn) env)
186 ram 1.2 (push tn (ir2-environment-live-tns (environment-info env)))
187     tn)
188 ram 1.8 ;;;
189     (defun environment-debug-live-tn (tn env)
190     (declare (type tn tn) (type environment env))
191     (assert (eq (tn-kind tn) :normal))
192     (setf (tn-kind tn) :debug-environment)
193     (setf (tn-environment tn) env)
194     (push tn (ir2-environment-debug-live-tns (environment-info env)))
195     tn)
196 wlott 1.1
197    
198 ram 1.2 ;;; Component-Live-TN -- Interface
199     ;;;
200     ;;; Make TN be live throughout the current component. Return TN.
201     ;;;
202     (defun component-live-tn (tn)
203     (declare (type tn tn))
204     (assert (eq (tn-kind tn) :normal))
205     (setf (tn-kind tn) :component)
206     (push tn (ir2-component-component-tns (component-info *compile-component*)))
207     tn)
208    
209    
210 ram 1.8 ;;; SPECIFY-SAVE-TN -- Interface
211     ;;;
212     ;;; Specify that Save be used as the save location for TN. TN is returned.
213     ;;;
214     (defun specify-save-tn (tn save)
215     (declare (type tn tn save))
216     (assert (eq (tn-kind save) :normal))
217     (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
218     (setf (tn-kind save) :specified-save)
219     (setf (tn-save-tn tn) save)
220     (setf (tn-save-tn save) tn)
221     (push save
222     (ir2-component-specified-save-tns
223     (component-info *compile-component*)))
224     tn)
225    
226    
227 wlott 1.1 ;;; Make-Constant-TN -- Interface
228     ;;;
229     ;;; Create a constant TN. The implementation dependent
230     ;;; Immediate-Constant-SC function is used to determine whether the constant
231     ;;; has an immediate representation.
232     ;;;
233     (defun make-constant-tn (constant)
234     (declare (type constant constant))
235     (let* ((component (component-info *compile-component*))
236     (immed (immediate-constant-sc (constant-value constant)))
237 wlott 1.10 (sc (svref (backend-sc-numbers *backend*)
238 wlott 1.11 (or immed (sc-number-or-lose 'constant *backend*))))
239 wlott 1.1 (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
240     (unless immed
241     (let ((constants (ir2-component-constants component)))
242     (setf (tn-offset res) (fill-pointer constants))
243     (vector-push-extend constant constants)))
244     (push-in tn-next res (ir2-component-constant-tns component))
245     (setf (tn-leaf res) constant)
246 ram 1.8 res))
247    
248 wlott 1.15
249     ;;; MAKE-LOAD-TIME-VALUE-TN -- interface.
250     ;;;
251     (defun make-load-time-value-tn (handle type)
252     (let* ((component (component-info *compile-component*))
253     (sc (svref (backend-sc-numbers *backend*)
254     (sc-number-or-lose 'constant *backend*)))
255     (res (make-tn 0 :constant (primitive-type type) sc))
256     (constants (ir2-component-constants component)))
257     (setf (tn-offset res) (fill-pointer constants))
258     (vector-push-extend (cons :load-time-value handle) constants)
259     (push-in tn-next res (ir2-component-constant-tns component))
260     res))
261 ram 1.8
262     ;;; MAKE-ALIAS-TN -- Interface
263     ;;;
264     ;;; Make a TN that aliases TN for use in local call argument passing.
265     ;;;
266     (defun make-alias-tn (tn)
267     (declare (type tn tn))
268     (let* ((component (component-info *compile-component*))
269     (res (make-tn (incf (ir2-component-global-tn-counter component))
270     :alias (tn-primitive-type tn) nil)))
271     (setf (tn-save-tn res) tn)
272     (push-in tn-next res
273     (ir2-component-alias-tns component))
274 wlott 1.1 res))
275    
276    
277     ;;; Make-Load-Time-Constant-TN -- Internal
278     ;;;
279     ;;; Return a load-time constant TN with the specified Kind and Info. If the
280     ;;; desired Constants entry already exists, then reuse it, otherwise allocate a
281     ;;; new load-time constant slot.
282     ;;;
283     (defun make-load-time-constant-tn (kind info)
284     (declare (type keyword kind))
285     (let* ((component (component-info *compile-component*))
286 wlott 1.10 (res (make-tn 0 :constant (backend-any-primitive-type *backend*)
287     (svref (backend-sc-numbers *backend*)
288 wlott 1.11 (sc-number-or-lose 'constant *backend*))))
289 wlott 1.1 (constants (ir2-component-constants component)))
290    
291     (do ((i 0 (1+ i)))
292     ((= i (length constants))
293     (setf (tn-offset res) i)
294     (vector-push-extend (cons kind info) constants))
295     (let ((entry (aref constants i)))
296     (when (and (consp entry)
297     (eq (car entry) kind)
298 wlott 1.18 (or (eq (cdr entry) info)
299     (and (consp info)
300     (equal (cdr entry) info))))
301 wlott 1.16 (setf (tn-offset res) i)
302     (return))))
303 wlott 1.1
304     (push-in tn-next res (ir2-component-constant-tns component))
305     res))
306    
307    
308     ;;;; TN referencing:
309    
310     ;;; Reference-TN -- Interface
311     ;;;
312     ;;; Make a TN-Ref that references TN and return it. Write-P should be true
313     ;;; if this is a write reference, otherwise false. All we do other than
314     ;;; calling the constructor is add the reference to the TN's references.
315     ;;;
316     (defun reference-tn (tn write-p)
317     (declare (type tn tn) (type boolean write-p))
318     (let ((res (make-tn-ref tn write-p)))
319     (if write-p
320     (push-in tn-ref-next res (tn-writes tn))
321     (push-in tn-ref-next res (tn-reads tn)))
322     res))
323    
324    
325     ;;; Reference-TN-List -- Interface
326     ;;;
327     ;;; Make TN-Refs to reference each TN in TNs, linked together by
328     ;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is
329     ;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
330     ;;; result if there are no TNs.
331     ;;;
332     (defun reference-tn-list (tns write-p &optional more)
333     (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
334     (if tns
335     (let* ((first (reference-tn (first tns) write-p))
336     (prev first))
337     (dolist (tn (rest tns))
338     (let ((res (reference-tn tn write-p)))
339     (setf (tn-ref-across prev) res)
340     (setq prev res)))
341     (setf (tn-ref-across prev) more)
342     first)
343     more))
344    
345    
346     ;;; Delete-TN-Ref -- Interface
347     ;;;
348     ;;; Remove Ref from the references for its associated TN.
349     ;;;
350     (defun delete-tn-ref (ref)
351     (declare (type tn-ref ref))
352     (if (tn-ref-write-p ref)
353     (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
354     (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
355     (undefined-value))
356    
357    
358     ;;; Change-TN-Ref-TN -- Interface
359     ;;;
360     ;;; Do stuff to change the TN referenced by Ref. We remove Ref from it's
361     ;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
362     ;;;
363     (defun change-tn-ref-tn (ref tn)
364     (declare (type tn-ref ref) (type tn tn))
365     (delete-tn-ref ref)
366     (setf (tn-ref-tn ref) tn)
367     (if (tn-ref-write-p ref)
368     (push-in tn-ref-next ref (tn-writes tn))
369     (push-in tn-ref-next ref (tn-reads tn)))
370     (undefined-value))
371    
372    
373     ;;;; Random utilities:
374    
375 ram 1.2
376     ;;; Emit-Move-Template -- Internal
377     ;;;
378     ;;; Emit a move-like template determined at run-time, with X as the argument
379     ;;; and Y as the result. Useful for move, coerce and type-check templates. If
380     ;;; supplied, then insert before VOP, otherwise insert at then end of the
381     ;;; block. Returns the last VOP inserted.
382     ;;;
383     (defun emit-move-template (node block template x y &optional before)
384     (declare (type node node) (type ir2-block block)
385     (type template template) (type tn x y))
386     (let ((arg (reference-tn x nil))
387     (result (reference-tn y t)))
388     (multiple-value-bind
389     (first last)
390     (funcall (template-emit-function template) node block template arg
391     result)
392     (insert-vop-sequence first last block before)
393     last)))
394    
395    
396     ;;; EMIT-LOAD-TEMPLATE -- Internal
397     ;;;
398     ;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
399     ;;;
400     (defun emit-load-template (node block template x y info &optional before)
401     (declare (type node node) (type ir2-block block)
402     (type template template) (type tn x y))
403     (let ((arg (reference-tn x nil))
404     (result (reference-tn y t)))
405     (multiple-value-bind
406     (first last)
407     (funcall (template-emit-function template) node block template arg
408     result info)
409     (insert-vop-sequence first last block before)
410     last)))
411    
412    
413     ;;; EMIT-MOVE-ARG-TEMPLATE -- Internal
414     ;;;
415     ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
416     ;;;
417     (defun emit-move-arg-template (node block template x f y &optional before)
418     (declare (type node node) (type ir2-block block)
419     (type template template) (type tn x f y))
420     (let ((x-ref (reference-tn x nil))
421     (f-ref (reference-tn f nil))
422     (y-ref (reference-tn y t)))
423     (setf (tn-ref-across x-ref) f-ref)
424     (multiple-value-bind
425     (first last)
426     (funcall (template-emit-function template) node block template x-ref
427     y-ref)
428     (insert-vop-sequence first last block before)
429     last)))
430    
431    
432     ;;; EMIT-CONTEXT-TEMPLATE -- Internal
433     ;;;
434     ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
435     ;;;
436     (defun emit-context-template (node block template y &optional before)
437     (declare (type node node) (type ir2-block block)
438     (type template template) (type tn y))
439     (let ((y-ref (reference-tn y t)))
440     (multiple-value-bind
441     (first last)
442     (funcall (template-emit-function template) node block template nil
443     y-ref)
444     (insert-vop-sequence first last block before)
445     last)))
446    
447    
448     ;;; Block-Label -- Interface
449     ;;;
450     ;;; Return the label marking the start of Block, assigning one if necessary.
451     ;;;
452     (defun block-label (block)
453     (declare (type cblock block))
454     (let ((2block (block-info block)))
455     (or (ir2-block-%label 2block)
456     (setf (ir2-block-%label 2block) (gen-label)))))
457    
458    
459     ;;; Drop-Thru-P -- Interface
460     ;;;
461     ;;; Return true if Block is emitted immediately after the block ended by
462     ;;; Node.
463     ;;;
464     (defun drop-thru-p (node block)
465     (declare (type node node) (type cblock block))
466     (let ((next-block (ir2-block-next (block-info (node-block node)))))
467     (assert (eq node (block-last (node-block node))))
468     (eq next-block (block-info block))))
469    
470    
471     ;;; Insert-VOP-Sequence -- Interface
472     ;;;
473     ;;; Link a list of VOPs from First to Last into Block, Before the specified
474     ;;; VOP. If Before is NIL, insert at the end.
475     ;;;
476     (defun insert-vop-sequence (first last block before)
477     (declare (type vop first last) (type ir2-block block)
478     (type (or vop null) before))
479     (if before
480     (let ((prev (vop-prev before)))
481     (setf (vop-prev first) prev)
482     (if prev
483     (setf (vop-next prev) first)
484     (setf (ir2-block-start-vop block) first))
485     (setf (vop-next last) before)
486     (setf (vop-prev before) last))
487     (let ((current (ir2-block-last-vop block)))
488     (setf (vop-prev first) current)
489     (setf (ir2-block-last-vop block) last)
490     (if current
491     (setf (vop-next current) first)
492     (setf (ir2-block-start-vop block) first))))
493     (undefined-value))
494    
495    
496     ;;; DELETE-VOP -- Interface
497     ;;;
498     ;;; Delete all of the TN-Refs associated with VOP and remove VOP from the
499     ;;; IR2.
500     ;;;
501     (defun delete-vop (vop)
502     (declare (type vop vop))
503     (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
504     ((null ref))
505     (delete-tn-ref ref))
506    
507     (let ((prev (vop-prev vop))
508     (next (vop-next vop))
509     (block (vop-block vop)))
510     (if prev
511     (setf (vop-next prev) next)
512     (setf (ir2-block-start-vop block) next))
513     (if next
514     (setf (vop-prev next) prev)
515     (setf (ir2-block-last-vop block) prev)))
516    
517     (undefined-value))
518    
519    
520 wlott 1.1 ;;; Make-N-TNs -- Interface
521     ;;;
522     ;;; Return a list of N normal TNs of the specified primitive type.
523     ;;;
524     (defun make-n-tns (n ptype)
525     (declare (type unsigned-byte n) (type primitive-type ptype))
526     (collect ((res))
527     (dotimes (i n)
528     (res (make-normal-tn ptype)))
529     (res)))
530    
531    
532     ;;; Location= -- Interface
533     ;;;
534     ;;; Return true if X and Y are packed in the same location, false otherwise.
535     ;;; This is false if either operand is constant.
536     ;;;
537     (defun location= (x y)
538     (declare (type tn x y))
539     (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
540     (eql (tn-offset x) (tn-offset y))
541     (not (or (eq (tn-kind x) :constant)
542     (eq (tn-kind y) :constant)))))
543    
544    
545     ;;; TN-Value -- Interface
546     ;;;
547     ;;; Return the value of an immediate constant TN.
548     ;;;
549     (defun tn-value (tn)
550     (declare (type tn tn))
551     (assert (member (tn-kind tn) '(:constant :cached-constant)))
552     (constant-value (tn-leaf tn)))
553    
554    
555     ;;; Force-TN-To-Stack -- Interface
556     ;;;
557 ram 1.2 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
558     ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
559     ;;; but since we change the SC to an unbounded one, we should always succeed in
560     ;;; packing it in that SC.
561 wlott 1.1 ;;;
562     (defun force-tn-to-stack (tn)
563     (declare (type tn tn))
564 ram 1.2 (let ((sc (tn-sc tn)))
565     (unless (and (not (sc-save-p sc))
566     (eq (sb-kind (sc-sb sc)) :unbounded))
567     (dolist (alt (sc-alternate-scs sc)
568     (error "SC ~S has no :unbounded :save-p NIL alternate SC."
569     (sc-name sc)))
570     (when (and (not (sc-save-p alt))
571     (eq (sb-kind (sc-sb alt)) :unbounded))
572     (setf (tn-sc tn) alt)
573     (return)))))
574 wlott 1.1 (undefined-value))
575    

  ViewVC Help
Powered by ViewVC 1.1.5