/[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 - (show 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 ;;; -*- 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 (not (eq (tn-kind tn) :normal))
54 (tn-reads tn)
55 (tn-writes tn))
56 (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 :normal type nil)))
83 (push-in tn-next res (ir2-component-normal-tns component))
84 res))
85
86
87 ;;; MAKE-REPRESENTATION-TN -- Interface
88 ;;;
89 ;;; Create a normal packed TN with representation indicated by SCN.
90 ;;;
91 (defun make-representation-tn (ptype scn)
92 (declare (type primitive-type ptype) (type sc-number scn))
93 (let* ((component (component-info *compile-component*))
94 (res (make-tn (incf (ir2-component-global-tn-counter component))
95 :normal ptype (svref *sc-numbers* scn))))
96 (push-in tn-next res (ir2-component-normal-tns component))
97 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 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
105 ;;; temporaries.
106 ;;;
107 (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 (let* ((component (component-info *compile-component*))
111 (res (make-tn (incf (ir2-component-global-tn-counter component))
112 :normal ptype (svref *sc-numbers* scn))))
113 (setf (tn-offset res) offset)
114 (push-in tn-next res (ir2-component-wired-tns component))
115 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 res))
130
131
132 ;;; Environment-Live-TN -- Interface
133 ;;;
134 ;;; Make TN be live throughout environment. TN must be referenced only in
135 ;;; Env. Return TN.
136 ;;;
137 (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
144
145 ;;; 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 ;;; 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
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 ;;; 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 ;;; 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 ;;;
460 (defun force-tn-to-stack (tn)
461 (declare (type tn tn))
462 (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 (undefined-value))
473
474
475 ;;; TN-Environment -- Interface
476 ;;;
477 ;;; 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 ;;;
481 (defun tn-environment (tn)
482 (declare (type tn tn))
483 (let ((ref (or (tn-reads tn) (tn-writes tn))))
484 (assert ref)
485 (lambda-environment
486 (block-lambda
487 (ir2-block-block (vop-block (tn-ref-vop ref)))))))

  ViewVC Help
Powered by ViewVC 1.1.5