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

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5