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

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5