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

Contents of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5