(load load (cdr load))
(n 0 (1+ n)))
((null costs)
- (assert more-cost)
+ (aver more-cost)
(values arg-p
(+ n
(or (position-in #'tn-ref-across ref refs)
\f
;;;; representation selection
-;;; VOPs that we ignore in initial cost computation. We ignore SET in the
-;;; hopes that nobody is setting specials inside of loops. We ignore
-;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the
-;;; result. Notes are suppressed for T-C-E as well, since we don't need to
-;;; worry about the efficiency of that case.
-(defconstant ignore-cost-vops '(set type-check-error))
-(defconstant suppress-note-vops '(type-check-error))
-
-;;; We special-case the move VOP, since using this costs for the normal MOVE
-;;; would spuriously encourage descriptor representations. We won't actually
-;;; need to coerce to descriptor and back, since we will replace the MOVE with
-;;; a specialized move VOP. What we do is look at the other operand. If its
-;;; representation has already been chosen (e.g. if it is wired), then we use
-;;; the appropriate move costs, otherwise we just ignore the references.
+;;; VOPs that we ignore in initial cost computation. We ignore SET in
+;;; the hopes that nobody is setting specials inside of loops. We
+;;; ignore TYPE-CHECK-ERROR because we don't want the possibility of
+;;; error to bias the result. Notes are suppressed for T-C-E as well,
+;;; since we don't need to worry about the efficiency of that case.
+(defparameter *ignore-cost-vops* '(set type-check-error))
+(defparameter *suppress-note-vops* '(type-check-error))
+
+;;; We special-case the move VOP, since using this costs for the
+;;; normal MOVE would spuriously encourage descriptor representations.
+;;; We won't actually need to coerce to descriptor and back, since we
+;;; will replace the MOVE with a specialized move VOP. What we do is
+;;; look at the other operand. If its representation has already been
+;;; 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
ops-slot costs-slot more-costs-slot
write-p)
(incf (svref costs scn) res)))))
(let* ((vop (tn-ref-vop ref))
(info (vop-info vop)))
- (case (vop-info-name info)
- (#.ignore-cost-vops)
- (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))))))))
+ (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)))))))))
(values))
;;; Return the best representation for a normal TN. SCs is a list
(op-tn (tn-ref-tn op))
(*compiler-error-context* op-node))
(cond ((eq (tn-kind op-tn) :constant))
- ((policy op-node (<= speed brevity) (<= space brevity)))
- ((member (template-name (vop-info op-vop)) suppress-note-vops))
+ ((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)
(tn-ref-across val))
(pass pass-locs (cdr pass)))
((null val)
- (assert (null pass)))
+ (aver (null pass)))
(let* ((val-tn (tn-ref-tn val))
(pass-tn (first pass))
(pass-sc (tn-sc pass-tn))
(cond ((not (sc-number-stack-p pass-sc)) fp-tn)
(nfp-tn)
(t
- (assert (eq how :known-return))
+ (aver (eq how :known-return))
(setq nfp-tn (make-number-stack-pointer-tn))
(setf (tn-sc nfp-tn)
(svref *backend-sc-numbers*
node block
(template-or-lose 'compute-old-nfp)
nfp-tn vop)
- (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
+ (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)
- (assert (eq (vop-info-name (vop-info prev))
- 'allocate-frame))
+ (aver (eq (vop-info-name (vop-info prev))
+ 'allocate-frame))
prev)
(prev (vop-next prev))
(t
(do ((tn (ir2-component-normal-tns 2comp)
(tn-next tn)))
((null tn))
- (assert (tn-primitive-type tn))
+ (aver (tn-primitive-type tn))
(unless (tn-sc tn)
(let* ((scs (primitive-type-scs (tn-primitive-type tn))))
(cond ((rest scs)
(do ((tn (ir2-component-normal-tns 2comp)
(tn-next tn)))
((null tn))
- (assert (tn-primitive-type tn))
+ (aver (tn-primitive-type tn))
(unless (tn-sc tn)
(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)))))
- (assert sc)
+ (aver sc)
(setf (tn-sc tn) sc))))
(do ((alias (ir2-component-alias-tns 2comp)
projects / sbcl.git / blobdiff