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-ARGUMENT 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-function-consistency ()
 190   (dotimes (i sc-number-limit)
 191     (let ((sc (svref *backend-sc-numbers* i)))
 192       (when sc
 193         (let ((moves (sc-move-functions 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-functions 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   (do ((ref refs (tn-ref-next ref)))
 231       ((null ref))
 232     (flet ((add-costs (cost)
 233              (dolist (scn scs)
 234                (let ((res (svref cost scn)))
 235                  (unless res
 236                    (bad-costs-error ref))
 237                  (incf (svref costs scn) res)))))
 238       (let* ((vop (tn-ref-vop ref))
 239              (info (vop-info vop)))
 240         (unless (find (vop-info-name info) *ignore-cost-vops*)
 241           (case (vop-info-name info)
 242             (move
 243              (let ((rep (tn-sc
 244                          (tn-ref-tn
 245                           (if write-p
 246                               (vop-args vop)
 247                               (vop-results vop))))))
 248                (when rep
 249                  (if write-p
 250                      (dolist (scn scs)
 251                        (let ((res (svref (sc-move-costs
 252                                           (svref *backend-sc-numbers* scn))
 253                                          (sc-number rep))))
 254                          (when res
 255                            (incf (svref costs scn) res))))
 256                      (dolist (scn scs)
 257                        (let ((res (svref (sc-move-costs rep) scn)))
 258                          (when res
 259                            (incf (svref costs scn) res))))))))
 260             (t
 261              (do ((cost (funcall costs-slot info) (cdr cost))
 262                   (op (funcall ops-slot vop) (tn-ref-across op)))
 263                  ((null cost)
 264                   (add-costs (funcall more-costs-slot info)))
 265                (when (eq op ref)
 266                  (add-costs (car cost))
 267                  (return)))))))))
 268   (values))
 269
 270 ;;; Return the best representation for a normal TN. SCs is a list
 271 ;;; of the SC numbers of the SCs to select from. Costs is a scratch
 272 ;;; vector.
 273 ;;;
 274 ;;; What we do is sum the costs for each reference to TN in each of
 275 ;;; the SCs, and then return the SC having the lowest cost. A second
 276 ;;; value is returned which is true when the selection is unique which
 277 ;;; is often not the case for the MOVE VOP.
 278 (defun select-tn-representation (tn scs costs)
 279   (declare (type tn tn) (type sc-vector costs)
 280            (inline add-representation-costs))
 281   (dolist (scn scs)
 282     (setf (svref costs scn) 0))
 283
 284   (add-representation-costs (tn-reads tn) scs costs
 285                             #'vop-args #'vop-info-arg-costs
 286                             #'vop-info-more-arg-costs
 287                             nil)
 288   (add-representation-costs (tn-writes tn) scs costs
 289                             #'vop-results #'vop-info-result-costs
 290                             #'vop-info-more-result-costs
 291                             t)
 292
 293   (let ((min most-positive-fixnum)
 294         (min-scn nil)
 295         (unique nil))
 296     (dolist (scn scs)
 297       (let ((cost (svref costs scn)))
 298         (cond ((= cost min)
 299                (setf unique nil))
 300               ((< cost min)
 301                (setq min cost)
 302                (setq min-scn scn)
 303                (setq unique t)))))
 304     (values (svref *backend-sc-numbers* min-scn) unique)))
 305
 306 ;;; Prepare for the possibility of a TN being allocated on the number
 307 ;;; stack by setting NUMBER-STACK-P in all functions that TN is
 308 ;;; referenced in and in all the functions in their tail sets. REFS is
 309 ;;; a TN-REFS list of references to the TN.
 310 (defun note-number-stack-tn (refs)
 311   (declare (type (or tn-ref null) refs))
 312
 313   (do ((ref refs (tn-ref-next ref)))
 314       ((null ref))
 315     (let* ((lambda (block-home-lambda
 316                     (ir2-block-block
 317                      (vop-block (tn-ref-vop ref)))))
 318            (tails (lambda-tail-set lambda)))
 319       (flet ((frob (fun)
 320                (setf (ir2-physenv-number-stack-p
 321                       (physenv-info
 322                        (lambda-physenv fun)))
 323                      t)))
 324         (frob lambda)
 325         (when tails
 326           (dolist (fun (tail-set-funs tails))
 327             (frob fun))))))
 328
 329   (values))
 330
 331 ;;; If TN is a variable, return the name. If TN is used by a VOP
 332 ;;; emitted for a return, then return a string indicating this.
 333 ;;; Otherwise, return NIL.
 334 (defun get-operand-name (tn arg-p)
 335   (declare (type tn tn))
 336   (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
 337          (reads (tn-reads tn))
 338          (leaf (tn-leaf actual)))
 339     (cond ((lambda-var-p leaf) (leaf-source-name leaf))
 340           ((and (not arg-p) reads
 341                 (return-p (vop-node (tn-ref-vop reads))))
 342            "<return value>")
 343           (t
 344            nil))))
 345
 346 ;;; If policy indicates, give an efficiency note for doing the
 347 ;;; coercion VOP, where OP is the operand we are coercing for and
 348 ;;; DEST-TN is the distinct destination in a move.
 349 (defun do-coerce-efficiency-note (vop op dest-tn)
 350   (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
 351   (let* ((note (or (template-note vop) (template-name vop)))
 352          (cost (template-cost vop))
 353          (op-vop (tn-ref-vop op))
 354          (op-node (vop-node op-vop))
 355          (op-tn (tn-ref-tn op))
 356          (*compiler-error-context* op-node))
 357     (cond ((eq (tn-kind op-tn) :constant))
 358           ((policy op-node (and (<= speed inhibit-warnings)
 359                                 (<= space inhibit-warnings))))
 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 ~W)~:[~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 ~W)~@[ 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
 385 ;;; the SC slot that we grab from (move or move-argument). WRITE-P
 386 ;;; indicates that OP is a VOP result, so OP is the move result and
 387 ;;; other is the arg, otherwise 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
 390 ;;; other operand instead, effectively intersecting the argument and
 391 ;;; result type assertions. This way, a move VOP can restrict
 392 ;;; whichever operand makes more sense, without worrying about which
 393 ;;; operand has the type info.
 394 (defun find-move-vop (op-tn write-p other-sc other-ptype slot)
 395   (declare (type tn op-tn) (type sc other-sc)
 396            (type primitive-type other-ptype)
 397            (type function slot))
 398   (let* ((op-sc (tn-sc op-tn))
 399          (op-scn (sc-number op-sc))
 400          (other-scn (sc-number other-sc))
 401          (any-ptype *backend-t-primitive-type*)
 402          (op-ptype (tn-primitive-type op-tn)))
 403     (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype))
 404           (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype)))
 405       (dolist (info (if write-p
 406                         (svref (funcall slot op-sc) other-scn)
 407                         (svref (funcall slot other-sc) op-scn))
 408                     nil)
 409         (when (and (operand-restriction-ok
 410                     (first (template-arg-types info))
 411                     (if write-p other-ptype op-ptype)
 412                     :tn op-tn :t-ok nil)
 413                    (operand-restriction-ok
 414                     (first (template-result-types info))
 415                     (if write-p op-ptype other-ptype)
 416                     :t-ok nil))
 417           (return info))))))
 418
 419 ;;; Emit a coercion VOP for OP BEFORE the specifed VOP or die trying.
 420 ;;; SCS is the operand's LOAD-SCS vector, which we use to determine
 421 ;;; what SCs the VOP will accept. We pick any acceptable coerce VOP,
 422 ;;; since it practice it seems uninteresting to have more than one
 423 ;;; applicable.
 424 ;;;
 425 ;;; On the X86 port, stack SCs may be placed in the list of operand
 426 ;;; preferred SCs, and to prevent these stack SCs being selected when
 427 ;;; a register SC is available the non-stack SCs are searched first.
 428 ;;;
 429 ;;; What we do is look at each SC allowed by both the operand
 430 ;;; restriction and the operand primitive-type, and see whether there
 431 ;;; is a move VOP which moves between the operand's SC and load SC. If
 432 ;;; we find such a VOP, then we make a TN having the load SC as the
 433 ;;; representation.
 434 ;;;
 435 ;;; DEST-TN is the TN that we are moving to, for a move or move-arg.
 436 ;;; This is only for efficiency notes.
 437 ;;;
 438 ;;; If the TN is an unused result TN, then we don't actually emit the
 439 ;;; move; we just change to the right kind of TN.
 440 (defun emit-coerce-vop (op dest-tn scs before)
 441   (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
 442            (type (or tn null) dest-tn))
 443   (let* ((op-tn (tn-ref-tn op))
 444          (ptype (tn-primitive-type op-tn))
 445          (write-p (tn-ref-write-p op))
 446          (vop (tn-ref-vop op))
 447          (node (vop-node vop))
 448          (block (vop-block vop)))
 449     (flet ((check-sc (scn sc)
 450              (when (sc-allowed-by-primitive-type sc ptype)
 451                (let ((res (find-move-vop op-tn write-p sc ptype
 452                                          #'sc-move-vops)))
 453                  (when res
 454                    (when (>= (vop-info-cost res)
 455                              *efficiency-note-cost-threshold*)
 456                      (do-coerce-efficiency-note res op dest-tn))
 457                    (let ((temp (make-representation-tn ptype scn)))
 458                      (change-tn-ref-tn op temp)
 459                      (cond
 460                        ((not write-p)
 461                         (emit-move-template node block res op-tn temp before))
 462                        ((and (null (tn-reads op-tn))
 463                              (eq (tn-kind op-tn) :normal)))
 464                        (t
 465                         (emit-move-template node block res temp op-tn
 466                                             before))))
 467                    t)))))
 468       ;; Search the non-stack load SCs first.
 469       (dotimes (scn sc-number-limit)
 470         (let ((sc (svref *backend-sc-numbers* scn)))
 471           (when (and (eq (svref scs scn) t)
 472                      (not (eq (sb-kind (sc-sb sc)) :unbounded))
 473                      (check-sc scn sc))
 474             (return-from emit-coerce-vop))))
 475       ;; Search the stack SCs if the above failed.
 476       (dotimes (scn sc-number-limit (bad-coerce-error op))
 477         (let ((sc (svref *backend-sc-numbers* scn)))
 478           (when (and (eq (svref scs scn) t)
 479                      (eq (sb-kind (sc-sb sc)) :unbounded)
 480                      (check-sc scn sc))
 481             (return)))))))
 482
 483 ;;; Scan some operands and call EMIT-COERCE-VOP on any for which we
 484 ;;; can't load the operand. The coerce VOP is inserted Before the
 485 ;;; specified VOP. Dest-TN is the destination TN if we are doing a
 486 ;;; move or move-arg, and is NIL otherwise. This is only used for
 487 ;;; efficiency notes.
 488 #!-sb-fluid (declaim (inline coerce-some-operands))
 489 (defun coerce-some-operands (ops dest-tn load-scs before)
 490   (declare (type (or tn-ref null) ops) (list load-scs)
 491            (type (or tn null) dest-tn) (type (or vop null) before))
 492   (do ((op ops (tn-ref-across op))
 493        (scs load-scs (cdr scs)))
 494       ((null scs))
 495     (unless (svref (car scs)
 496                    (sc-number (tn-sc (tn-ref-tn op))))
 497       (emit-coerce-vop op dest-tn (car scs) before)))
 498   (values))
 499
 500 ;;; Emit coerce VOPs for the args and results, as needed.
 501 (defun coerce-vop-operands (vop)
 502   (declare (type vop vop))
 503   (let ((info (vop-info vop)))
 504     (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
 505     (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
 506                           (vop-next vop)))
 507   (values))
 508
 509 ;;; Iterate over the more operands to a call VOP, emitting move-arg
 510 ;;; VOPs and any necessary coercions. We determine which FP to use by
 511 ;;; looking at the MOVE-ARGS annotation. If the vop is a :LOCAL-CALL,
 512 ;;; we insert any needed coercions before the ALLOCATE-FRAME so that
 513 ;;; lifetime analysis doesn't get confused (since otherwise, only
 514 ;;; passing locations are written between A-F and call.)
 515 (defun emit-arg-moves (vop)
 516   (let* ((info (vop-info vop))
 517          (node (vop-node vop))
 518          (block (vop-block vop))
 519          (how (vop-info-move-args info))
 520          (args (vop-args vop))
 521          (fp-tn (tn-ref-tn args))
 522          (nfp-tn (if (eq how :local-call)
 523                      (tn-ref-tn (tn-ref-across args))
 524                      nil))
 525          (pass-locs (first (vop-codegen-info vop)))
 526          (prev (vop-prev vop)))
 527     (do ((val (do ((arg args (tn-ref-across arg))
 528                    (req (template-arg-types info) (cdr req)))
 529                   ((null req) arg))
 530               (tn-ref-across val))
 531          (pass pass-locs (cdr pass)))
 532         ((null val)
 533          (aver (null pass)))
 534       (let* ((val-tn (tn-ref-tn val))
 535              (pass-tn (first pass))
 536              (pass-sc (tn-sc pass-tn))
 537              (res (find-move-vop val-tn nil pass-sc
 538                                  (tn-primitive-type pass-tn)
 539                                  #'sc-move-arg-vops)))
 540         (unless res
 541           (bad-move-arg-error val-tn pass-tn))
 542
 543         (change-tn-ref-tn val pass-tn)
 544         (let* ((this-fp
 545                 (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
 546                       (nfp-tn)
 547                       (t
 548                        (aver (eq how :known-return))
 549                        (setq nfp-tn (make-number-stack-pointer-tn))
 550                        (setf (tn-sc nfp-tn)
 551                              (svref *backend-sc-numbers*
 552                                     (first (primitive-type-scs
 553                                             (tn-primitive-type nfp-tn)))))
 554                        (emit-context-template
 555                         node block
 556                         (template-or-lose 'compute-old-nfp)
 557                         nfp-tn vop)
 558                        (aver (not (sc-number-stack-p (tn-sc nfp-tn))))
 559                        nfp-tn)))
 560                (new (emit-move-arg-template node block res val-tn this-fp
 561                                             pass-tn vop))
 562                (after
 563                 (cond ((eq how :local-call)
 564                        (aver (eq (vop-info-name (vop-info prev))
 565                                  'allocate-frame))
 566                        prev)
 567                       (prev (vop-next prev))
 568                       (t
 569                        (ir2-block-start-vop block)))))
 570           (coerce-some-operands (vop-args new) pass-tn
 571                                 (vop-info-arg-load-scs res)
 572                                 after)))))
 573   (values))
 574
 575 ;;; Scan the IR2 looking for move operations that need to be replaced
 576 ;;; with special-case VOPs and emitting coercion VOPs for operands of
 577 ;;; normal VOPs. We delete moves to TNs that are never read at this
 578 ;;; point, rather than possibly converting them to some expensive move
 579 ;;; operation.
 580 (defun emit-moves-and-coercions (block)
 581   (declare (type ir2-block block))
 582   (do ((vop (ir2-block-start-vop block)
 583             (vop-next vop)))
 584       ((null vop))
 585     (let ((info (vop-info vop))
 586           (node (vop-node vop))
 587           (block (vop-block vop)))
 588       (cond
 589        ((eq (vop-info-name info) 'move)
 590         (let* ((args (vop-args vop))
 591                (x (tn-ref-tn args))
 592                (y (tn-ref-tn (vop-results vop)))
 593                (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
 594                                    #'sc-move-vops)))
 595           (cond ((and (null (tn-reads y))
 596                       (eq (tn-kind y) :normal))
 597                  (delete-vop vop))
 598                 ((eq res info))
 599                 (res
 600                  (when (>= (vop-info-cost res)
 601                            *efficiency-note-cost-threshold*)
 602                    (do-coerce-efficiency-note res args y))
 603                  (emit-move-template node block res x y vop)
 604                  (delete-vop vop))
 605                 (t
 606                  (coerce-vop-operands vop)))))
 607        ((vop-info-move-args info)
 608         (emit-arg-moves vop))
 609        (t
 610         (coerce-vop-operands vop))))))
 611
 612 ;;; If TN is in a number stack SC, make all the right annotations.
 613 ;;; Note that this should be called after TN has been referenced,
 614 ;;; since it must iterate over the referencing environments.
 615 #!-sb-fluid (declaim (inline note-if-number-stack))
 616 (defun note-if-number-stack (tn 2comp restricted)
 617   (declare (type tn tn) (type ir2-component 2comp))
 618   (when (if restricted
 619             (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack)
 620             (sc-number-stack-p (tn-sc tn)))
 621     (unless (ir2-component-nfp 2comp)
 622       (setf (ir2-component-nfp 2comp) (make-nfp-tn)))
 623     (note-number-stack-tn (tn-reads tn))
 624     (note-number-stack-tn (tn-writes tn)))
 625   (values))
 626
 627 ;;; This is the entry to representation selection. First we select the
 628 ;;; representation for all normal TNs, setting the TN-SC. After
 629 ;;; selecting the TN representations, we set the SC for all :ALIAS TNs
 630 ;;; to be the representation chosen for the original TN. We then scan
 631 ;;; all the IR2, emitting any necessary coerce and move-arg VOPs.
 632 ;;; Finally, we scan all TNs looking for ones that might be placed on
 633 ;;; the number stack, noting this so that the number-FP can be
 634 ;;; allocated. This must be done last, since references in new
 635 ;;; environments may be introduced by MOVE-ARG insertion.
 636 (defun select-representations (component)
 637   (let ((costs (make-array sc-number-limit))
 638         (2comp (component-info component)))
 639
 640     ;; First pass; only allocate SCs where there is a distinct choice.
 641     (do ((tn (ir2-component-normal-tns 2comp)
 642              (tn-next tn)))
 643         ((null tn))
 644       (aver (tn-primitive-type tn))
 645       (unless (tn-sc tn)
 646         (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
 647           (cond ((rest scs)
 648                  (multiple-value-bind (sc unique)
 649                      (select-tn-representation tn scs costs)
 650                    (when unique
 651                       (setf (tn-sc tn) sc))))
 652                 (t
 653                  (setf (tn-sc tn)
 654                        (svref *backend-sc-numbers* (first scs))))))))
 655
 656     (do ((tn (ir2-component-normal-tns 2comp)
 657              (tn-next tn)))
 658         ((null tn))
 659       (aver (tn-primitive-type tn))
 660       (unless (tn-sc tn)
 661         (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
 662                (sc (if (rest scs)
 663                        (select-tn-representation tn scs costs)
 664                        (svref *backend-sc-numbers* (first scs)))))
 665           (aver sc)
 666           (setf (tn-sc tn) sc))))
 667
 668     (do ((alias (ir2-component-alias-tns 2comp)
 669                 (tn-next alias)))
 670         ((null alias))
 671       (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
 672
 673     (do-ir2-blocks (block component)
 674       (emit-moves-and-coercions block))
 675
 676     (macrolet ((frob (slot restricted)
 677                  `(do ((tn (,slot 2comp) (tn-next tn)))
 678                       ((null tn))
 679                     (note-if-number-stack tn 2comp ,restricted))))
 680       (frob ir2-component-normal-tns nil)
 681       (frob ir2-component-wired-tns t)
 682       (frob ir2-component-restricted-tns t)))
 683
 684   (values))