X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=12681b3ffd628e09fa25eb5d65300739dbf5d5c9;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=b3b9457c531fc7ea0249eedd50e127338637bb79;hpb=c9c0e648c51317ff374851c4fcc740a15d37acae;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index b3b9457..12681b3 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -13,9 +13,6 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; cost estimation @@ -27,425 +24,522 @@ ;;; ;;; We special-case NULL, since it does have a source tranform and is ;;; interesting to us. -(defun function-cost (name) +(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 (function-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 in space. The -;;; units are based on the costs specified for various templates in the VM -;;; definition. +;;; 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 +;;; in space. The units are based on the costs specified for various +;;; templates in the VM definition. (defun type-test-cost (type) (declare (type ctype type)) - (or (let ((check (type-check-template type))) - (if check - (template-cost check) - (let ((found (cdr (assoc type *backend-type-predicates* - :test #'type=)))) - (if found - (+ (function-cost found) (function-cost 'eq)) - nil)))) + (or (when (eq type *universal-type*) + 0) + (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)))) (typecase type - (union-type - (collect ((res 0 +)) - (dolist (mem (union-type-types type)) - (res (type-test-cost mem))) - (res))) - (member-type - (* (length (member-type-members type)) - (function-cost 'eq))) - (numeric-type - (* (if (numeric-type-complexp type) 2 1) - (function-cost - (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp)) - (+ 1 - (if (numeric-type-low type) 1 0) - (if (numeric-type-high type) 1 0)))) - (t - (function-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 + :hash-function (lambda (x) + (logand (type-hash-value x) #xFF))) + ((type eq)) + (declare (type ctype 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)) + (cond ((eq type *wild-type*) type) + ((not (values-type-p type)) + (weaken-type type)) + (t + (make-values-type :required (mapcar #'weaken-type + (values-type-required type)) + :optional (mapcar #'weaken-type + (values-type-optional type)) + :rest (acond ((values-type-rest type) + (weaken-type it))))))) ;;;; checking strategy determination -;;; Return the type we should test for when we really want to check for -;;; Type. If speed, space or compilation speed is more important than safety, -;;; then we return a weaker type if it is easier to check. First we try the -;;; defined type weakenings, then look for any predicate that is cheaper. -;;; -;;; 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. -(defun maybe-weaken-check (type cont) - (declare (type ctype type) (type continuation cont)) - (cond ((policy (continuation-dest cont) - (<= speed safety) (<= space safety) (<= cspeed safety)) - type) - (t - (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)) - (setq found-super t) - (setq min-type stype min-cost stype-cost)))))) - (if found-super - min-type - *universal-type*))))) +;;; Return the type we should test for when we really want to check +;;; for TYPE. If type checking policy is "fast", then we return a +;;; weaker type if it is easier to check. First we try the defined +;;; type weakenings, then look for any predicate that is cheaper. +(defun maybe-weaken-check (type policy) + (declare (type ctype type)) + (ecase (policy policy type-check) + (0 *wild-type*) + (2 (weaken-values-type type)) + (3 type))) -;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION. -(defun no-function-values-types (type) +;;; This is like VALUES-TYPES, only we mash any complex function types +;;; to FUNCTION. +(defun no-fun-values-types (type) (declare (type ctype type)) (multiple-value-bind (res count) (values-types type) - (values (mapcar #'(lambda (type) - (if (function-type-p type) - (specifier-type 'function) - type)) - res) - count))) + (values (mapcar (lambda (type) + (if (fun-type-p type) + (specifier-type 'function) + type)) + res) + count))) ;;; Switch to disable check complementing, for evaluation. (defvar *complement-type-checks* t) -;;; Cont is a continuation we are doing a type check on and Types is a list -;;; of types that we are checking its values against. If we have proven -;;; that Cont generates a fixed number of values, then for each value, we check -;;; whether it is cheaper to then difference between the proven type and -;;; the corresponding type in Types. If so, we opt 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 debug-info is -;;; not particularly important (debug <= 1) or speed is 3, then we allow -;;; weakened checks to be simple, resulting in less informative error messages, -;;; but saving space and possibly time. -(defun maybe-negate-check (cont types force-hairy) - (declare (type continuation cont) (list types)) - (multiple-value-bind (ptypes count) - (no-function-values-types (continuation-proven-type cont)) - (if (eq count :unknown) - (if (and (every #'type-check-template types) (not force-hairy)) - (values :simple types) - (values :hairy - (mapcar #'(lambda (x) - (list nil (maybe-weaken-check x cont) x)) - types))) - (let ((res (mapcar #'(lambda (p c) - (let ((diff (type-difference p c)) - (weak (maybe-weaken-check c cont))) - (if (and diff - (< (type-test-cost diff) - (type-test-cost weak)) - *complement-type-checks*) - (list t diff c) - (list nil weak c)))) - ptypes types))) - (cond ((or force-hairy (find-if #'first res)) - (values :hairy res)) - ((every #'type-check-template types) - (values :simple types)) - ((policy (continuation-dest cont) - (or (<= debug 1) (and (= speed 3) (/= debug 3)))) - (let ((weakened (mapcar #'second res))) - (if (every #'type-check-template weakened) - (values :simple weakened) - (values :hairy res)))) - (t - (values :hairy res))))))) +;;; LVAR is an lvar we are doing a type check on and TYPES is a list +;;; of types that we are checking its values against. If we have +;;; proven that LVAR generates a fixed number of values, then for each +;;; value, we check whether it is cheaper to then difference between +;;; the proven type and the corresponding type in TYPES. If so, we opt +;;; 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. +(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)))) + (multiple-value-bind (hairy-res simple-res) + (loop for p in ptypes + and c in types + and a in original-types + and i from 0 + for cc = (if (>= i n-required) + (type-union c (specifier-type 'null)) + c) + for diff = (type-difference p cc) + collect (if (and diff + (< (type-test-cost diff) + (type-test-cost cc)) + *complement-type-checks*) + (list t diff a) + (list nil cc a)) + into hairy-res + collect cc into simple-res + finally (return (values hairy-res simple-res))) + (cond ((or force-hairy (find-if #'first hairy-res)) + (values :hairy hairy-res)) + ((every #'type-check-template simple-res) + (values :simple simple-res)) + (t + (values :hairy hairy-res)))))) -;;; Determines whether Cont's assertion is: -;;; -- Checkable by the back end (:SIMPLE), or -;;; -- Not checkable by the back end, but checkable via an explicit test in -;;; type check conversion (:HAIRY), or +;;; Determines whether CAST's assertion is: +;;; -- checkable by the back end (:SIMPLE), or +;;; -- 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). ;;; -;;; A type is checkable if it either represents a fixed number of values (as -;;; determined by VALUES-TYPES), or it is the assertion for an MV-Bind. A type -;;; is simply checkable if all the type assertions have a TYPE-CHECK-TEMPLATE. -;;; In this :SIMPLE case, the second value is a list of the type restrictions -;;; specified for the leading positional values. +;;; We may check only fixed number of values; in any case the number +;;; of generated values is trusted. If we know the number of produced +;;; values, all of them are checked; otherwise if we know the number +;;; of consumed -- only they are checked; otherwise the check is not +;;; performed. ;;; -;;; We force a check to be hairy even when there are fixed values if we are in -;;; a context where we may be forced to use the unknown values convention -;;; anyway. This is because IR2tran can't generate type checks for unknown -;;; values continuations but people could still be depending on the check being -;;; done. We only care about EXIT and RETURN (not MV-COMBINATION) since these -;;; are the only contexts where the ultimate values receiver +;;; A type is simply checkable if all the type assertions have a +;;; TYPE-CHECK-TEMPLATE. In this :SIMPLE case, the second value is a +;;; list of the type restrictions specified for the leading positional +;;; values. ;;; -;;; In the :HAIRY case, the second value is a list of triples of the form: -;;; (Not-P Type Original-Type) +;;; Old comment: ;;; -;;; If true, the Not-P flag indicates a test that the corresponding value is -;;; *not* of the specified Type. Original-Type is the type asserted on this -;;; value in the continuation, for use in error messages. When Not-P is true, -;;; this will be different from Type. +;;; We force a check to be hairy even when there are fixed values +;;; if we are in a context where we may be forced to use the +;;; unknown values convention anyway. This is because IR2tran can't +;;; generate type checks for unknown values lvars but people could +;;; still be depending on the check being done. We only care about +;;; EXIT and RETURN (not MV-COMBINATION) since these are the only +;;; contexts where the ultimate values receiver ;;; -;;; This allows us to take what has been proven about Cont's type into -;;; consideration. If it is cheaper to test for the difference between the -;;; derived type and the asserted type, then we check for the negation of this -;;; type instead. -(defun continuation-check-types (cont) - (declare (type continuation cont)) - (let ((type (continuation-asserted-type cont)) - (dest (continuation-dest cont))) - (assert (not (eq type *wild-type*))) - (multiple-value-bind (types count) (no-function-values-types type) - (cond ((not (eq count :unknown)) - (if (or (exit-p dest) - (and (return-p dest) - (multiple-value-bind (ignore count) - (values-types (return-result-type dest)) - (declare (ignore ignore)) - (eq count :unknown)))) - (maybe-negate-check cont types t) - (maybe-negate-check cont types nil))) - ((and (mv-combination-p dest) - (eq (basic-combination-kind dest) :local)) - (assert (values-type-p type)) - (maybe-negate-check cont (args-type-optional type) nil)) - (t - (values :too-hairy nil)))))) - -;;; Return true if Cont is a continuation 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 continuation is an argument to an unknown function, or -;;; -- the continuation 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. +;;; In the :HAIRY case, the second value is a list of triples of +;;; the form: +;;; (NOT-P TYPE ORIGINAL-TYPE) ;;; -;;; We must only return nil when it is *certain* that a check will not be done, -;;; since if we pass up this chance to do the check, it will be too late. The -;;; penalty for being too conservative is duplicated type checks. +;;; If true, the NOT-P flag indicates a test that the corresponding +;;; value is *not* of the specified TYPE. ORIGINAL-TYPE is the type +;;; asserted on this value in the lvar, for use in error +;;; messages. When NOT-P is true, this will be different from TYPE. ;;; -;;; If there is a compile-time type error, then we always return true unless -;;; the DEST is a full call. With a full call, the theory is that the type -;;; error is probably 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 the error is really in the callee, not the -;;; caller. We don't want to make people recompile all calls to a function -;;; when they were originally compiled with a bad declaration (or an old type -;;; assertion derived from a definition appearing after the call.) -(defun probable-type-check-p (cont) - (declare (type continuation cont)) - (let ((dest (continuation-dest cont))) - (cond ((eq (continuation-type-check cont) :error) - (if (and (combination-p dest) (eq (combination-kind dest) :error)) - nil - t)) - ((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) - ((eq kind :local) t) - ((member kind '(:full :error)) nil) - ((function-info-ir2-convert kind) t) - (t - (dolist (template (function-info-templates kind) nil) - (when (eq (template-policy template) :fast-safe) - (multiple-value-bind (val win) - (valid-function-use dest (template-type template)) - (when (or val (not win)) (return t))))))))) - (t t)))) +;;; This allows us to take what has been proven about CAST's argument +;;; type into consideration. If it is cheaper to test for the +;;; difference between the derived type and the asserted type, then we +;;; check for the negation of this type instead. +(defun cast-check-types (cast force-hairy) + (declare (type cast cast)) + (let* ((ctype (coerce-to-values (cast-type-to-check cast))) + (atype (coerce-to-values (cast-asserted-type cast))) + (dtype (node-derived-type cast)) + (value (cast-value cast)) + (lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar))) + (n-consumed (cond ((not lvar) + nil) + ((lvar-single-value-p lvar) + 1) + ((and (mv-combination-p dest) + (eq (mv-combination-kind dest) :local)) + (let ((fun-ref (lvar-use (mv-combination-fun dest)))) + (length (lambda-vars (ref-leaf fun-ref))))))) + (n-required (length (values-type-required dtype)))) + (aver (not (eq ctype *wild-type*))) + (cond ((and (null (values-type-optional dtype)) + (not (values-type-rest dtype))) + ;; we [almost] know how many values are produced + (maybe-negate-check value + (values-type-out ctype n-required) + (values-type-out atype n-required) + ;; backend checks only consumed values + (not (eql n-required n-consumed)) + n-required)) + ((lvar-single-value-p lvar) + ;; exactly one value is consumed + (principal-lvar-single-valuify lvar) + (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 + (maybe-negate-check value + (adjust-list (values-type-types ctype) + n-consumed + *universal-type*) + (adjust-list (values-type-types atype) + n-consumed + *universal-type*) + force-hairy + n-required)) + (t + (values :too-hairy nil))))) -;;; Return a form that we can convert to do a hairy type check of the -;;; specified Types. Types is a list of the format returned by -;;; Continuation-Check-Types in the :HAIRY case. In place of the actual -;;; value(s) we are to check, we use 'DUMMY. This constant reference is later -;;; replaced with the actual values continuation. +;;; 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 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 +;;; 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: 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))))))))))))) ;;; -;;; Note that we don't attempt to check for required values being unsupplied. -;;; Such checking is impossible to efficiently do at the source level because -;;; our fixed-values conventions are optimized for the common MV-Bind case. +;;; 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)))) + +;;; 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 +;;; LVAR-CHECK-TYPES in the :HAIRY case. ;;; -;;; We can always use Multiple-Value-Bind, since the macro is clever about -;;; binding a single variable. +;;; Note that we don't attempt to check for required values being +;;; unsupplied. Such checking is impossible to efficiently do at the +;;; source level because our fixed-values conventions are optimized +;;; for the common MV-BIND case. (defun make-type-check-form (types) (let ((temps (make-gensym-list (length types)))) - `(multiple-value-bind ,temps 'dummy - ,@(mapcar #'(lambda (temp type) - (let* ((spec - (let ((*unparse-function-type-simplify* t)) - (type-specifier (second type)))) - (test (if (first type) `(not ,spec) spec))) - `(unless (typep ,temp ',test) - (%type-check-error - ,temp - ',(type-specifier (third type)))))) - temps - types) + `(multiple-value-bind ,temps + 'dummy + ,@(mapcar (lambda (temp type) + (let* ((spec + (let ((*unparse-fun-type-simplify* t)) + (type-specifier (second type)))) + (test (if (first type) `(not ,spec) spec))) + `(unless (typep ,temp ',test) + (%type-check-error + ,temp + ',(type-specifier (third type)))))) + temps + types) (values ,@temps)))) -;;; Splice in explicit type check code immediately before the node which is -;;; Cont's Dest. This code receives the value(s) that were being passed to -;;; Cont, checks the type(s) of the value(s), then passes them on to Cont. -(defun convert-type-check (cont types) - (declare (type continuation cont) (type list types)) - (with-ir1-environment (continuation-dest cont) - - ;; Ensuring that CONT starts a block lets us freely manipulate its uses. - (ensure-block-start cont) - - ;; Make a new continuation and move CONT's uses to it. - (let* ((new-start (make-continuation)) - (dest (continuation-dest cont)) - (prev (node-prev dest))) - (continuation-starts-block new-start) - (substitute-continuation-uses new-start cont) - - ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the check has - ;; been done. - (setf (continuation-%type-check cont) :deleted) - - ;; Make the DEST node start its block so that we can splice in the - ;; type check code. - (when (continuation-use prev) - (node-ends-block (continuation-use prev))) - - (let* ((prev-block (continuation-block prev)) - (new-block (continuation-block new-start)) - (dummy (make-continuation))) - - ;; Splice in the new block before DEST, giving the new block all of - ;; DEST's predecessors. - (dolist (block (block-pred prev-block)) - (change-block-successor block prev-block new-block)) - - ;; Convert the check form, using the new block start as START and a - ;; dummy continuation as CONT. - (ir1-convert new-start dummy (make-type-check-form types)) - - ;; TO DO: Why should this be true? -- WHN 19990601 - (assert (eq (continuation-block dummy) new-block)) - - ;; KLUDGE: Comments at the head of this function in CMU CL said that - ;; somewhere in here we - ;; Set the new block's start and end cleanups to the *start* - ;; cleanup of PREV's block. This overrides the incorrect - ;; default from WITH-IR1-ENVIRONMENT. - ;; Unfortunately I can't find any code which corresponds to this. - ;; Perhaps it was a stale comment? Or perhaps I just don't - ;; understand.. -- WHN 19990521 - - (let ((node (continuation-use dummy))) - (setf (block-last new-block) node) - ;; Change the use to a use of CONT. (We need to use the dummy - ;; continuation to get the control transfer right, because we want to - ;; go to PREV's block, not CONT's.) - (delete-continuation-use node) - (add-continuation-use node cont)) - ;; Link the new block to PREV's block. - (link-blocks new-block prev-block)) - - ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type of - ;; 'DUMMY, not a real form. At this point we convert to the real form by - ;; finding 'DUMMY and overwriting it with the new continuation. (We can - ;; find 'DUMMY because no LET conversion has been done yet.) The - ;; [mv-]combination code from the mv-bind in the check form will be the - ;; use of the new check continuation. We substitute for the first - ;; argument of this node. - (let* ((node (continuation-use cont)) - (args (basic-combination-args node)) - (victim (first args))) - (assert (and (= (length args) 1) - (eq (constant-value - (ref-leaf - (continuation-use victim))) - 'dummy))) - (substitute-continuation new-start victim))) - - ;; Invoking local call analysis converts this call to a LET. - (local-call-analyze *current-component*)) - - (values)) +;;; Splice in explicit type check code immediately before CAST. This +;;; code receives the value(s) that were being passed to CAST-VALUE, +;;; checks the type(s) of the value(s), then passes them further. +(defun convert-type-check (cast types) + (declare (type cast cast) (type list types)) + (let ((value (cast-value cast)) + (length (length types))) + (filter-lvar value (make-type-check-form types)) + (reoptimize-lvar (cast-value cast)) + (setf (cast-type-to-check cast) *wild-type*) + (setf (cast-%type-check cast) nil) + (let* ((atype (cast-asserted-type cast)) + (atype (cond ((not (values-type-p atype)) + atype) + ((= length 1) + (single-value-type atype)) + (t + (make-values-type + :required (values-type-out atype length))))) + (dtype (node-derived-type cast)) + (dtype (make-values-type + :required (values-type-out dtype length)))) + (setf (cast-asserted-type cast) atype) + (setf (node-derived-type cast) dtype))) -;;; Emit a type warning for Node. If the value of node is being used for a -;;; variable binding, we figure out which one for source context. If the value -;;; is a constant, we print it specially. We ignore nodes whose type is NIL, -;;; since they are supposed to never return. -(defun do-type-warning (node) - (declare (type node node)) - (let* ((*compiler-error-context* node) - (cont (node-cont node)) - (atype-spec (type-specifier (continuation-asserted-type cont))) - (dtype (node-derived-type node)) - (dest (continuation-dest cont)) - (what (when (and (combination-p dest) - (eq (combination-kind dest) :local)) - (let ((lambda (combination-lambda dest)) - (pos (position-or-lose cont (combination-args dest)))) - (format nil "~:[A possible~;The~] binding of ~S" - (and (continuation-use cont) - (eq (functional-kind lambda) :let)) - (leaf-name (elt (lambda-vars lambda) pos))))))) - (cond ((eq dtype *empty-type*)) - ((and (ref-p node) (constant-p (ref-leaf node))) - (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" - what atype-spec (constant-value (ref-leaf node)))) - (t - (compiler-warning - "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" - what (type-specifier dtype) atype-spec)))) (values)) -;;; Mark Cont as being a continuation with a manifest type error. We set -;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an -;;; argument to a known call. The last is done so that the back end doesn't -;;; have to worry about type errors in arguments to known functions. This -;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't -;;; do a full call to funny functions. -(defun mark-error-continuation (cont) - (declare (type continuation cont)) - (setf (continuation-%type-check cont) :error) - (let ((dest (continuation-dest cont))) - (when (and (combination-p dest) - (let ((kind (basic-combination-kind dest))) - (or (eq kind :full) - (and (function-info-p kind) - (not (function-info-ir2-convert kind)))))) - (setf (basic-combination-kind dest) :error))) +;;; Check all possible arguments of CAST and emit type warnings for +;;; those with type errors. If the value of USE is being used for a +;;; variable binding, we figure out which one for source context. If +;;; the value is a constant, we print it specially. +(defun cast-check-uses (cast) + (declare (type cast cast)) + (let* ((lvar (node-lvar cast)) + (dest (and lvar (lvar-dest lvar))) + (value (cast-value cast)) + (atype (cast-asserted-type cast)) + (condition 'type-warning) + (not-ok-uses '())) + (do-uses (use value) + (let ((dtype (node-derived-type use))) + (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, looking for -;;; continuations with TYPE-CHECK T. We do two mostly unrelated things: detect -;;; compile-time type errors and determine if and how to do run-time type -;;; checks. +;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set, +;;; looking for CASTs with TYPE-CHECK T. We do two mostly unrelated +;;; things: detect compile-time type errors and determine if and how +;;; to do run-time type checks. ;;; -;;; If there is a compile-time type error, then we mark the continuation and -;;; emit a warning if appropriate. This part loops over all the uses of the -;;; continuation, since after we convert the check, the :DELETED kind will -;;; inhibit warnings about the types of other uses. +;;; If there is a compile-time type error, then we mark the CAST and +;;; emit a warning if appropriate. This part loops over all the uses +;;; of the continuation, since after we convert the check, the +;;; :DELETED kind will inhibit warnings about the types of other uses. ;;; -;;; If a continuation is too complex to be checked by the back end, or is -;;; better checked with explicit code, then convert to an explicit test. -;;; Assertions that can checked by the back end are passed through. Assertions -;;; that can't be tested are flamed about and marked as not needing to be -;;; checked. +;;; If the cast is too complex to be checked by the back end, or is +;;; better checked with explicit code, then convert to an explicit +;;; test. Assertions that can checked by the back end are passed +;;; through. Assertions that can't be tested are flamed about and +;;; marked as not needing to be checked. ;;; -;;; If we determine that a type check won't be done, then we set TYPE-CHECK -;;; to :NO-CHECK. In the non-hairy cases, this is just to prevent us from -;;; wasting time coming to the same conclusion again on a later iteration. In -;;; the hairy case, we must indicate to LTN that it must choose a safe -;;; implementation, since IR2 conversion will choke on the check. +;;; If we determine that a type check won't be done, then we set +;;; TYPE-CHECK to :NO-CHECK. In the non-hairy cases, this is just to +;;; prevent us from wasting time coming to the same conclusion again +;;; on a later iteration. In the hairy case, we must indicate to LTN +;;; that it must choose a safe implementation, since IR2 conversion +;;; will choke on the check. ;;; ;;; The generation of the type checks is delayed until all the type ;;; check decisions have been made because the generation of the type @@ -453,38 +547,36 @@ ;;; which may lead to inappropriate template choices due to the ;;; modification of argument types. (defun generate-type-checks (component) - (collect ((conts)) + (collect ((casts)) (do-blocks (block component) (when (block-type-check block) - (do-nodes (node cont block) - (let ((type-check (continuation-type-check cont))) - (unless (member type-check '(nil :error :deleted)) - (let ((atype (continuation-asserted-type cont))) - (do-uses (use cont) - (unless (values-types-intersect (node-derived-type use) - atype) - (mark-error-continuation cont) - (unless (policy node (= brevity 3)) - (do-type-warning use)))))) - (when (and (eq type-check t) - (not *byte-compiling*)) - (cond ((probable-type-check-p cont) - (conts cont)) - (t - (setf (continuation-%type-check cont) :no-check)))))) - (setf (block-type-check block) nil))) - (dolist (cont (conts)) - (multiple-value-bind (check types) (continuation-check-types cont) - (ecase check - (:simple) - (:hairy - (convert-type-check cont types)) - (:too-hairy - (let* ((context (continuation-dest cont)) - (*compiler-error-context* context)) - (when (policy context (>= safety brevity)) - (compiler-note - "type assertion too complex to check:~% ~S." - (type-specifier (continuation-asserted-type cont))))) - (setf (continuation-%type-check cont) :deleted)))))) + ;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass + (do-nodes-backwards (node nil block) + (when (and (cast-p node) + (cast-type-check node)) + (cast-check-uses node) + (cond ((cast-externally-checkable-p node) + (setf (cast-%type-check node) :external)) + (t + ;; it is possible that NODE was marked :EXTERNAL by + ;; the previous pass + (setf (cast-%type-check node) t) + (casts (cons node (not (probable-type-check-p node)))))))) + (setf (block-type-check block) nil))) + (dolist (cast (casts)) + (destructuring-bind (cast . force-hairy) cast + (multiple-value-bind (check types) + (cast-check-types cast force-hairy) + (ecase check + (:simple) + (:hairy + (convert-type-check cast types)) + (:too-hairy + (let ((*compiler-error-context* cast)) + (when (policy cast (>= safety inhibit-warnings)) + (compiler-notify + "type assertion too complex to check:~% ~S." + (type-specifier (coerce-to-values (cast-asserted-type cast)))))) + (setf (cast-type-to-check cast) *wild-type*) + (setf (cast-%type-check cast) nil))))))) (values))