X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=b461851c8978b1cd9145b995f85b4a3498985222;hb=e8571be6d533b80768bdae4e3e15316e4faa22fa;hp=5bcdee08cd4f86aa3a46893a00f1e182f7b84399;hpb=a9cac95ee124f8e71a31554964d308f74da9c866;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 5bcdee0..b461851 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -77,39 +77,69 @@ (t (fun-guessed-cost 'typep))))) +(defun weaken-integer-type (type) + (cond ((union-type-p type) + (let* ((types (union-type-types type)) + (one (pop types)) + (low (numeric-type-low one)) + (high (numeric-type-high one))) + (flet ((maximize (bound) + (if (and bound high) + (setf high (max high bound)) + (setf high nil))) + (minimize (bound) + (if (and bound low) + (setf low (min low bound)) + (setf low nil)))) + (dolist (a types) + (minimize (numeric-type-low a)) + (maximize (numeric-type-high a)))) + (specifier-type `(integer ,(or low '*) ,(or high '*))))) + (t + (aver (integer-type-p type)) + type))) + (defun-cached (weaken-type :hash-bits 8 :hash-function (lambda (x) (logand (type-hash-value x) #xFF))) ((type eq)) (declare (type ctype type)) - (let ((min-cost (type-test-cost type)) - (min-type type) - (found-super nil)) - (dolist (x *backend-type-predicates*) - (let* ((stype (car x)) - (samep (type= stype type))) - (when (or samep - (and (csubtypep type stype) - (not (union-type-p stype)))) - (let ((stype-cost (type-test-cost stype))) - (when (or (< stype-cost min-cost) - samep) - ;; If the supertype is equal in cost to the type, we - ;; prefer the supertype. This produces a closer - ;; approximation of the right thing in the presence of - ;; poor cost info. - (setq found-super t - min-type stype - min-cost stype-cost)))))) - ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found, - ;; but that's too liberal: it's far too easy for the user to create - ;; a union type (which are excluded above), and then trick the compiler - ;; into trusting the union type... and finally ending up corrupting the - ;; heap once a bad object sneaks past the missing type check. - (if found-super - min-type - type))) + (cond ((named-type-p type) + type) + ((csubtypep type (specifier-type 'integer)) + ;; KLUDGE: Simple range checks are not that expensive, and we *don't* + ;; want to accidentally lose eg. array bounds checks due to weakening, + ;; so for integer types we simply collapse all ranges into one. + (weaken-integer-type type)) + (t + (let ((min-cost (type-test-cost type)) + (min-type type) + (found-super nil)) + (dolist (x *backend-type-predicates*) + (let* ((stype (car x)) + (samep (type= stype type))) + (when (or samep + (and (csubtypep type stype) + (not (union-type-p stype)))) + (let ((stype-cost (type-test-cost stype))) + (when (or (< stype-cost min-cost) + samep) + ;; If the supertype is equal in cost to the type, we + ;; prefer the supertype. This produces a closer + ;; approximation of the right thing in the presence of + ;; poor cost info. + (setq found-super t + min-type stype + min-cost stype-cost)))))) + ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found, + ;; but that's too liberal: it's far too easy for the user to create + ;; a union type (which are excluded above), and then trick the compiler + ;; into trusting the union type... and finally ending up corrupting the + ;; heap once a bad object sneaks past the missing type check. + (if found-super + min-type + type))))) (defun weaken-values-type (type) (declare (type ctype type)) @@ -285,28 +315,36 @@ (t (values :too-hairy nil))))) -;;; Do we want to do a type check? +;;; Return T is the cast appears to be from the declaration of the callee, +;;; and should be checked externally -- that is, by the callee and not the caller. (defun cast-externally-checkable-p (cast) (declare (type cast cast)) (let* ((lvar (node-lvar cast)) (dest (and lvar (lvar-dest lvar)))) (and (combination-p dest) - ;; The theory is that the type assertion is from a - ;; declaration in (or on) the callee, so the callee should be - ;; able to do the check. We want to let the callee do the - ;; check, because it is possible that by the time of call - ;; that declaration will be changed and we do not want to - ;; make people recompile all calls to a function when they - ;; were originally compiled with a bad declaration. (See also - ;; bug 35.) - (or (immediately-used-p lvar cast) - (binding* ((ctran (node-next cast) :exit-if-null) - (next (ctran-next ctran))) - (and (cast-p next) - (eq (node-dest next) dest) - (eq (cast-type-check next) :external)))) - (values-subtypep (lvar-externally-checkable-type lvar) - (cast-type-to-check cast))))) + ;; The theory is that the type assertion is from a declaration on the + ;; callee, so the callee should be able to do the check. We want to + ;; let the callee do the check, because it is possible that by the + ;; time of call that declaration will be changed and we do not want + ;; to make people recompile all calls to a function when they were + ;; originally compiled with a bad declaration. + ;; + ;; ALMOST-IMMEDIATELY-USED-P ensures that we don't delegate casts + ;; that occur before nodes that can cause observable side effects -- + ;; most commonly other non-external casts: so the order in which + ;; possible type errors are signalled matches with the evaluation + ;; order. + ;; + ;; FIXME: We should let more cases be handled by the callee then we + ;; currently do, see: https://bugs.launchpad.net/sbcl/+bug/309104 + ;; This is not fixable quite here, though, because flow-analysis has + ;; deleted the LVAR of the cast by the time we get here, so there is + ;; no destination. Perhaps we should mark cases inserted by + ;; ASSERT-CALL-TYPE explicitly, and delete those whose destination is + ;; deemed unreachable? + (almost-immediately-used-p lvar cast) + (values (values-subtypep (lvar-externally-checkable-type lvar) + (cast-type-to-check cast)))))) ;;; Return true if CAST's value is an lvar whose type the back end is ;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we @@ -411,35 +449,41 @@ (let* ((lvar (node-lvar cast)) (dest (and lvar (lvar-dest lvar))) (value (cast-value cast)) - (atype (cast-asserted-type cast))) + (atype (cast-asserted-type cast)) + (condition 'type-warning) + (not-ok-uses '())) (do-uses (use value) (let ((dtype (node-derived-type use))) - (unless (values-types-equal-or-intersect dtype atype) - (let* ((*compiler-error-context* use) - (atype-spec (type-specifier atype)) - (what (when (and (combination-p dest) - (eq (combination-kind dest) :local)) - (let ((lambda (combination-lambda dest)) - (pos (position-or-lose - lvar (combination-args dest)))) - (format nil "~:[A possible~;The~] binding of ~S" - (and (lvar-has-single-use-p lvar) - (eq (functional-kind lambda) :let)) - (leaf-source-name (elt (lambda-vars lambda) - pos))))))) - (cond ((and (ref-p use) (constant-p (ref-leaf use))) - (warn 'type-warning - :format-control - "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" - :format-arguments - (list what atype-spec - (constant-value (ref-leaf use))))) - (t - (warn 'type-warning - :format-control - "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" - :format-arguments - (list what (type-specifier dtype) atype-spec))))))))) + (if (values-types-equal-or-intersect dtype atype) + (setf condition 'type-style-warning) + (push use not-ok-uses)))) + (dolist (use (nreverse not-ok-uses)) + (let* ((*compiler-error-context* use) + (dtype (node-derived-type use)) + (atype-spec (type-specifier atype)) + (what (when (and (combination-p dest) + (eq (combination-kind dest) :local)) + (let ((lambda (combination-lambda dest)) + (pos (position-or-lose + lvar (combination-args dest)))) + (format nil "~:[A possible~;The~] binding of ~S" + (and (lvar-has-single-use-p lvar) + (eq (functional-kind lambda) :let)) + (leaf-source-name (elt (lambda-vars lambda) + pos))))))) + (cond ((and (ref-p use) (constant-p (ref-leaf use))) + (warn condition + :format-control + "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" + :format-arguments + (list what atype-spec + (constant-value (ref-leaf use))))) + (t + (warn condition + :format-control + "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" + :format-arguments + (list what (type-specifier dtype) atype-spec))))))) (values)) ;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,