X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Frepresent.lisp;h=ab4403e5a5ac387bca5e78509352913542fd6394;hb=d147d512602d761a2dcdfded506dd1a8f9a140dc;hp=823d7c2c4937b63fdd07bb1ad0234e82d9ea8244;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 823d7c2..ab4403e 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -39,7 +39,7 @@ (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) @@ -209,20 +209,21 @@ ;;;; 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) @@ -236,34 +237,34 @@ (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 @@ -353,8 +354,9 @@ (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) @@ -523,7 +525,7 @@ (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)) @@ -538,7 +540,7 @@ (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* @@ -548,14 +550,14 @@ 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 @@ -632,7 +634,7 @@ (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) @@ -647,13 +649,13 @@ (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)