X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=12681b3ffd628e09fa25eb5d65300739dbf5d5c9;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=3fd81d57a6fed065ece18b06d969fd7a26925e3f;hpb=bfa4310e41dcd011ca9d139f29be1c5757b41378;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 3fd81d5..12681b3 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -27,15 +27,15 @@ (defun fun-guessed-cost (name) (declare (symbol name)) (let ((info (info :function :info name)) - (call-cost (template-cost (template-or-lose 'call-named)))) + (call-cost (template-cost (template-or-lose 'call-named)))) (if info - (let ((templates (fun-info-templates info))) - (if templates - (template-cost (first templates)) - (case name - (null (template-cost (template-or-lose 'if-eq))) - (t call-cost)))) - call-cost))) + (let ((templates (fun-info-templates info))) + (if templates + (template-cost (first templates)) + (case name + (null (template-cost (template-or-lose 'if-eq))) + (t call-cost)))) + call-cost))) ;;; Return some sort of guess for the cost of doing a test against ;;; TYPE. The result need not be precise as long as it isn't way out @@ -48,34 +48,87 @@ (when (eq type *empty-type*) 0) (let ((check (type-check-template type))) - (if check - (template-cost check) - (let ((found (cdr (assoc type *backend-type-predicates* - :test #'type=)))) - (if found - (+ (fun-guessed-cost found) (fun-guessed-cost 'eq)) - nil)))) + (if check + (template-cost check) + (let ((found (cdr (assoc type *backend-type-predicates* + :test #'type=)))) + (if found + (+ (fun-guessed-cost found) (fun-guessed-cost 'eq)) + nil)))) (typecase type - (compound-type - (reduce #'+ (compound-type-types type) :key 'type-test-cost)) - (member-type - (* (length (member-type-members type)) - (fun-guessed-cost 'eq))) - (numeric-type - (* (if (numeric-type-complexp type) 2 1) - (fun-guessed-cost - (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp)) - (+ 1 - (if (numeric-type-low type) 1 0) - (if (numeric-type-high type) 1 0)))) - (cons-type - (+ (type-test-cost (specifier-type 'cons)) - (fun-guessed-cost 'car) - (type-test-cost (cons-type-car-type type)) - (fun-guessed-cost 'cdr) - (type-test-cost (cons-type-cdr-type type)))) - (t - (fun-guessed-cost 'typep))))) + (compound-type + (reduce #'+ (compound-type-types type) :key 'type-test-cost)) + (member-type + (* (member-type-size type) + (fun-guessed-cost 'eq))) + (numeric-type + (* (if (numeric-type-complexp type) 2 1) + (fun-guessed-cost + (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp)) + (+ 1 + (if (numeric-type-low type) 1 0) + (if (numeric-type-high type) 1 0)))) + (cons-type + (+ (type-test-cost (specifier-type 'cons)) + (fun-guessed-cost 'car) + (type-test-cost (cons-type-car-type type)) + (fun-guessed-cost 'cdr) + (type-test-cost (cons-type-cdr-type type)))) + (t + (fun-guessed-cost 'typep))))) + +(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 @@ -83,26 +136,42 @@ (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))) - (when (and (csubtypep type stype) - (not (union-type-p stype))) - (let ((stype-cost (type-test-cost stype))) - (when (or (< stype-cost min-cost) - (type= stype type)) - ;; 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)))))) - (if found-super - min-type - *universal-type*))) + (cond ((named-type-p type) + type) + ((csubtypep type (specifier-type 'integer)) + ;; 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)) @@ -136,11 +205,11 @@ (declare (type ctype type)) (multiple-value-bind (res count) (values-types type) (values (mapcar (lambda (type) - (if (fun-type-p type) - (specifier-type 'function) - type)) - res) - count))) + (if (fun-type-p type) + (specifier-type 'function) + type)) + res) + count))) ;;; Switch to disable check complementing, for evaluation. (defvar *complement-type-checks* t) @@ -153,17 +222,6 @@ ;;; for a :HAIRY check with that test negated. Otherwise, we try to do ;;; a simple test, and if that is impossible, we do a hairy test with ;;; non-negated types. If true, FORCE-HAIRY forces a hairy type check. -;;; -;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to -;;; weaken the test to a convenient supertype (conditional on policy.) -;;; If SPEED is 3, or DEBUG-INFO is not particularly important (DEBUG -;;; <= 1), then we allow weakened checks to be simple, resulting in -;;; less informative error messages, but saving space and possibly -;;; time. -;;; -;;; FIXME: I don't quite understand this, but it looks as though -;;; that means type checks are weakened when SPEED=3 regardless of -;;; the SAFETY level, which is not the right thing to do. (defun maybe-negate-check (lvar types original-types force-hairy n-required) (declare (type lvar lvar) (list types original-types)) (let ((ptypes (values-type-out (lvar-derived-type lvar) (length types)))) @@ -194,7 +252,7 @@ ;;; Determines whether CAST's assertion is: ;;; -- checkable by the back end (:SIMPLE), or -;;; -- not checkable by the back end, but checkable via an explicit +;;; -- not checkable by the back end, but checkable via an explicit ;;; test in type check conversion (:HAIRY), or ;;; -- not reasonably checkable at all (:TOO-HAIRY). ;;; @@ -262,16 +320,18 @@ ((lvar-single-value-p lvar) ;; exactly one value is consumed (principal-lvar-single-valuify lvar) - (let ((creq (car (args-type-required ctype)))) - (multiple-value-setq (ctype atype) - (if creq - (values creq (car (args-type-required atype))) - (values (car (args-type-optional ctype)) - (car (args-type-optional atype))))) - (maybe-negate-check value - (list ctype) (list atype) - force-hairy - n-required))) + (flet ((get-type (type) + (acond ((args-type-required type) + (car it)) + ((args-type-optional type) + (car it)) + (t (bug "type ~S is too hairy" type))))) + (multiple-value-bind (ctype atype) + (values (get-type ctype) (get-type atype)) + (maybe-negate-check value + (list ctype) (list atype) + force-hairy + n-required)))) ((and (mv-combination-p dest) (eq (mv-combination-kind dest) :local)) ;; we know the number of consumed values @@ -287,76 +347,78 @@ (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 want to check. Since we don't know what template the -;;; back end is going to choose to implement the continuation's DEST, -;;; we use a heuristic. We always return T unless: -;;; -- nobody uses the value, or -;;; -- safety is totally unimportant, or -;;; -- the lvar is an argument to an unknown function, or -;;; -- the lvar is an argument to a known function that has +;;; likely to be able to check (see GENERATE-TYPE-CHECKS). Since we +;;; don't know what template the back end is going to choose to +;;; implement the continuation's DEST, we use a heuristic. +;;; +;;; We always return T unless nobody uses the value (the backend +;;; cannot check unused LVAR chains). +;;; +;;; The logic used to be more complex, but most of the cases that used +;;; to be checked here are now dealt with differently . FIXME: but +;;; here's one we used to do, don't anymore, but could still benefit +;;; from, if we reimplemented it (elsewhere): +;;; +;;; -- If the lvar is an argument to a known function that has ;;; no IR2-CONVERT method or :FAST-SAFE templates that are -;;; compatible with the call's type. +;;; compatible with the call's type: return NIL. +;;; +;;; The code used to look like something like this: +;;; ... +;;; (:known +;;; (let ((info (basic-combination-fun-info dest))) +;;; (if (fun-info-ir2-convert info) +;;; t +;;; (dolist (template (fun-info-templates info) nil) +;;; (when (eq (template-ltn-policy template) +;;; :fast-safe) +;;; (multiple-value-bind (val win) +;;; (valid-fun-use dest (template-type template)) +;;; (when (or val (not win)) (return t))))))))))))) +;;; +;;; ADP says: It is still interesting. When we have a :SAFE template +;;; and the type assertion is derived from the destination function +;;; type, the check is unneccessary. We cannot return NIL here (the +;;; whole function has changed its meaning, and here NIL *forces* +;;; hairy check), but the functionality is interesting. (defun probable-type-check-p (cast) (declare (type cast cast)) (let* ((lvar (node-lvar cast)) (dest (and lvar (lvar-dest lvar)))) (cond ((not dest) nil) - (t t)) - #+nil - (cond ((or (not dest) - (policy dest (zerop safety))) - nil) - ((basic-combination-p dest) - (let ((kind (basic-combination-kind dest))) - (cond - ((eq cont (basic-combination-fun dest)) t) - (t - (ecase kind - (:local t) - (:full - (and (combination-p dest) - (not (values-subtypep ; explicit THE - (continuation-externally-checkable-type cont) - (continuation-type-to-check cont))))) - ;; :ERROR means that we have an invalid syntax of - ;; the call and the callee will detect it before - ;; thinking about types. - (:error nil) - (:known - (let ((info (basic-combination-fun-info dest))) - (if (fun-info-ir2-convert info) - t - (dolist (template (fun-info-templates info) nil) - (when (eq (template-ltn-policy template) - :fast-safe) - (multiple-value-bind (val win) - (valid-fun-use dest (template-type template)) - (when (or val (not win)) (return t))))))))))))) - (t t)))) + (t t)))) ;;; Return a lambda form that we can convert to do a hairy type check ;;; of the specified TYPES. TYPES is a list of the format returned by @@ -396,11 +458,11 @@ (setf (cast-%type-check cast) nil) (let* ((atype (cast-asserted-type cast)) (atype (cond ((not (values-type-p atype)) - atype) - ((= length 1) + atype) + ((= length 1) (single-value-type atype)) (t - (make-values-type + (make-values-type :required (values-type-out atype length))))) (dtype (node-derived-type cast)) (dtype (make-values-type @@ -419,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, @@ -483,7 +551,7 @@ (do-blocks (block component) (when (block-type-check block) ;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass - (do-nodes-backwards (node nil block) + (do-nodes-backwards (node nil block) (when (and (cast-p node) (cast-type-check node)) (cast-check-uses node) @@ -494,7 +562,7 @@ ;; the previous pass (setf (cast-%type-check node) t) (casts (cons node (not (probable-type-check-p node)))))))) - (setf (block-type-check block) nil))) + (setf (block-type-check block) nil))) (dolist (cast (casts)) (destructuring-bind (cast . force-hairy) cast (multiple-value-bind (check types)