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

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5