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
7 ;;;; This software is part of the SBCL system. See the README file for
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.
23 ;;;; Problems in the VM definition often show up here, so we try to be
24 ;;;; as implementor-friendly as possible.
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))
48 (or (position-in #'tn-ref-across ref refs)
49 (error "couldn't find REF?"))
56 (let ((parse (vop-parse-or-lose (vop-info-name info))))
57 (multiple-value-bind (ccosts cscs)
58 (compute-loading-costs
60 (vop-parse-args parse)
61 (vop-parse-results parse))
71 (not (and (equalp ccosts (car costs))
72 (equalp cscs (car load))))))))))))
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))))))
81 ;;; Convert a load-costs vector to the list of SCs allowed by the operand
83 (defun listify-restrictions (restr)
84 (declare (type sc-vector restr))
86 (dotimes (i sc-number-limit)
87 (when (eq (svref restr i) t)
88 (res (svref *backend-sc-numbers* i))))
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)
100 (dolist (scn (primitive-type-scs ptype))
101 (unless (svref costs scn)
102 (losers (svref *backend-sc-numbers* scn))))
105 (error "Representation selection flamed out for no obvious reason.~@
106 Try again after recompiling the VM definition."))
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:~
112 Current cost info inconsistent with that in effect at compile ~
113 time. Recompile.~%Compilation order may be incorrect.~]"
115 (template-name (vop-info (tn-ref-vop ref)))
116 (primitive-type-name ptype)
117 (mapcar #'sc-name (losers))
120 (mapcar #'sc-name (listify-restrictions load-scs)))
123 ;;; Try to give a helpful error message when we fail to do a coercion
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)
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))
143 ((not (find-move-vop op-tn write-p i-sc ptype
145 (let ((vops (if write-p
146 (svref (sc-move-vops op-sc) i)
147 (svref (sc-move-vops i-sc) op-scn))))
149 (dolist (vop vops) (move-lose (template-name vop)))
150 (no-move-scs i-sc))))
152 (error "Representation selection flamed out for no ~
153 obvious reason."))))))
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."))
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:~
165 ~@[These move VOPs couldn't be used due to operand type ~
166 restrictions:~% ~S~%~]~
168 Current cost info inconsistent with that in effect at compile ~
169 time. Recompile.~%Compilation order may be incorrect.~]"
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))
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 ~
183 val (sc-name (tn-sc val))
184 pass (sc-name (tn-sc pass))))
186 ;;;; VM consistency checking
188 ;;;; We do some checking of the consistency of the VM definition at load
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)))
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 ~
201 (sc-name sc) (sc-name const))))
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 ~
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 ~
211 (sc-name sc) (sc-name alt)))))))))
213 ;;;; representation selection
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))
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
232 (do ((ref refs (tn-ref-next ref)))
234 (flet ((add-costs (cost)
236 (let ((res (svref cost scn)))
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)
249 (vop-results vop))))))
253 (let ((res (svref (sc-move-costs
254 (svref *backend-sc-numbers* scn))
257 (incf (svref costs scn) res))))
259 (let ((res (svref (sc-move-costs rep) scn)))
261 (incf (svref costs scn) res))))))))
263 (do ((cost (funcall costs-slot info) (cdr cost))
264 (op (funcall ops-slot vop) (tn-ref-across op)))
266 (add-costs (funcall more-costs-slot info)))
268 (add-costs (car cost))
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
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))
284 (setf (svref costs scn) 0))
286 (add-representation-costs (tn-reads tn) scs costs
287 #'vop-args #'vop-info-arg-costs
288 #'vop-info-more-arg-costs
290 (add-representation-costs (tn-writes tn) scs costs
291 #'vop-results #'vop-info-result-costs
292 #'vop-info-more-result-costs
295 (let ((min most-positive-fixnum)
299 (let ((cost (svref costs scn)))
306 (values (svref *backend-sc-numbers* min-scn) unique)))
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
312 (defun note-number-stack-tn (refs)
313 (declare (type (or tn-ref null) refs))
315 (do ((ref refs (tn-ref-next ref)))
317 (let* ((lambda (block-home-lambda
319 (vop-block (tn-ref-vop ref)))))
320 (tails (lambda-tail-set lambda)))
322 (setf (ir2-environment-number-stack-p
324 (lambda-environment fun)))
328 (dolist (fun (tail-set-functions tails))
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))))
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))
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
370 (vop-results op-vop)))
371 (error "couldn't find op? bug!")))))
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
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)))))
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.
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))
408 (when (and (operand-restriction-ok
409 (first (template-arg-types info))
410 (if write-p other-ptype op-ptype)
412 (operand-restriction-ok
413 (first (template-result-types info))
414 (if write-p op-ptype other-ptype)
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.
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.
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.
432 ;;; Dest-TN is the TN that we are moving to, for a move or move-arg. This
433 ;;; is only for efficiency notes.
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
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)
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)))
462 (emit-move-template node block res temp op-tn
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))
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)
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)))
491 (unless (svref (car scs)
492 (sc-number (tn-sc (tn-ref-tn op))))
493 (emit-coerce-vop op dest-tn (car scs) before)))
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)
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
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))
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)))
527 (pass pass-locs (cdr pass)))
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)))
537 (bad-move-arg-error val-tn pass-tn))
539 (change-tn-ref-tn val pass-tn)
541 (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
544 (assert (eq how :known-return))
545 (setq nfp-tn (make-number-stack-pointer-tn))
547 (svref *backend-sc-numbers*
548 (first (primitive-type-scs
549 (tn-primitive-type nfp-tn)))))
550 (emit-context-template
552 (template-or-lose 'compute-old-nfp)
554 (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
556 (new (emit-move-arg-template node block res val-tn this-fp
559 (cond ((eq how :local-call)
560 (assert (eq (vop-info-name (vop-info prev))
563 (prev (vop-next prev))
565 (ir2-block-start-vop block)))))
566 (coerce-some-operands (vop-args new) pass-tn
567 (vop-info-arg-load-scs res)
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)
580 (let ((info (vop-info vop))
581 (node (vop-node vop))
582 (block (vop-block vop)))
584 ((eq (vop-info-name info) 'move)
585 (let* ((args (vop-args vop))
587 (y (tn-ref-tn (vop-results vop)))
588 (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
590 (cond ((and (null (tn-reads y))
591 (eq (tn-kind y) :normal))
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)
601 (coerce-vop-operands vop)))))
602 ((vop-info-move-args info)
603 (emit-arg-moves vop))
605 (coerce-vop-operands vop))))))
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))
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)))
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)))
634 ;; First pass; only allocate SCs where there is a distinct choice.
635 (do ((tn (ir2-component-normal-tns 2comp)
638 (assert (tn-primitive-type tn))
640 (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
642 (multiple-value-bind (sc unique)
643 (select-tn-representation tn scs costs)
645 (setf (tn-sc tn) sc))))
648 (svref *backend-sc-numbers* (first scs))))))))
650 (do ((tn (ir2-component-normal-tns 2comp)
653 (assert (tn-primitive-type tn))
655 (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
657 (select-tn-representation tn scs costs)
658 (svref *backend-sc-numbers* (first scs)))))
660 (setf (tn-sc tn) sc))))
662 (do ((alias (ir2-component-alias-tns 2comp)
665 (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
667 (do-ir2-blocks (block component)
668 (emit-moves-and-coercions block))
670 (macrolet ((frob (slot restricted)
671 `(do ((tn (,slot 2comp) (tn-next 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)))