- (do ((refs refs (tn-ref-across refs))
- (costs costs (cdr costs))
- (load load (cdr load))
- (n 0 (1+ n)))
- ((null costs)
- (aver more-cost)
- (values arg-p
- (+ n
- (or (position-in #'tn-ref-across ref refs)
- (error "couldn't find REF?"))
- 1)
- t
- more-cost
- nil
- nil))
- (when (eq refs ref)
- (let ((parse (vop-parse-or-lose (vop-info-name info))))
- (multiple-value-bind (ccosts cscs)
- (compute-loading-costs
- (elt (if arg-p
- (vop-parse-args parse)
- (vop-parse-results parse))
- n)
- arg-p)
-
- (return
- (values arg-p
- (1+ n)
- nil
- (car costs)
- (car load)
- (not (and (equalp ccosts (car costs))
- (equalp cscs (car load))))))))))))
+ (do ((refs refs (tn-ref-across refs))
+ (costs costs (cdr costs))
+ (load load (cdr load))
+ (n 0 (1+ n)))
+ ((null costs)
+ (aver more-cost)
+ (values arg-p
+ (+ n
+ (or (position-in #'tn-ref-across ref refs)
+ (error "couldn't find REF?"))
+ 1)
+ t
+ more-cost
+ nil
+ nil))
+ (when (eq refs ref)
+ (let ((parse (vop-parse-or-lose (vop-info-name info))))
+ (multiple-value-bind (ccosts cscs)
+ (compute-loading-costs
+ (elt (if arg-p
+ (vop-parse-args parse)
+ (vop-parse-results parse))
+ n)
+ arg-p)
+
+ (return
+ (values arg-p
+ (1+ n)
+ nil
+ (car costs)
+ (car load)
+ (not (and (equalp ccosts (car costs))
+ (equalp cscs (car load))))))))))))
- (frob (vop-args vop) (vop-info-arg-costs info)
- (vop-info-arg-load-scs info)
- (vop-info-more-arg-costs info))
- (frob (vop-results vop) (vop-info-result-costs info)
- (vop-info-result-load-scs info)
- (vop-info-more-result-costs info))))))
+ (frob (vop-args vop) (vop-info-arg-costs info)
+ (vop-info-arg-load-scs info)
+ (vop-info-more-arg-costs info))
+ (frob (vop-results vop) (vop-info-result-costs info)
+ (vop-info-result-load-scs info)
+ (vop-info-more-result-costs info))))))
- (dolist (scn (primitive-type-scs ptype))
- (unless (svref costs scn)
- (losers (svref *backend-sc-numbers* scn))))
-
- (unless (losers)
- (error "Representation selection flamed out for no obvious reason.~@
- Try again after recompiling the VM definition."))
-
- (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
- ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
- ~:[which cannot be coerced or loaded into the allowed SCs:~
- ~% ~S~;~*~]~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
- tn pos arg-p
- (template-name (vop-info (tn-ref-vop ref)))
- (primitive-type-name ptype)
- (mapcar #'sc-name (losers))
- more-p
- (unless more-p
- (mapcar #'sc-name (listify-restrictions load-scs)))
- incon)))))
+ (dolist (scn (primitive-type-scs ptype))
+ (unless (svref costs scn)
+ (losers (svref *backend-sc-numbers* scn))))
+
+ (unless (losers)
+ (error "Representation selection flamed out for no obvious reason.~@
+ Try again after recompiling the VM definition."))
+
+ (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
+ ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
+ ~:[which cannot be coerced or loaded into the allowed SCs:~
+ ~% ~S~;~*~]~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ tn pos arg-p
+ (template-name (vop-info (tn-ref-vop ref)))
+ (primitive-type-name ptype)
+ (mapcar #'sc-name (losers))
+ more-p
+ (unless more-p
+ (mapcar #'sc-name (listify-restrictions load-scs)))
+ incon)))))
;;; Try to give a helpful error message when we fail to do a coercion
;;; for some reason.
(defun bad-coerce-error (op)
(declare (type tn-ref op))
(let* ((op-tn (tn-ref-tn op))
;;; Try to give a helpful error message when we fail to do a coercion
;;; for some reason.
(defun bad-coerce-error (op)
(declare (type tn-ref op))
(let* ((op-tn (tn-ref-tn op))
- (no-move-scs)
- (move-lose))
- (dotimes (i sc-number-limit)
- (let ((i-sc (svref *backend-sc-numbers* i)))
- (when (eq (svref load-scs i) t)
- (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
- (load-lose i-sc))
- ((not (find-move-vop op-tn write-p i-sc ptype
- #'sc-move-vops))
- (let ((vops (if write-p
- (svref (sc-move-vops op-sc) i)
- (svref (sc-move-vops i-sc) op-scn))))
- (if vops
- (dolist (vop vops) (move-lose (template-name vop)))
- (no-move-scs i-sc))))
- (t
- (error "Representation selection flamed out for no ~
- obvious reason."))))))
-
- (unless (or (load-lose) (no-move-scs) (move-lose))
- (error "Representation selection flamed out for no obvious reason.~@
- Try again after recompiling the VM definition."))
-
- (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
- ~% ~S~%Primitive type: ~S~@
- SC restrictions:~% ~S~@
- ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
- ~@[No move VOPs are defined to coerce to these allowed SCs:~
- ~% ~S~%~]~
- ~@[These move VOPs couldn't be used due to operand type ~
- restrictions:~% ~S~%~]~
- ~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
- op-tn pos arg-p
- (template-name (vop-info (tn-ref-vop op)))
- (primitive-type-name ptype)
- (mapcar #'sc-name (listify-restrictions load-scs))
- (mapcar #'sc-name (load-lose))
- (mapcar #'sc-name (no-move-scs))
- (move-lose)
- incon)))))
+ (no-move-scs)
+ (move-lose))
+ (dotimes (i sc-number-limit)
+ (let ((i-sc (svref *backend-sc-numbers* i)))
+ (when (eq (svref load-scs i) t)
+ (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
+ (load-lose i-sc))
+ ((not (find-move-vop op-tn write-p i-sc ptype
+ #'sc-move-vops))
+ (let ((vops (if write-p
+ (svref (sc-move-vops op-sc) i)
+ (svref (sc-move-vops i-sc) op-scn))))
+ (if vops
+ (dolist (vop vops) (move-lose (template-name vop)))
+ (no-move-scs i-sc))))
+ (t
+ (error "Representation selection flamed out for no ~
+ obvious reason."))))))
+
+ (unless (or (load-lose) (no-move-scs) (move-lose))
+ (error "Representation selection flamed out for no obvious reason.~@
+ Try again after recompiling the VM definition."))
+
+ (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
+ ~% ~S~%Primitive type: ~S~@
+ SC restrictions:~% ~S~@
+ ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
+ ~@[No move VOPs are defined to coerce to these allowed SCs:~
+ ~% ~S~%~]~
+ ~@[These move VOPs couldn't be used due to operand type ~
+ restrictions:~% ~S~%~]~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ op-tn pos arg-p
+ (template-name (vop-info (tn-ref-vop op)))
+ (primitive-type-name ptype)
+ (mapcar #'sc-name (listify-restrictions load-scs))
+ (mapcar #'sc-name (load-lose))
+ (mapcar #'sc-name (no-move-scs))
+ (move-lose)
+ incon)))))
- (let ((moves (sc-move-funs sc)))
- (dolist (const (sc-constant-scs sc))
- (unless (svref moves (sc-number const))
- (warn "no move function defined to load SC ~S from constant ~
- SC ~S"
- (sc-name sc) (sc-name const))))
-
- (dolist (alt (sc-alternate-scs sc))
- (unless (svref moves (sc-number alt))
- (warn "no move function defined to load SC ~S from alternate ~
- SC ~S"
- (sc-name sc) (sc-name alt)))
- (unless (svref (sc-move-funs alt) i)
- (warn "no move function defined to save SC ~S to alternate ~
- SC ~S"
- (sc-name sc) (sc-name alt)))))))))
+ (let ((moves (sc-move-funs sc)))
+ (dolist (const (sc-constant-scs sc))
+ (unless (svref moves (sc-number const))
+ (warn "no move function defined to load SC ~S from constant ~
+ SC ~S"
+ (sc-name sc) (sc-name const))))
+
+ (dolist (alt (sc-alternate-scs sc))
+ (unless (svref moves (sc-number alt))
+ (warn "no move function defined to load SC ~S from alternate ~
+ SC ~S"
+ (sc-name sc) (sc-name alt)))
+ (unless (svref (sc-move-funs alt) i)
+ (warn "no move function defined to save SC ~S to alternate ~
+ SC ~S"
+ (sc-name sc) (sc-name alt)))))))))
;;; chosen (e.g. if it is wired), then we use the appropriate move
;;; costs, otherwise we just ignore the references.
(defun add-representation-costs (refs scs costs
;;; chosen (e.g. if it is wired), then we use the appropriate move
;;; costs, otherwise we just ignore the references.
(defun add-representation-costs (refs scs costs
- (info (vop-info vop)))
- (unless (find (vop-info-name info) *ignore-cost-vops*)
- (case (vop-info-name info)
- (move
- (let ((rep (tn-sc
- (tn-ref-tn
- (if write-p
- (vop-args vop)
- (vop-results vop))))))
- (when rep
- (if write-p
- (dolist (scn scs)
- (let ((res (svref (sc-move-costs
- (svref *backend-sc-numbers* scn))
- (sc-number rep))))
- (when res
- (incf (svref costs scn) res))))
- (dolist (scn scs)
- (let ((res (svref (sc-move-costs rep) scn)))
- (when res
- (incf (svref costs scn) res))))))))
- (t
- (do ((cost (funcall costs-slot info) (cdr cost))
- (op (funcall ops-slot vop) (tn-ref-across op)))
- ((null cost)
- (add-costs (funcall more-costs-slot info)))
- (when (eq op ref)
- (add-costs (car cost))
- (return)))))))))
+ (info (vop-info vop)))
+ (unless (find (vop-info-name info) *ignore-cost-vops*)
+ (case (vop-info-name info)
+ (move
+ (let ((rep (tn-sc
+ (tn-ref-tn
+ (if write-p
+ (vop-args vop)
+ (vop-results vop))))))
+ (when rep
+ (if write-p
+ (dolist (scn scs)
+ (let ((res (svref (sc-move-costs
+ (svref *backend-sc-numbers* scn))
+ (sc-number rep))))
+ (when res
+ (incf (svref costs scn) res))))
+ (dolist (scn scs)
+ (let ((res (svref (sc-move-costs rep) scn)))
+ (when res
+ (incf (svref costs scn) res))))))))
+ (t
+ (do ((cost (funcall costs-slot info) (cdr cost))
+ (op (funcall ops-slot vop) (tn-ref-across op)))
+ ((null cost)
+ (add-costs (funcall more-costs-slot info)))
+ (when (eq op ref)
+ (add-costs (car cost))
+ (return)))))))))
;;; If policy indicates, give an efficiency note for doing the
;;; coercion VOP, where OP is the operand we are coercing for and
;;; DEST-TN is the distinct destination in a move.
;;; If policy indicates, give an efficiency note for doing the
;;; coercion VOP, where OP is the operand we are coercing for and
;;; DEST-TN is the distinct destination in a move.
- ((policy op-node (and (<= speed inhibit-warnings)
- (<= space inhibit-warnings))))
- ((member (template-name (vop-info op-vop)) *suppress-note-vops*))
- ((null dest-tn)
- (let* ((op-info (vop-info op-vop))
- (op-note (or (template-note op-info)
- (template-name op-info)))
- (arg-p (not (tn-ref-write-p op)))
- (name (get-operand-name op-tn arg-p))
- (pos (1+ (or (position-in #'tn-ref-across op
- (if arg-p
- (vop-args op-vop)
- (vop-results op-vop)))
- (error "couldn't find op? bug!")))))
- (compiler-note
- "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
- the ~:R ~:[result~;argument~] of ~A"
- note cost name arg-p name
- pos arg-p op-note)))
- (t
- (compiler-note "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]"
- note cost (get-operand-name op-tn t)
- (get-operand-name dest-tn nil)))))
+ ((policy op-node (and (<= speed inhibit-warnings)
+ (<= space inhibit-warnings))))
+ ((member (template-name (vop-info op-vop)) *suppress-note-vops*))
+ ((null dest-tn)
+ (let* ((op-info (vop-info op-vop))
+ (op-note (or (template-note op-info)
+ (template-name op-info)))
+ (arg-p (not (tn-ref-write-p op)))
+ (name (get-operand-name op-tn arg-p))
+ (pos (1+ (or (position-in #'tn-ref-across op
+ (if arg-p
+ (vop-args op-vop)
+ (vop-results op-vop)))
+ (error "couldn't find op? bug!")))))
+ (compiler-notify
+ "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
+ the ~:R ~:[result~;argument~] of ~A"
+ note cost name arg-p name
+ pos arg-p op-note)))
+ (t
+ (compiler-notify "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]"
+ note cost (get-operand-name op-tn t)
+ (get-operand-name dest-tn nil)))))
- (op-scn (sc-number op-sc))
- (other-scn (sc-number other-sc))
- (any-ptype *backend-t-primitive-type*)
- (op-ptype (tn-primitive-type op-tn)))
+ (op-scn (sc-number op-sc))
+ (other-scn (sc-number other-sc))
+ (any-ptype *backend-t-primitive-type*)
+ (op-ptype (tn-primitive-type op-tn)))
- (svref (funcall slot op-sc) other-scn)
- (svref (funcall slot other-sc) op-scn))
- nil)
- (when (and (operand-restriction-ok
- (first (template-arg-types info))
- (if write-p other-ptype op-ptype)
- :tn op-tn :t-ok nil)
- (operand-restriction-ok
- (first (template-result-types info))
- (if write-p op-ptype other-ptype)
- :t-ok nil))
- (return info))))))
-
+ (svref (funcall slot op-sc) other-scn)
+ (svref (funcall slot other-sc) op-scn))
+ nil)
+ (when (and (operand-restriction-ok
+ (first (template-arg-types info))
+ (if write-p other-ptype op-ptype)
+ :tn op-tn :t-ok nil)
+ (operand-restriction-ok
+ (first (template-result-types info))
+ (if write-p op-ptype other-ptype)
+ :t-ok nil))
+ (return info))))))
+
;;; Emit a coercion VOP for OP BEFORE the specifed VOP or die trying.
;;; SCS is the operand's LOAD-SCS vector, which we use to determine
;;; what SCs the VOP will accept. We pick any acceptable coerce VOP,
;;; Emit a coercion VOP for OP BEFORE the specifed VOP or die trying.
;;; SCS is the operand's LOAD-SCS vector, which we use to determine
;;; what SCs the VOP will accept. We pick any acceptable coerce VOP,
- (when (sc-allowed-by-primitive-type sc ptype)
- (let ((res (find-move-vop op-tn write-p sc ptype
- #'sc-move-vops)))
- (when res
- (when (>= (vop-info-cost res)
- *efficiency-note-cost-threshold*)
- (do-coerce-efficiency-note res op dest-tn))
- (let ((temp (make-representation-tn ptype scn)))
- (change-tn-ref-tn op temp)
- (cond
- ((not write-p)
- (emit-move-template node block res op-tn temp before))
- ((and (null (tn-reads op-tn))
- (eq (tn-kind op-tn) :normal)))
- (t
- (emit-move-template node block res temp op-tn
- before))))
- t)))))
+ (when (sc-allowed-by-primitive-type sc ptype)
+ (let ((res (find-move-vop op-tn write-p sc ptype
+ #'sc-move-vops)))
+ (when res
+ (when (>= (vop-info-cost res)
+ *efficiency-note-cost-threshold*)
+ (maybe-emit-coerce-efficiency-note res op dest-tn))
+ (let ((temp (make-representation-tn ptype scn)))
+ (change-tn-ref-tn op temp)
+ (cond
+ ((not write-p)
+ (emit-move-template node block res op-tn temp before))
+ ((and (null (tn-reads op-tn))
+ (eq (tn-kind op-tn) :normal)))
+ (t
+ (emit-move-template node block res temp op-tn
+ before))))
+ t)))))
- (let ((sc (svref *backend-sc-numbers* scn)))
- (when (and (eq (svref scs scn) t)
- (not (eq (sb-kind (sc-sb sc)) :unbounded))
- (check-sc scn sc))
- (return-from emit-coerce-vop))))
+ (let ((sc (svref *backend-sc-numbers* scn)))
+ (when (and (eq (svref scs scn) t)
+ (not (eq (sb-kind (sc-sb sc)) :unbounded))
+ (check-sc scn sc))
+ (return-from emit-coerce-vop))))
- (node (vop-node vop))
- (block (vop-block vop))
- (how (vop-info-move-args info))
- (args (vop-args vop))
- (fp-tn (tn-ref-tn args))
- (nfp-tn (if (eq how :local-call)
- (tn-ref-tn (tn-ref-across args))
- nil))
- (pass-locs (first (vop-codegen-info vop)))
- (prev (vop-prev vop)))
+ (node (vop-node vop))
+ (block (vop-block vop))
+ (how (vop-info-move-args info))
+ (args (vop-args vop))
+ (fp-tn (tn-ref-tn args))
+ (nfp-tn (if (eq how :local-call)
+ (tn-ref-tn (tn-ref-across args))
+ nil))
+ (pass-locs (first (vop-codegen-info vop)))
+ (prev (vop-prev vop)))
- (pass-tn (first pass))
- (pass-sc (tn-sc pass-tn))
- (res (find-move-vop val-tn nil pass-sc
- (tn-primitive-type pass-tn)
- #'sc-move-arg-vops)))
- (unless res
- (bad-move-arg-error val-tn pass-tn))
-
- (change-tn-ref-tn val pass-tn)
- (let* ((this-fp
- (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
- (nfp-tn)
- (t
- (aver (eq how :known-return))
- (setq nfp-tn (make-number-stack-pointer-tn))
- (setf (tn-sc nfp-tn)
- (svref *backend-sc-numbers*
- (first (primitive-type-scs
- (tn-primitive-type nfp-tn)))))
- (emit-context-template
- node block
- (template-or-lose 'compute-old-nfp)
- nfp-tn vop)
- (aver (not (sc-number-stack-p (tn-sc nfp-tn))))
- nfp-tn)))
- (new (emit-move-arg-template node block res val-tn this-fp
- pass-tn vop))
- (after
- (cond ((eq how :local-call)
- (aver (eq (vop-info-name (vop-info prev))
- 'allocate-frame))
- prev)
- (prev (vop-next prev))
- (t
- (ir2-block-start-vop block)))))
- (coerce-some-operands (vop-args new) pass-tn
- (vop-info-arg-load-scs res)
- after)))))
+ (pass-tn (first pass))
+ (pass-sc (tn-sc pass-tn))
+ (res (find-move-vop val-tn nil pass-sc
+ (tn-primitive-type pass-tn)
+ #'sc-move-arg-vops)))
+ (unless res
+ (bad-move-arg-error val-tn pass-tn))
+
+ (change-tn-ref-tn val pass-tn)
+ (let* ((this-fp
+ (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
+ (nfp-tn)
+ (t
+ (aver (eq how :known-return))
+ (setq nfp-tn (make-number-stack-pointer-tn))
+ (setf (tn-sc nfp-tn)
+ (svref *backend-sc-numbers*
+ (first (primitive-type-scs
+ (tn-primitive-type nfp-tn)))))
+ (emit-context-template
+ node block
+ (template-or-lose 'compute-old-nfp)
+ nfp-tn vop)
+ (aver (not (sc-number-stack-p (tn-sc nfp-tn))))
+ nfp-tn)))
+ (new (emit-move-arg-template node block res val-tn this-fp
+ pass-tn vop))
+ (after
+ (cond ((eq how :local-call)
+ (aver (eq (vop-info-name (vop-info prev))
+ 'allocate-frame))
+ prev)
+ (prev (vop-next prev))
+ (t
+ (ir2-block-start-vop block)))))
+ (coerce-some-operands (vop-args new) pass-tn
+ (vop-info-arg-load-scs res)
+ after)))))
- (let* ((args (vop-args vop))
- (x (tn-ref-tn args))
- (y (tn-ref-tn (vop-results vop)))
- (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
- #'sc-move-vops)))
- (cond ((and (null (tn-reads y))
- (eq (tn-kind y) :normal))
- (delete-vop vop))
- ((eq res info))
- (res
- (when (>= (vop-info-cost res)
- *efficiency-note-cost-threshold*)
- (do-coerce-efficiency-note res args y))
- (emit-move-template node block res x y vop)
- (delete-vop vop))
- (t
- (coerce-vop-operands vop)))))
+ (let* ((args (vop-args vop))
+ (x (tn-ref-tn args))
+ (y (tn-ref-tn (vop-results vop)))
+ (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
+ #'sc-move-vops)))
+ (cond ((and (null (tn-reads y))
+ (eq (tn-kind y) :normal))
+ (delete-vop vop))
+ ((eq res info))
+ (res
+ (when (>= (vop-info-cost res)
+ *efficiency-note-cost-threshold*)
+ (maybe-emit-coerce-efficiency-note res args y))
+ (emit-move-template node block res x y vop)
+ (delete-vop vop))
+ (t
+ (coerce-vop-operands vop)))))
- (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
- (cond ((rest scs)
- (multiple-value-bind (sc unique)
- (select-tn-representation tn scs costs)
- (when unique
- (setf (tn-sc tn) sc))))
- (t
- (setf (tn-sc tn)
- (svref *backend-sc-numbers* (first scs))))))))
+ (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
+ (cond ((rest scs)
+ (multiple-value-bind (sc unique)
+ (select-tn-representation tn scs costs)
+ (when unique
+ (setf (tn-sc tn) sc))))
+ (t
+ (setf (tn-sc tn)
+ (svref *backend-sc-numbers* (first scs))))))))
- (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
- (sc (if (rest scs)
- (select-tn-representation tn scs costs)
- (svref *backend-sc-numbers* (first scs)))))
- (aver sc)
- (setf (tn-sc tn) sc))))
+ (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
+ (sc (if (rest scs)
+ (select-tn-representation tn scs costs)
+ (svref *backend-sc-numbers* (first scs)))))
+ (aver sc)
+ (setf (tn-sc tn) sc))))
(setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
(do-ir2-blocks (block component)
(emit-moves-and-coercions block))
(macrolet ((frob (slot restricted)
(setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
(do-ir2-blocks (block component)
(emit-moves-and-coercions block))
(macrolet ((frob (slot restricted)