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

Contents of /src/compiler/vmdef.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.51: +7 -7 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/vmdef.lisp,v 1.52 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains implementation-independent facilities used for
13 ;;; defining the compiler's interface to the VM in a given implementation.
14 ;;;
15 ;;; Written by Rob MacLachlan
16 ;;;
17 (in-package :c)
18
19 (intl:textdomain "cmucl")
20
21 (export '(template-or-lose sc-or-lose sb-or-lose sc-number-or-lose
22 meta-sc-or-lose meta-sb-or-lose meta-sc-number-or-lose
23 primitive-type-or-lose note-this-location note-next-instruction))
24
25 ;;; Template-Or-Lose -- Internal
26 ;;;
27 ;;; Return the template having the specified name, or die trying.
28 ;;;
29 (defun template-or-lose (x &optional (backend *target-backend*))
30 (the template
31 (or (gethash x (backend-template-names backend))
32 (error (intl:gettext "~S is not a defined template.") x))))
33
34
35 ;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose -- Internal
36 ;;;
37 ;;; Return the SC structure, SB structure or SC number corresponding to a
38 ;;; name, or die trying.
39 ;;;
40 (defun sc-or-lose (x &optional (backend *target-backend*))
41 (the sc
42 (or (gethash x (backend-sc-names backend))
43 (error (intl:gettext "~S is not a defined storage class.") x))))
44 ;;;
45 (defun sb-or-lose (x &optional (backend *target-backend*))
46 (the sb
47 (or (gethash x (backend-sb-names backend))
48 (error (intl:gettext "~S is not a defined storage base.") x))))
49 ;;;
50 (defun sc-number-or-lose (x &optional (backend *target-backend*))
51 (the sc-number (sc-number (sc-or-lose x backend))))
52
53
54 ;;; META-SC-OR-LOSE, META-SB-OR-LOSE, META-SC-NUMBER-OR-LOSE -- Internal
55 ;;;
56 ;;; Like the non-meta versions, but go for the meta-compile-time info.
57 ;;; These should not be used after load time, since compiling the compiler
58 ;;; changes the definitions.
59 ;;;
60 (defun meta-sc-or-lose (x)
61 (the sc
62 (or (gethash x (backend-meta-sc-names *target-backend*))
63 (error (intl:gettext "~S is not a defined storage class.") x))))
64 ;;;
65 (defun meta-sb-or-lose (x)
66 (the sb
67 (or (gethash x (backend-meta-sb-names *target-backend*))
68 (error (intl:gettext "~S is not a defined storage base.") x))))
69 ;;;
70 (defun meta-sc-number-or-lose (x)
71 (the sc-number (sc-number (meta-sc-or-lose x))))
72
73
74 ;;;; Side-Effect Classes
75
76 (def-boolean-attribute vop
77 any)
78
79
80
81 ;;;; Move/coerce definition:
82
83 ;;; COMPUTE-MOVE-COSTS -- Internal
84 ;;;
85 ;;; Compute at compiler load time the costs for moving between all SCs that
86 ;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
87 ;;;
88 (defun compute-move-costs (from-sc to-sc cost)
89 (declare (type sc from-sc to-sc) (type index cost))
90 (let ((to-scn (sc-number to-sc))
91 (from-costs (sc-load-costs from-sc)))
92 (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
93 (let ((vec (sc-move-costs dest-sc))
94 (dest-costs (sc-load-costs dest-sc)))
95 (setf (svref vec (sc-number from-sc)) cost)
96 (dolist (sc (append (sc-alternate-scs from-sc)
97 (sc-constant-scs from-sc)))
98 (let* ((scn (sc-number sc))
99 (total (+ (svref from-costs scn)
100 (svref dest-costs to-scn)
101 cost))
102 (old (svref vec scn)))
103 (unless (and old (< old total))
104 (setf (svref vec scn) total))))))))
105
106
107 ;;;; Primitive type definition:
108
109 ;;; PRIMITIVE-TYPE-OR-LOSE -- Interface
110 ;;;
111 ;;; Return the primitive type corresponding to the specified name, or die
112 ;;; trying.
113 ;;;
114 (defun primitive-type-or-lose (name &optional (backend *target-backend*))
115 (the primitive-type
116 (or (gethash name (backend-primitive-type-names backend))
117 (error (intl:gettext "~S is not a defined primitive type.") name))))
118
119
120 ;;; SC-ALLOWED-BY-PRIMITIVE-TYPE -- Interface
121 ;;;
122 ;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
123 ;;; alternate or constant SCs.
124 ;;;
125 (defun sc-allowed-by-primitive-type (sc ptype)
126 (declare (type sc sc) (type primitive-type ptype))
127 (let ((scn (sc-number sc)))
128 (dolist (allowed (primitive-type-scs ptype) nil)
129 (when (eql allowed scn)
130 (return t))
131 (let ((allowed-sc (svref (backend-sc-numbers *backend*) allowed)))
132 (when (or (member sc (sc-alternate-scs allowed-sc))
133 (member sc (sc-constant-scs allowed-sc)))
134 (return t))))))
135
136
137 ;;;; Emit function generation:
138
139 (defconstant max-vop-tn-refs 256)
140
141 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
142 (defvar *using-vop-tn-refs* nil)
143
144 (defun flush-vop-tn-refs ()
145 (unless *using-vop-tn-refs*
146 (fill *vop-tn-refs* nil)))
147
148 (pushnew 'flush-vop-tn-refs *before-gc-hooks*)
149
150 (defconstant sc-bits (integer-length (1- sc-number-limit)))
151
152 (defun emit-generic-vop (node block template args results &optional info)
153 (%emit-generic-vop node block template args results info))
154
155 (defun %emit-generic-vop (node block template args results info)
156 (let* ((vop (make-vop block node template args results))
157 (num-args (vop-info-num-args template))
158 (last-arg (1- num-args))
159 (num-results (vop-info-num-results template))
160 (num-operands (+ num-args num-results))
161 (last-result (1- num-operands))
162 (ref-ordering (vop-info-ref-ordering template)))
163 (declare (type vop vop)
164 (type (integer 0 #.max-vop-tn-refs)
165 num-args num-results num-operands)
166 (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result)
167 (type (simple-array (mod #.max-vop-tn-refs) (*)) ref-ordering))
168 (setf (vop-codegen-info vop) info)
169 (let ((refs *vop-tn-refs*)
170 (*using-vop-tn-refs* t))
171 (declare (type (simple-vector #.max-vop-tn-refs) refs))
172 (do ((index 0 (1+ index))
173 (ref args (and ref (tn-ref-across ref))))
174 ((= index num-args))
175 (setf (svref refs index) ref))
176 (do ((index num-args (1+ index))
177 (ref results (and ref (tn-ref-across ref))))
178 ((= index num-operands))
179 (setf (svref refs index) ref))
180 (let ((temps (vop-info-temps template)))
181 (when temps
182 (let ((index num-operands)
183 (prev nil))
184 (dotimes (i (length temps))
185 (let* ((temp (aref temps i))
186 (tn (if (logbitp 0 temp)
187 (make-wired-tn nil
188 (ldb (byte sc-bits 1) temp)
189 (ash temp (- (1+ sc-bits))))
190 (make-restricted-tn nil (ash temp -1))))
191 (write-ref (reference-tn tn t)))
192 (setf (aref refs index) (reference-tn tn nil))
193 (setf (aref refs (1+ index)) write-ref)
194 (if prev
195 (setf (tn-ref-across prev) write-ref)
196 (setf (vop-temps vop) write-ref))
197 (setf prev write-ref)
198 (incf index 2))))))
199 (let ((prev nil))
200 (flet ((add-ref (ref)
201 (setf (tn-ref-vop ref) vop)
202 (setf (tn-ref-next-ref ref) prev)
203 (setf prev ref)))
204 (declare (inline add-ref))
205 (dotimes (i (length ref-ordering))
206 (let* ((index (aref ref-ordering i))
207 (ref (aref refs index)))
208 (if (or (= index last-arg) (= index last-result))
209 (do ((ref ref (tn-ref-across ref)))
210 ((null ref))
211 (add-ref ref))
212 (add-ref ref)))))
213 (setf (vop-refs vop) prev))
214 (let ((targets (vop-info-targets template)))
215 (when targets
216 (dotimes (i (length targets))
217 (let ((target (aref targets i)))
218 (target-if-desirable (aref refs (ldb (byte 8 8) target))
219 (aref refs (ldb (byte 8 0) target))))))))
220 (values vop vop)))
221
222
223 ;;;; Function translation stuff:
224
225 ;;; Adjoin-Template -- Internal
226 ;;;
227 ;;; Add Template into List, removing any old template with the same name.
228 ;;; We also maintain the increasing cost ordering.
229 ;;;
230 (defun adjoin-template (template list)
231 (declare (type template template) (list list))
232 (sort (cons template
233 (remove (template-name template) list
234 :key #'template-name))
235 #'<=
236 :key #'template-cost))
237
238
239
240 ;;; Template-Type-Specifier -- Internal
241 ;;;
242 ;;; Return a function type specifier describing Template's type computed
243 ;;; from the operand type restrictions.
244 ;;;
245 (defun template-type-specifier (template)
246 (declare (type template template))
247 (flet ((convert (types more-types)
248 (flet ((frob (x)
249 (if (eq x '*)
250 't
251 (ecase (first x)
252 (:or `(or ,@(mapcar #'(lambda (type)
253 (type-specifier
254 (primitive-type-type
255 type)))
256 (rest x))))
257 (:constant `(constant-argument ,(third x)))))))
258 `(,@(mapcar #'frob types)
259 ,@(when more-types
260 `(&rest ,(frob more-types)))))))
261 (let* ((args (convert (template-arg-types template)
262 (template-more-args-type template)))
263 (result-restr (template-result-types template))
264 (results (if (eq result-restr :conditional)
265 '(boolean)
266 (convert result-restr
267 (cond ((template-more-results-type template))
268 ((/= (length result-restr) 1) '*)
269 (t nil))))))
270 `(function ,args
271 ,(if (= (length results) 1)
272 (first results)
273 `(values ,@results))))))
274
275
276 ;;;; Random utilities.
277
278 ;;; NOTE-THIS-LOCATION -- Interface
279 ;;;
280 (defun note-this-location (vop kind)
281 "NOTE-THIS-LOCATION VOP Kind
282 Note that the current code location is an interesting (to the debugger)
283 location of the specified Kind. VOP is the VOP responsible for this code.
284 This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so
285 that the live set is computed."
286 (let ((lab (gen-label)))
287 (emit-label lab)
288 (note-debug-location vop lab kind)))
289
290 ;;; NOTE-NEXT-INSTRUCTION -- interface.
291 ;;;
292 (defun note-next-instruction (vop kind)
293 "NOTE-NEXT-INSTRUCTION VOP Kind
294 Similar to NOTE-THIS-LOCATION, except the use the location of the next
295 instruction for the code location, wherever the scheduler decided to put
296 it."
297 (let ((loc (note-debug-location vop nil kind)))
298 (new-assem:emit-postit #'(lambda (segment posn)
299 (declare (ignore segment))
300 (setf (location-info-label loc) posn))))
301 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5