X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=12681b3ffd628e09fa25eb5d65300739dbf5d5c9;hb=c6aa07913db78733634b49d305f41bb8ae4f97e2;hp=46b32e11cc9140e1729c6309e1f3fe792f99283d;hpb=024389e7e3db268f535e36d883b4efc9d7ea0f65;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 46b32e1..12681b3 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -77,27 +77,58 @@ (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 weaken-integer-type (type &key range-only) + ;; FIXME: Our canonicalization isn't quite ideal for this. We get + ;; types such as: + ;; + ;; (OR (AND (SATISFIES FOO) (INTEGER -100 -50)) + ;; (AND (SATISFIES FOO) (INTEGER 100 200))) + ;; + ;; here, and weakening that into + ;; + ;; (AND (SATISFIES FOO) (INTEGER -100 200)) + ;; + ;; is too much work to do here ... but if we canonicalized things + ;; differently, we could get it for free with trivial changes here. + (labels ((weaken-integer-type-part (type base) + (cond ((intersection-type-p type) + (let ((new (specifier-type base))) + (dolist (part (intersection-type-types type)) + (when (if range-only + (numeric-type-p part) + (not (unknown-type-p part))) + (setf new (type-intersection + new (weaken-integer-type-part part t))))) + new)) + ((union-type-p type) + (let ((low t) (high t) (rest *empty-type*)) + (flet ((maximize (bound) + (if (and bound high) + (setf high (if (eq t high) + bound + (max high bound))) + (setf high nil))) + (minimize (bound) + (if (and bound low) + (setf low (if (eq t low) + bound + (min low bound))) + (setf low nil)))) + (dolist (part (union-type-types type)) + (let ((weak (weaken-integer-type-part part t))) + (cond ((numeric-type-p weak) + (minimize (numeric-type-low weak)) + (maximize (numeric-type-high weak))) + ((not range-only) + (setf rest (type-union rest weak))))))) + (if (eq t low) + rest + (type-union rest + (specifier-type + `(integer ,(or low '*) ,(or high '*))))))) + (t + type)))) + (weaken-integer-type-part type 'integer))) (defun-cached (weaken-type :hash-bits 8 @@ -108,9 +139,10 @@ (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. + ;; 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)) @@ -449,35 +481,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,