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