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