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

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5