X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=a67b43ff7c1894d146c91e35a166ace43ce6c941;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=d331db65d566a48d4007895bd3d7bdf577356fab;hpb=ecad36c71e99fa4155b80af8bed38d02b9bdb83d;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index d331db6..a67b43f 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -93,10 +93,8 @@ ;;; matches the specified result. ;;; ;;; Unlike the argument test, the result test may be called on values -;;; or function types. If STRICT-RESULT is true and SAFETY is -;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if -;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is -;;; intersected with the CONT's ASSERTED-TYPE. +;;; or function types. NODE-DERIVED-TYPE is intersected with the +;;; trusted asserted type. ;;; ;;; The error and warning functions are functions that are called to ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the @@ -107,7 +105,7 @@ (result-test #'values-subtypep) ((:lossage-fun *lossage-fun*)) ((:unwinnage-fun *unwinnage-fun*))) - (declare (type function result-test) (type combination call) + (declare (type (or function null) result-test) (type combination call) ;; FIXME: Could TYPE here actually be something like ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How ;; horrible... -- CSR, 2003-05-03 @@ -153,17 +151,26 @@ (when keyp (check-key-args args max-args type)))) - (let* ((dtype (node-derived-type call)) - (return-type (fun-type-returns type)) - (out-type dtype)) - (multiple-value-bind (int win) (funcall result-test out-type return-type) - (cond ((not win) - (note-unwinnage "can't tell whether the result is a ~S" - (type-specifier return-type))) - ((not int) - (note-lossage "The result is a ~S, not a ~S." - (type-specifier out-type) - (type-specifier return-type))))))) + (when result-test + (let* ((dtype (node-derived-type call)) + (out-type (or + (binding* ((lvar (node-lvar call) :exit-if-null) + (dest (lvar-dest lvar))) + (when (and (cast-p dest) + (eq (cast-type-to-check dest) *wild-type*) + (immediately-used-p lvar call)) + (values-type-intersection + dtype (cast-asserted-type dest)))) + dtype)) + (return-type (fun-type-returns type))) + (multiple-value-bind (int win) (funcall result-test out-type return-type) + (cond ((not win) + (note-unwinnage "can't tell whether the result is a ~S" + (type-specifier return-type))) + ((not int) + (note-lossage "The result is a ~S, not a ~S." + (type-specifier out-type) + (type-specifier return-type)))))))) (loop for arg in args and i from 1 do (check-arg-type arg *wild-type* i))) @@ -171,18 +178,18 @@ (*unwinnage-detected* (values nil nil)) (t (values t t))))) -;;; Check that the derived type of the continuation CONT is compatible -;;; with TYPE. N is the arg number, for error message purposes. We -;;; return true if arg is definitely o.k. If the type is a magic -;;; CONSTANT-TYPE, then we check for the argument being a constant -;;; value of the specified type. If there is a manifest type error -;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even -;;; when our type is satisfied under the test. -(defun check-arg-type (cont type n) - (declare (type continuation cont) (type ctype type) (type index n)) +;;; Check that the derived type of the LVAR is compatible with TYPE. N +;;; is the arg number, for error message purposes. We return true if +;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then +;;; we check for the argument being a constant value of the specified +;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then +;;; we flame about the asserted type even when our type is satisfied +;;; under the test. +(defun check-arg-type (lvar type n) + (declare (type lvar lvar) (type ctype type) (type index n)) (cond ((not (constant-type-p type)) - (let ((ctype (continuation-type cont))) + (let ((ctype (lvar-type lvar))) (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type) (cond ((not win) (note-unwinnage "can't tell whether the ~:R argument is a ~S" @@ -196,16 +203,16 @@ (note-unwinnage "The ~:R argument never returns a value." n) nil) (t t))))) - ((not (constant-continuation-p cont)) + ((not (constant-lvar-p lvar)) (note-unwinnage "The ~:R argument is not a constant." n) nil) (t - (let ((val (continuation-value cont)) + (let ((val (lvar-value lvar)) (type (constant-type-type type))) (multiple-value-bind (res win) (ctypep val type) (cond ((not win) (note-unwinnage "can't tell whether the ~:R argument is a ~ - constant ~S:~% ~S" + constant ~S:~% ~S" n (type-specifier type) val) nil) ((not res) @@ -244,12 +251,12 @@ (let ((k (car key))) (cond ((not (check-arg-type k (specifier-type 'symbol) n))) - ((not (constant-continuation-p k)) + ((not (constant-lvar-p k)) (note-unwinnage "The ~:R argument (in keyword position) is not a ~ - constant." + constant." n)) (t - (let* ((name (continuation-value k)) + (let* ((name (lvar-value k)) (info (find name (fun-type-keywords type) :key #'key-info-name))) (cond ((not info) @@ -265,7 +272,7 @@ ;;; ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct ;;; the &REST type. -(declaim (ftype (function (functional) fun-type) definition-type)) +(declaim (ftype (sfunction (functional) fun-type) definition-type)) (defun definition-type (functional) (if (lambda-p functional) (make-fun-type @@ -354,8 +361,8 @@ (args (combination-args call)) (nargs (length args)) (allowp (some (lambda (x) - (and (constant-continuation-p x) - (eq (continuation-value x) :allow-other-keys))) + (and (constant-lvar-p x) + (eq (lvar-value x) :allow-other-keys))) args))) (setf (approximate-fun-type-min-args type) @@ -369,10 +376,10 @@ (setf (approximate-fun-type-types type) (nconc types (mapcar (lambda (x) - (list (continuation-type x))) + (list (lvar-type x))) arg)))) (when (null arg) (return)) - (pushnew (continuation-type (car arg)) + (pushnew (lvar-type (car arg)) (car old) :test #'type=)) @@ -383,8 +390,8 @@ (setf (approximate-fun-type-keys type) (keys))) (let ((key (first arg)) (val (second arg))) - (when (constant-continuation-p key) - (let ((name (continuation-value key))) + (when (constant-lvar-p key) + (let ((name (lvar-value key))) (when (keywordp name) (let ((old (find-if (lambda (x) @@ -392,7 +399,7 @@ (= (approximate-key-info-position x) pos))) (keys))) - (val-type (continuation-type val))) + (val-type (lvar-type val))) (cond (old (pushnew val-type (approximate-key-info-types old) @@ -418,7 +425,7 @@ #'types-equal-or-intersect) (*lossage-fun* #'compiler-style-warn) - (*unwinnage-fun* #'compiler-note)) + (*unwinnage-fun* #'compiler-notify)) (let* ((*lossage-detected* nil) (*unwinnage-detected* nil) (required (fun-type-required type)) @@ -547,7 +554,7 @@ ((eq int *empty-type*) (note-lossage "Definition's declared type for variable ~A:~% ~S~@ - conflicts with this type from ~A:~% ~S" + conflicts with this type from ~A:~% ~S" (leaf-debug-name var) (type-specifier vtype) where (type-specifier type)) (return-from try-type-intersections (values nil nil))) @@ -599,7 +606,7 @@ (unless (eq x y) (note-lossage "The definition ~:[doesn't have~;has~] ~A, but ~ - ~A ~:[doesn't~;does~]." + ~A ~:[doesn't~;does~]." x what where y)))) (frob (optional-dispatch-keyp od) (fun-type-keyp type) "&KEY arguments") @@ -704,11 +711,11 @@ ;;; If there is no problem, we return T (even if REALLY-ASSERT was ;;; false). If there was a problem, we return NIL. (defun assert-definition-type - (functional type &key (really-assert t) - ((:lossage-fun *lossage-fun*) - #'compiler-style-warn) - unwinnage-fun - (where "previous declaration")) + (functional type &key (really-assert t) + ((:lossage-fun *lossage-fun*) + #'compiler-style-warn) + unwinnage-fun + (where "previous declaration")) (declare (type functional functional) (type function *lossage-fun*) (string where)) @@ -726,57 +733,104 @@ (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) (dtype (when return - (continuation-derived-type (return-result return))))) + (lvar-derived-type (return-result return))))) (cond - ((and dtype (not (values-types-equal-or-intersect dtype - type-returns))) - (note-lossage - "The result type from ~A:~% ~S~@ - conflicts with the definition's result type:~% ~S" - where (type-specifier type-returns) (type-specifier dtype)) - nil) - (*lossage-detected* nil) - ((not really-assert) t) - (t - (assert-continuation-type (return-result return) type-returns - (lexenv-policy (functional-lexenv functional))) - (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and unwinnage-fun - (not (csubtypep (leaf-type var) type))) - (funcall unwinnage-fun - "Assignment to argument: ~S~% ~ - prevents use of assertion from function ~ - type ~A:~% ~S~%" - (leaf-debug-name var) - where - (type-specifier type)))) - (t - (setf (leaf-type var) type) - (dolist (ref (leaf-refs var)) - (derive-node-type ref (make-single-value-type type)))))) - t)))))) - + ((and dtype (not (values-types-equal-or-intersect dtype + type-returns))) + (note-lossage + "The result type from ~A:~% ~S~@ + conflicts with the definition's result type:~% ~S" + where (type-specifier type-returns) (type-specifier dtype)) + nil) + (*lossage-detected* nil) + ((not really-assert) t) + (t + (let ((policy (lexenv-policy (functional-lexenv functional)))) + (when (policy policy (> type-check 0)) + (assert-lvar-type (return-result return) type-returns + policy))) + (loop for var in vars and type in types do + (cond ((basic-var-sets var) + (when (and unwinnage-fun + (not (csubtypep (leaf-type var) type))) + (funcall unwinnage-fun + "Assignment to argument: ~S~% ~ + prevents use of assertion from function ~ + type ~A:~% ~S~%" + (leaf-debug-name var) + where + (type-specifier type)))) + (t + (setf (leaf-type var) type) + (dolist (ref (leaf-refs var)) + (derive-node-type ref (make-single-value-type type)))))) + t)))))) + +;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION. (defun assert-global-function-definition-type (name fun) (declare (type functional fun)) (let ((type (info :function :type name)) (where (info :function :where-from name))) (when (eq where :declared) (setf (leaf-type fun) type) - (assert-definition-type fun type - :unwinnage-fun #'compiler-note - :where "proclamation")))) + (assert-definition-type + fun type + :unwinnage-fun #'compiler-notify + :where "proclamation" + :really-assert (not (awhen (info :function :info name) + (ir1-attributep (fun-info-attributes it) + explicit-check))))))) + +;;; Call FUN with (arg-lvar arg-type) +(defun map-combination-args-and-types (fun call) + (declare (type function fun) (type combination call)) + (binding* ((type (lvar-type (combination-fun call))) + (nil (fun-type-p type) :exit-if-null) + (args (combination-args call))) + (dolist (req (fun-type-required type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg req))) + (dolist (opt (fun-type-optional type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg opt))) + + (let ((rest (fun-type-rest type))) + (when rest + (dolist (arg args) + (funcall fun arg rest)))) + + (dolist (key (fun-type-keywords type)) + (let ((name (key-info-name key))) + (do ((arg args (cddr arg))) + ((null arg)) + (when (eq (lvar-value (first arg)) name) + (funcall fun (second arg) (key-info-type key)))))))) + +;;; Assert that CALL is to a function of the specified TYPE. It is +;;; assumed that the call is legal and has only constants in the +;;; keyword positions. +(defun assert-call-type (call type) + (declare (type combination call) (type fun-type type)) + (derive-node-type call (fun-type-returns type)) + (let ((policy (lexenv-policy (node-lexenv call)))) + (map-combination-args-and-types + (lambda (arg type) + (assert-lvar-type arg type policy)) + call)) + (values)) ;;;; FIXME: Move to some other file. (defun check-catch-tag-type (tag) - (declare (type continuation tag)) - (let ((ctype (continuation-type tag))) + (declare (type lvar tag)) + (let ((ctype (lvar-type tag))) (when (csubtypep ctype (specifier-type '(or number character))) (compiler-style-warn "~@" - (continuation-source tag) - (type-specifier (continuation-type tag)))))) + (lvar-source tag) + (type-specifier (lvar-type tag)))))) (defun %compile-time-type-error (values atype dtype) (declare (ignore dtype)) @@ -793,10 +847,11 @@ (destructuring-bind (values atype dtype) (basic-combination-args node) (declare (ignore values)) - (let ((atype (continuation-value atype)) - (dtype (continuation-value dtype))) + (let ((atype (lvar-value atype)) + (dtype (lvar-value dtype))) (unless (eq atype nil) - (compiler-warn - "~@" - atype dtype)))) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list atype dtype))))) (ir2-convert-full-call node block)))