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

Contents of /src/compiler/represent.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months 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.39: +22 -22 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/represent.lisp,v 1.40 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the implementation independent code for the
13 ;;; representation selection phase in the compiler. Representation selection
14 ;;; decides whether to use non-descriptor representations for objects and emits
15 ;;; the appropriate representation-specific move and coerce vops.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;;
19 (in-package "C")
20 (intl:textdomain "cmucl")
21
22
23 ;;;; Error routines:
24 ;;;
25 ;;; Problems in the VM definition often show up here, so we try to be as
26 ;;; implementor-friendly as possible.
27 ;;;
28
29 ;;; GET-OPERAND-INFO -- Interface
30 ;;;
31 ;;; Given a TN ref for a VOP argument or result, return these values:
32 ;;; 1] True if the operand is an argument, false otherwise.
33 ;;; 2] The ordinal position of the operand.
34 ;;; 3] True if the operand is a more operand, false otherwise.
35 ;;; 4] The costs for this operand.
36 ;;; 5] The load-scs vector for this operand (NIL if more-p.)
37 ;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the
38 ;;; currently record ones.
39 ;;;
40 (defun get-operand-info (ref)
41 (declare (type tn-ref ref))
42 (let* ((arg-p (not (tn-ref-write-p ref)))
43 (vop (tn-ref-vop ref))
44 (info (vop-info vop)))
45 (flet ((frob (refs costs load more-cost)
46 (do ((refs refs (tn-ref-across refs))
47 (costs costs (cdr costs))
48 (load load (cdr load))
49 (n 0 (1+ n)))
50 ((null costs)
51 (assert more-cost)
52 (values arg-p
53 (+ n
54 (or (position-in #'tn-ref-across ref refs)
55 (error (intl:gettext "Couldn't find REF?")))
56 1)
57 t
58 more-cost
59 nil
60 nil))
61 (when (eq refs ref)
62 (let ((parse (vop-parse-or-lose (vop-info-name info)
63 *backend*)))
64 (multiple-value-bind
65 (ccosts cscs)
66 (compute-loading-costs
67 (elt (if arg-p
68 (vop-parse-args parse)
69 (vop-parse-results parse))
70 n)
71 arg-p)
72
73 (return
74 (values arg-p
75 (1+ n)
76 nil
77 (car costs)
78 (car load)
79 (not (and (equalp ccosts (car costs))
80 (equalp cscs (car load))))))))))))
81 (if arg-p
82 (frob (vop-args vop) (vop-info-arg-costs info)
83 (vop-info-arg-load-scs info)
84 (vop-info-more-arg-costs info))
85 (frob (vop-results vop) (vop-info-result-costs info)
86 (vop-info-result-load-scs info)
87 (vop-info-more-result-costs info))))))
88
89
90 ;;; LISTIFY-RESTRICTIONS -- Interface
91 ;;;
92 ;;; Convert a load-costs vector to the list of SCs allowed by the operand
93 ;;; restriction.
94 ;;;
95 (defun listify-restrictions (restr)
96 (declare (type sc-vector restr))
97 (collect ((res))
98 (dotimes (i sc-number-limit)
99 (when (eq (svref restr i) t)
100 (res (svref (backend-sc-numbers *backend*) i))))
101 (res)))
102
103
104 ;;; BAD-COSTS-ERROR -- Internal
105 ;;;
106 ;;; Try to give a helpful error message when Ref has no cost specified for
107 ;;; some SC allowed by the TN's primitive-type.
108 ;;;
109 (defun bad-costs-error (ref)
110 (declare (type tn-ref ref))
111 (let* ((tn (tn-ref-tn ref))
112 (ptype (tn-primitive-type tn)))
113 (multiple-value-bind (arg-p pos more-p costs load-scs incon)
114 (get-operand-info ref)
115 (collect ((losers))
116 (dolist (scn (primitive-type-scs ptype))
117 (unless (svref costs scn)
118 (losers (svref (backend-sc-numbers *backend*) scn))))
119
120 (unless (losers)
121 (error (intl:gettext "Representation selection flamed out for no obvious reason.~@
122 Try again after recompiling the VM definition.")))
123
124 (error (intl:gettext "~S is not valid as the ~:R ~:[result~;argument~] to the~@
125 ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
126 ~:[which cannot be coerced or loaded into the allowed SCs:~
127 ~% ~S~;~*~]~:[~;~@
128 Current cost info inconsistent with that in effect at compile ~
129 time. Recompile.~%Compilation order may be incorrect.~]")
130 tn pos arg-p
131 (template-name (vop-info (tn-ref-vop ref)))
132 (primitive-type-name ptype)
133 (mapcar #'sc-name (losers))
134 more-p
135 (unless more-p
136 (mapcar #'sc-name (listify-restrictions load-scs)))
137 incon)))))
138
139
140 ;;; BAD-COERCE-ERROR -- Internal
141 ;;;
142 ;;; Try to give a helpful error message when we fail to do a coercion
143 ;;; for some reason.
144 ;;;
145 (defun bad-coerce-error (op)
146 (declare (type tn-ref op))
147 (let* ((op-tn (tn-ref-tn op))
148 (op-sc (tn-sc op-tn))
149 (op-scn (sc-number op-sc))
150 (ptype (tn-primitive-type op-tn))
151 (write-p (tn-ref-write-p op)))
152 (multiple-value-bind (arg-p pos more-p costs load-scs incon)
153 (get-operand-info op)
154 (declare (ignore costs more-p))
155 (collect ((load-lose)
156 (no-move-scs)
157 (move-lose))
158 (dotimes (i sc-number-limit)
159 (let ((i-sc (svref (backend-sc-numbers *backend*) i)))
160 (when (eq (svref load-scs i) t)
161 (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
162 (load-lose i-sc))
163 ((not (find-move-vop op-tn write-p i-sc ptype
164 #'sc-move-vops))
165 (let ((vops (if write-p
166 (svref (sc-move-vops op-sc) i)
167 (svref (sc-move-vops i-sc) op-scn))))
168 (if vops
169 (dolist (vop vops) (move-lose (template-name vop)))
170 (no-move-scs i-sc))))
171 (t
172 (error (intl:gettext "Representation selection flamed out for no ~
173 obvious reason.")))))))
174
175 (unless (or (load-lose) (no-move-scs) (move-lose))
176 (error (intl:gettext "Representation selection flamed out for no obvious reason.~@
177 Try again after recompiling the VM definition.")))
178
179 (error (intl:gettext "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
180 ~% ~S~%Primitive type: ~S~@
181 SC restrictions:~% ~S~@
182 ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
183 ~@[No move VOPs are defined to coerce to these allowed SCs:~
184 ~% ~S~%~]~
185 ~@[These move VOPs couldn't be used due to operand type ~
186 restrictions:~% ~S~%~]~
187 ~:[~;~@
188 Current cost info inconsistent with that in effect at compile ~
189 time. Recompile.~%Compilation order may be incorrect.~]")
190 op-tn pos arg-p
191 (template-name (vop-info (tn-ref-vop op)))
192 (primitive-type-name ptype)
193 (mapcar #'sc-name (listify-restrictions load-scs))
194 (mapcar #'sc-name (load-lose))
195 (mapcar #'sc-name (no-move-scs))
196 (move-lose)
197 incon)))))
198
199
200 ;;; BAD-MOVE-ARG-ERROR -- Internal
201 ;;;
202 (defun bad-move-arg-error (val pass)
203 (declare (type tn val pass))
204 (error (intl:gettext "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~
205 ~S (SC ~S.)")
206 val (sc-name (tn-sc val))
207 pass (sc-name (tn-sc pass))))
208
209
210 ;;;; VM Consistency Checking:
211 ;;;
212 ;;; We do some checking of the consistency of the VM definition at load
213 ;;; time.
214
215 ;;; CHECK-MOVE-FUNCTION-CONSISTENCY -- Interface
216 ;;;
217 (defun check-move-function-consistency ()
218 (dotimes (i sc-number-limit)
219 (let ((sc (svref (backend-sc-numbers *backend*) i)))
220 (when sc
221 (let ((moves (sc-move-functions sc)))
222 (dolist (const (sc-constant-scs sc))
223 (unless (svref moves (sc-number const))
224 (warn (intl:gettext "No move function defined to load SC ~S from constant ~
225 SC ~S.")
226 (sc-name sc) (sc-name const))))
227
228 (dolist (alt (sc-alternate-scs sc))
229 (unless (svref moves (sc-number alt))
230 (warn (intl:gettext "No move function defined to load SC ~S from alternate ~
231 SC ~S.")
232 (sc-name sc) (sc-name alt)))
233 (unless (svref (sc-move-functions alt) i)
234 (warn (intl:gettext "No move function defined to save SC ~S to alternate ~
235 SC ~S.")
236 (sc-name sc) (sc-name alt)))))))))
237
238
239 ;;;; Representation selection:
240
241 ;;; VOPs that we ignore in initial cost computation. We ignore SET in the
242 ;;; hopes that nobody is setting specials inside of loops. We ignore
243 ;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the
244 ;;; result. Notes are suppressed for T-C-E as well, since we don't need to
245 ;;; worry about the efficiency of that case.
246 ;;;
247 (defconstant ignore-cost-vops '(set type-check-error))
248 (defconstant suppress-note-vops '(type-check-error))
249
250 (declaim (start-block select-tn-representation))
251
252 ;;; ADD-REPRESENTATION-COSTS -- Local
253 ;;;
254 ;;; We special-case the move VOP, since using this costs for the normal MOVE
255 ;;; would spuriously encourage descriptor representations. We won't actually
256 ;;; need to coerce to descriptor and back, since we will replace the MOVE with
257 ;;; a specialized move VOP. What we do is look at the other operand. If its
258 ;;; representation has already been chosen (e.g. if it is wired), then we use
259 ;;; the appropriate move costs, otherwise we just ignore the references.
260 ;;;
261 (defun add-representation-costs (refs scs costs
262 ops-slot costs-slot more-costs-slot
263 write-p)
264 (do ((ref refs (tn-ref-next ref)))
265 ((null ref))
266 (flet ((add-costs (cost)
267 (dolist (scn scs)
268 (let ((res (svref cost scn)))
269 (unless res
270 (bad-costs-error ref))
271 (incf (svref costs scn) res)))))
272 (let* ((vop (tn-ref-vop ref))
273 (info (vop-info vop)))
274 (case (vop-info-name info)
275 (#.ignore-cost-vops)
276 (move
277 (let ((rep (tn-sc
278 (tn-ref-tn
279 (if write-p
280 (vop-args vop)
281 (vop-results vop))))))
282 (when rep
283 (if write-p
284 (dolist (scn scs)
285 (let ((res (svref (sc-move-costs
286 (svref (backend-sc-numbers *backend*)
287 scn))
288 (sc-number rep))))
289 (when res
290 (incf (svref costs scn) res))))
291 (dolist (scn scs)
292 (let ((res (svref (sc-move-costs rep) scn)))
293 (when res
294 (incf (svref costs scn) res))))))))
295 (t
296 (do ((cost (funcall costs-slot info) (cdr cost))
297 (op (funcall ops-slot vop) (tn-ref-across op)))
298 ((null cost)
299 (add-costs (funcall more-costs-slot info)))
300 (when (eq op ref)
301 (add-costs (car cost))
302 (return))))))))
303 (undefined-value))
304
305
306 ;;; SELECT-TN-REPRESENTATION -- Internal
307 ;;;
308 ;;; Return the best representation for a normal TN. SCs is a list
309 ;;; of the SC numbers of the SCs to select from. Costs is a scratch
310 ;;; vector.
311 ;;;
312 ;;; What we do is sum the costs for each reference to TN in each of
313 ;;; the SCs, and then return the SC having the lowest cost. A second
314 ;;; value is returned which is true when the selection is unique which
315 ;;; is often not the case for the MOVE VOP.
316 ;;;
317 (defun select-tn-representation (tn scs costs)
318 (declare (type tn tn) (type sc-vector costs)
319 (inline add-representation-costs))
320 (dolist (scn scs)
321 (setf (svref costs scn) 0))
322
323 (add-representation-costs (tn-reads tn) scs costs
324 #'vop-args #'vop-info-arg-costs
325 #'vop-info-more-arg-costs
326 nil)
327 (add-representation-costs (tn-writes tn) scs costs
328 #'vop-results #'vop-info-result-costs
329 #'vop-info-more-result-costs
330 t)
331
332 (let ((min most-positive-fixnum)
333 (min-scn nil)
334 (unique nil))
335 (dolist (scn scs)
336 (let ((cost (svref costs scn)))
337 (cond ((= cost min)
338 (setf unique nil))
339 ((< cost min)
340 (setq min cost)
341 (setq min-scn scn)
342 (setq unique t)))))
343 (values (svref (backend-sc-numbers *backend*) min-scn) unique)))
344
345 (declaim (end-block))
346
347
348 ;;; NOTE-NUMBER-STACK-TN -- Internal
349 ;;;
350 ;;; Prepare for the possibility of a TN being allocated on the number stack
351 ;;; by setting NUMBER-STACK-P in all functions that TN is referenced in and in
352 ;;; all the functions in their tail sets. Refs is a TN-Refs list of references
353 ;;; to the TN.
354 ;;;
355 (defun note-number-stack-tn (refs)
356 (declare (type (or tn-ref null) refs))
357
358 (do ((ref refs (tn-ref-next ref)))
359 ((null ref))
360 (let* ((lambda (block-home-lambda
361 (ir2-block-block
362 (vop-block (tn-ref-vop ref)))))
363 (tails (lambda-tail-set lambda)))
364 (flet ((frob (fun)
365 (setf (ir2-environment-number-stack-p
366 (environment-info
367 (lambda-environment fun)))
368 t)))
369 (frob lambda)
370 (when tails
371 (dolist (fun (tail-set-functions tails))
372 (frob fun))))))
373
374 (undefined-value))
375
376
377 ;;; GET-OPERAND-NAME -- Internal
378 ;;;
379 ;;; If TN is a variable, return the name. If TN is used by a VOP emitted
380 ;;; for a return, then return a string indicating this. Otherwise, return NIL.
381 ;;;
382 (defun get-operand-name (tn arg-p)
383 (declare (type tn tn))
384 (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
385 (reads (tn-reads tn))
386 (leaf (tn-leaf actual)))
387 (cond ((lambda-var-p leaf) (leaf-name leaf))
388 ((and (not arg-p) reads
389 (return-p (vop-node (tn-ref-vop reads))))
390 (intl:gettext "<return value>"))
391 (t
392 nil))))
393
394
395 ;;; DO-COERCE-EFFICIENCY-NOTE -- Internal
396 ;;;
397 ;;; If policy indicates, give an efficiency note for doing the a coercion
398 ;;; Vop, where Op is the operand we are coercing for and Dest-TN is the
399 ;;; distinct destination in a move.
400 ;;;
401 (defun do-coerce-efficiency-note (vop op dest-tn)
402 (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
403 (let* ((note (or (template-note vop) (template-name vop)))
404 (cost (template-cost vop))
405 (op-vop (tn-ref-vop op))
406 (op-node (vop-node op-vop))
407 (op-tn (tn-ref-tn op))
408 (*compiler-error-context* op-node))
409 (cond ((eq (tn-kind op-tn) :constant))
410 ((policy op-node (<= speed brevity) (<= space brevity)))
411 ((member (template-name (vop-info op-vop)) suppress-note-vops))
412 ((null dest-tn)
413 (let* ((op-info (vop-info op-vop))
414 (op-note (or (template-note op-info)
415 (template-name op-info)))
416 (arg-p (not (tn-ref-write-p op)))
417 (name (get-operand-name op-tn arg-p))
418 (pos (1+ (or (position-in #'tn-ref-across op
419 (if arg-p
420 (vop-args op-vop)
421 (vop-results op-vop)))
422 (error (intl:gettext "Couldn't fine op? Bug!"))))))
423 (compiler-note
424 _N"Doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
425 The ~:R ~:[result~;argument~] of ~A."
426 note cost name arg-p name
427 pos arg-p op-note)))
428 (t
429 (compiler-note _N"Doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]."
430 note cost (get-operand-name op-tn t)
431 (get-operand-name dest-tn nil)))))
432 (undefined-value))
433
434
435 ;;; FIND-MOVE-VOP -- Internal
436 ;;;
437 ;;; Find a move VOP to move from the operand OP-TN to some other
438 ;;; representation corresponding to OTHER-SC and OTHER-PTYPE. Slot is the SC
439 ;;; slot that we grab from (move or move-argument). Write-P indicates that OP
440 ;;; is a VOP result, so OP is the move result and other is the arg, otherwise
441 ;;; OP is the arg and other is the result.
442 ;;;
443 ;;; If an operand is of primitive type T, then we use the type of the other
444 ;;; operand instead, effectively intersecting the argument and result type
445 ;;; assertions. This way, a move VOP can restrict whichever operand makes more
446 ;;; sense, without worrying about which operand has the type info.
447 ;;;
448 (defun find-move-vop (op-tn write-p other-sc other-ptype slot)
449 (declare (type tn op-tn) (type sc other-sc)
450 (type primitive-type other-ptype)
451 (type function slot))
452 (let* ((op-sc (tn-sc op-tn))
453 (op-scn (sc-number op-sc))
454 (other-scn (sc-number other-sc))
455 (any-ptype (backend-any-primitive-type *backend*))
456 (op-ptype (tn-primitive-type op-tn)))
457 (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype))
458 (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype)))
459 (dolist (info (if write-p
460 (svref (funcall slot op-sc) other-scn)
461 (svref (funcall slot other-sc) op-scn))
462 nil)
463 (when (and (operand-restriction-ok
464 (first (template-arg-types info))
465 (if write-p other-ptype op-ptype)
466 :tn op-tn :t-ok nil)
467 (operand-restriction-ok
468 (first (template-result-types info))
469 (if write-p op-ptype other-ptype)
470 :t-ok nil))
471 (return info))))))
472
473
474 ;;; EMIT-COERCE-VOP -- Internal
475 ;;;
476 ;;; Emit a coercion VOP for Op Before the specifed VOP or die trying. SCS
477 ;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
478 ;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it
479 ;;; seems uninteresting to have more than one applicable.
480 ;;;
481 ;;; On the X86 port, stack SCs may be placed in the list of operand
482 ;;; preferred SCs, and to prevent these stack SCs being selected when
483 ;;; a register SC is available the non-stack SCs are searched first.
484 ;;;
485 ;;; What we do is look at each SC allowed by both the operand restriction
486 ;;; and the operand primitive-type, and see if there is a move VOP which moves
487 ;;; between the operand's SC and load SC. If we find such a VOP, then we make
488 ;;; a TN having the load SC as the representation.
489 ;;;
490 ;;; Dest-TN is the TN that we are moving to, for a move or move-arg. This
491 ;;; is only for efficiency notes.
492 ;;;
493 ;;; If the TN is an unused result TN, then we don't actually emit the move;
494 ;;; we just change to the right kind of TN.
495 ;;;
496 (defun emit-coerce-vop (op dest-tn scs before)
497 (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
498 (type (or tn null) dest-tn))
499 (let* ((op-tn (tn-ref-tn op))
500 (ptype (tn-primitive-type op-tn))
501 (write-p (tn-ref-write-p op))
502 (vop (tn-ref-vop op))
503 (node (vop-node vop))
504 (block (vop-block vop)))
505 (flet ((check-sc (scn sc)
506 (when (sc-allowed-by-primitive-type sc ptype)
507 (let ((res (find-move-vop op-tn write-p sc ptype
508 #'sc-move-vops)))
509 (when res
510 (when (>= (vop-info-cost res)
511 *efficiency-note-cost-threshold*)
512 (do-coerce-efficiency-note res op dest-tn))
513 (let ((temp (make-representation-tn ptype scn)))
514 (change-tn-ref-tn op temp)
515 (cond
516 ((not write-p)
517 (emit-move-template node block res op-tn temp before))
518 ((and (null (tn-reads op-tn))
519 (eq (tn-kind op-tn) :normal)))
520 (t
521 (emit-move-template node block res temp op-tn
522 before))))
523 t)))))
524 ;; Search the non-stack load SCs first.
525 (dotimes (scn sc-number-limit)
526 (let ((sc (svref (backend-sc-numbers *backend*) scn)))
527 (when (and (eq (svref scs scn) t)
528 (not (eq (sb-kind (sc-sb sc)) :unbounded))
529 (check-sc scn sc))
530 (return-from emit-coerce-vop))))
531 ;; Search the stack SCs if the above failed.
532 (dotimes (scn sc-number-limit (bad-coerce-error op))
533 (let ((sc (svref (backend-sc-numbers *backend*) scn)))
534 (when (and (eq (svref scs scn) t)
535 (eq (sb-kind (sc-sb sc)) :unbounded)
536 (check-sc scn sc))
537 (return)))))))
538
539
540 ;;; COERCE-SOME-OPERANDS -- Internal
541 ;;;
542 ;;; Scan some operands and call EMIT-COERCE-VOP on any for which we can't
543 ;;; load the operand. The coerce VOP is inserted Before the specified VOP.
544 ;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is
545 ;;; NIL otherwise. This is only used for efficiency notes.
546 ;;;
547 (declaim (inline coerce-some-operands))
548 (defun coerce-some-operands (ops dest-tn load-scs before)
549 (declare (type (or tn-ref null) ops) (list load-scs)
550 (type (or tn null) dest-tn) (type (or vop null) before))
551 (do ((op ops (tn-ref-across op))
552 (scs load-scs (cdr scs)))
553 ((null scs))
554 (unless (svref (car scs)
555 (sc-number (tn-sc (tn-ref-tn op))))
556 (emit-coerce-vop op dest-tn (car scs) before)))
557 (undefined-value))
558
559
560 ;;; COERCE-VOP-OPERANDS -- Internal
561 ;;;
562 ;;; Emit coerce VOPs for the args and results, as needed.
563 ;;;
564 (defun coerce-vop-operands (vop)
565 (declare (type vop vop))
566 (let ((info (vop-info vop)))
567 (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
568 (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
569 (vop-next vop)))
570 (undefined-value))
571
572
573 ;;; EMIT-ARG-MOVES -- Internal
574 ;;;
575 ;;; Iterate over the more operands to a call VOP, emitting move-arg VOPs and
576 ;;; any necessary coercions. We determine which FP to use by looking at the
577 ;;; MOVE-ARGS annotation. If the vop is a :LOCAL-CALL, we insert any needed
578 ;;; coercions before the ALLOCATE-FRAME so that lifetime analysis doesn't get
579 ;;; confused (since otherwise, only passing locations are written between A-F
580 ;;; and call.)
581 ;;;
582 (defun emit-arg-moves (vop)
583 (let* ((info (vop-info vop))
584 (node (vop-node vop))
585 (block (vop-block vop))
586 (how (vop-info-move-args info))
587 (args (vop-args vop))
588 (fp-tn (tn-ref-tn args))
589 (nfp-tn (if (eq how :local-call)
590 (tn-ref-tn (tn-ref-across args))
591 nil))
592 (pass-locs (first (vop-codegen-info vop)))
593 (prev (vop-prev vop)))
594 (do ((val (do ((arg args (tn-ref-across arg))
595 (req (template-arg-types info) (cdr req)))
596 ((null req) arg))
597 (tn-ref-across val))
598 (pass pass-locs (cdr pass)))
599 ((null val)
600 (assert (null pass)))
601 (let* ((val-tn (tn-ref-tn val))
602 (pass-tn (first pass))
603 (pass-sc (tn-sc pass-tn))
604 (res (find-move-vop val-tn nil pass-sc
605 (tn-primitive-type pass-tn)
606 #'sc-move-arg-vops)))
607 (unless res
608 (bad-move-arg-error val-tn pass-tn))
609
610 (change-tn-ref-tn val pass-tn)
611 (let* ((this-fp
612 (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
613 (nfp-tn)
614 (t
615 (assert (eq how :known-return))
616 (setq nfp-tn (make-number-stack-pointer-tn))
617 (setf (tn-sc nfp-tn)
618 (svref (backend-sc-numbers *backend*)
619 (first (primitive-type-scs
620 (tn-primitive-type nfp-tn)))))
621 (emit-context-template
622 node block
623 (template-or-lose 'compute-old-nfp *backend*)
624 nfp-tn vop)
625 (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
626 nfp-tn)))
627 (new (emit-move-arg-template node block res val-tn this-fp
628 pass-tn vop))
629 (after
630 (cond ((eq how :local-call)
631 (assert (eq (vop-info-name (vop-info prev))
632 'allocate-frame))
633 prev)
634 (prev (vop-next prev))
635 (t
636 (ir2-block-start-vop block)))))
637 (coerce-some-operands (vop-args new) pass-tn
638 (vop-info-arg-load-scs res)
639 after)))))
640 (undefined-value))
641
642
643 ;;; EMIT-MOVES-AND-COERCIONS -- Internal
644 ;;;
645 ;;; Scan the IR2 looking for move operations that need to be replaced with
646 ;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
647 ;;; We delete moves to TNs that are never read at this point, rather than
648 ;;; possibly converting them to some expensive move operation.
649 ;;;
650 (defun emit-moves-and-coercions (block)
651 (declare (type ir2-block block))
652 (do ((vop (ir2-block-start-vop block)
653 (vop-next vop)))
654 ((null vop))
655 (let ((info (vop-info vop))
656 (node (vop-node vop))
657 (block (vop-block vop)))
658 (cond
659 ((eq (vop-info-name info) 'move)
660 (let* ((args (vop-args vop))
661 (x (tn-ref-tn args))
662 (y (tn-ref-tn (vop-results vop)))
663 (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
664 #'sc-move-vops)))
665 (cond ((and (null (tn-reads y))
666 (eq (tn-kind y) :normal))
667 (delete-vop vop))
668 ((eq res info))
669 (res
670 (when (>= (vop-info-cost res)
671 *efficiency-note-cost-threshold*)
672 (do-coerce-efficiency-note res args y))
673 (emit-move-template node block res x y vop)
674 (delete-vop vop))
675 (t
676 (coerce-vop-operands vop)))))
677 ((vop-info-move-args info)
678 (emit-arg-moves vop))
679 (t
680 (coerce-vop-operands vop))))))
681
682
683 ;;; NOTE-IF-NUMBER-STACK -- Internal
684 ;;;
685 ;;; If TN is in a number stack SC, make all the right annotations. Note
686 ;;; that this should be called after TN has been referenced, since it must
687 ;;; iterate over the referencing environments.
688 ;;;
689 (declaim (inline note-if-number-stack))
690 (defun note-if-number-stack (tn 2comp restricted)
691 (declare (type tn tn) (type ir2-component 2comp))
692 (when (if restricted
693 (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack)
694 (sc-number-stack-p (tn-sc tn)))
695 (unless (ir2-component-nfp 2comp)
696 (setf (ir2-component-nfp 2comp) (make-nfp-tn)))
697 (note-number-stack-tn (tn-reads tn))
698 (note-number-stack-tn (tn-writes tn)))
699 (undefined-value))
700
701 ;;; Iterate over the normal TNs, storing the depth of the deepest loop
702 ;;; that the TN is used in TN-LOOP-DEPTH.
703 (defun assign-tn-depths (component)
704 (when *loop-analyze*
705 (do-ir2-blocks (block component)
706 (do ((vop (ir2-block-start-vop block)
707 (vop-next vop)))
708 ((null vop))
709 (flet ((find-all-tns (head-fun)
710 (collect ((tns))
711 (do ((ref (funcall head-fun vop) (tn-ref-across ref)))
712 ((null ref))
713 (tns (tn-ref-tn ref)))
714 (tns))))
715 (dolist (tn (nconc (find-all-tns #'vop-args)
716 (find-all-tns #'vop-results)
717 (find-all-tns #'vop-temps)
718 ;; What does "references in this VOP
719 ;; mean"? Probably something that isn't
720 ;; useful in this context, since these
721 ;; TN-REFs are linked with TN-REF-NEXT
722 ;; instead of TN-REF-ACROSS. --JES
723 ;; 2004-09-11
724 ;; (find-all-tns #'vop-refs)
725 ))
726 (setf (tn-loop-depth tn)
727 (max (tn-loop-depth tn)
728 (let* ((ir1-block (ir2-block-block (vop-block vop)))
729 (loop (block-loop ir1-block)))
730 (if loop
731 (loop-depth loop)
732 0))))))))))
733
734 ;;; SELECT-REPRESENTATIONS -- Interface
735 ;;;
736 ;;; Entry to representation selection. First we select the representation
737 ;;; for all normal TNs, setting the TN-SC. After selecting the TN
738 ;;; representations, we set the SC for all :ALIAS TNs to be the representation
739 ;;; chosen for the original TN. We then scan all the IR2, emitting any
740 ;;; necessary coerce and move-arg VOPs. Finally, we scan all TNs looking for
741 ;;; ones that might be placed on the number stack, noting this so that the
742 ;;; number-FP can be allocated. This must be done last, since references in
743 ;;; new environments may be introduced by MOVE-ARG insertion.
744 ;;;
745 (defun select-representations (component)
746 (let ((costs (make-array sc-number-limit))
747 (2comp (component-info component)))
748
749 ;; Compute loop depths for each TN in the component.
750 (assign-tn-depths component)
751
752 ;; First pass; only allocate SCs where there is a distinct choice.
753 (do ((tn (ir2-component-normal-tns 2comp)
754 (tn-next tn)))
755 ((null tn))
756 (assert (tn-primitive-type tn))
757 (unless (tn-sc tn)
758 (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
759 (cond ((rest scs)
760 (multiple-value-bind (sc unique)
761 (select-tn-representation tn scs costs)
762 (when unique
763 (setf (tn-sc tn) sc))))
764 (t
765 (setf (tn-sc tn)
766 (svref (backend-sc-numbers *backend*) (first scs))))))))
767
768 (do ((tn (ir2-component-normal-tns 2comp)
769 (tn-next tn)))
770 ((null tn))
771 (assert (tn-primitive-type tn))
772 (unless (tn-sc tn)
773 (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
774 (sc (if (rest scs)
775 (select-tn-representation tn scs costs)
776 (svref (backend-sc-numbers *backend*) (first scs)))))
777 (assert sc)
778 (setf (tn-sc tn) sc))))
779
780 (do ((alias (ir2-component-alias-tns 2comp)
781 (tn-next alias)))
782 ((null alias))
783 (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
784
785 (do-ir2-blocks (block component)
786 (emit-moves-and-coercions block))
787
788 (macrolet ((frob (slot restricted)
789 `(do ((tn (,slot 2comp) (tn-next tn)))
790 ((null tn))
791 (note-if-number-stack tn 2comp ,restricted))))
792 (frob ir2-component-normal-tns nil)
793 (frob ir2-component-wired-tns t)
794 (frob ir2-component-restricted-tns t)))
795
796 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5