From c1ec38c7fe7279b68dcce74ec4bf408defefe522 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Tue, 21 May 2013 17:57:04 -0400 Subject: [PATCH] Truthful error reporting for complicated compile-time type mismatches Type mismatches for multiple-use LVARs (i.e. resulting from conditional expressions) can't be pinpointed to a single source for the value(s). Such expressions used to be reported as type mismatches with the constant NIL. Instead, switch to a more complex format with the lowest common source form, if any (hopefully the conditional), and the nodes that may deliver the form's value. Do the same when warning about non-EQ-comparable CATCH tags. --- NEWS | 3 ++ src/compiler/ctype.lisp | 100 +++++++++++++++++++++++++++++++-------------- src/compiler/ir1opt.lisp | 2 +- src/compiler/ir1util.lisp | 24 +++++++++++ tests/compiler.pure.lisp | 32 +++++++++++++++ 5 files changed, 130 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index 28f4515..5825cd5 100644 --- a/NEWS +++ b/NEWS @@ -68,6 +68,9 @@ changes relative to sbcl-1.1.7: when testing for non-zero-ness. * bug fix: (CONCATENATE 'null ...) no longer fails for generic sequences. (lp#1162301) + * bug fix: Type mismatch for the value of conditional expressions are + correctly reported when detected at compile-time, instead of complaining + about a constant NIL (similar for non-EQ-comparable catch tags). * optimization: faster ISQRT on fixnums and small bignums * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64. * optimization: On x86-64, the number of multi-byte NOP instructions used diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index dbc19f4..62aa72e 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -892,33 +892,64 @@ (declare (type lvar tag)) (let ((ctype (lvar-type tag))) (when (csubtypep ctype (specifier-type '(or number character))) - (compiler-style-warn "~@" - (lvar-source tag) - (type-specifier (lvar-type tag)))))) + (let ((sources (lvar-all-sources tag))) + (if (singleton-p sources) + (compiler-style-warn + "~@" + (first sources) + (type-specifier (lvar-type tag))) + (compiler-style-warn + "~@" + (rest sources) (first sources) + (type-specifier (lvar-type tag)))))))) (defun %compile-time-type-error (values atype dtype context) (declare (ignore dtype)) (destructuring-bind (form . detail) context (if (and (consp atype) (eq (car atype) 'values)) - (error 'simple-type-error - :datum (car values) - :expected-type atype - :format-control - "~@" - :format-arguments (list values - detail form - atype)) - (error 'simple-type-error - :datum (car values) - :expected-type atype - :format-control "~@" + :format-arguments (list values + (rest detail) (first detail) + form + atype))) + (if (singleton-p detail) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control "~@" - :format-arguments (list detail form - (car values) - atype))))) + :format-arguments (list (car detail) form + (car values) + atype)) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control "~@" + :format-arguments (list (rest detail) (first detail) form + (car values) + atype)))))) (defoptimizer (%compile-time-type-error ir2-convert) ((objects atype dtype context) node block) @@ -932,15 +963,24 @@ (dtype (lvar-value dtype)) (detail (cdr (lvar-value context)))) (unless (eq atype nil) - (if (constantp detail) + (if (singleton-p detail) + (let ((detail (first detail))) + (if (constantp detail) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list (eval detail) atype)) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list detail dtype atype)))) (warn 'type-warning - :format-control - "~@" - :format-arguments (list (eval detail) atype)) - (warn 'type-warning - :format-control - "~@" - :format-arguments (list detail dtype atype)))))) + :format-control + "~@" + :format-arguments (list (rest detail) (first detail) dtype atype)))))) (ir2-convert-full-call node block))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 9c01bc1..838f284 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -2159,7 +2159,7 @@ ;; FIXME: Do it in one step. (let ((context (cons (node-source-form cast) - (lvar-source (cast-value cast))))) + (lvar-all-sources (cast-value cast))))) (filter-lvar value (if (cast-single-value-p cast) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index d0df903..6c0a271 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -797,6 +797,30 @@ (values nil nil) (values (node-source-form use) t)))) +(defun common-suffix (x y) + (let ((mismatch (mismatch x y :from-end t))) + (if mismatch + (subseq x mismatch) + x))) + +;;; If the LVAR has a single use, return NODE-SOURCE-FORM as a +;;; singleton. Otherwise, return a list of the lowest common +;;; ancestor source form of all the uses (if it can be found), +;;; followed by all the uses' source forms. +(defun lvar-all-sources (lvar) + (let ((use (lvar-uses lvar))) + (if (listp use) + (let ((forms '()) + (path (node-source-path (first use)))) + (dolist (use use (cons (if (find 'original-source-start path) + (find-original-source path) + "a hairy form") + forms)) + (pushnew (node-source-form use) forms) + (setf path (common-suffix path + (node-source-path use))))) + (list (node-source-form use))))) + ;;; Return the unique node, delivering a value to LVAR. #!-sb-fluid (declaim (inline lvar-use)) (defun lvar-use (lvar) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9a46285..555d3a2 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -4483,3 +4483,35 @@ (optimize speed)) (logtest x 2048)))) '(function ((unsigned-byte 10)) (values null &optional))))) + +;; type mismatches on LVARs with multiple potential sources used to +;; be reported as mismatches with the value NIL. Make sure we get +;; a warning, but that it doesn't complain about a constant NIL ... +;; of type FIXNUM. +(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast)) + (block nil + (handler-bind ((sb-int:type-warning + (lambda (c) + (assert + (not (search "Constant " + (simple-condition-format-control + c)))) + (return)))) + (compile nil `(lambda (x y z) + (declare (type fixnum y z)) + (aref (if x y z) 0)))) + (error "Where's my warning?"))) + +(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch)) + (block nil + (handler-bind ((style-warning + (lambda (c) + (assert + (not (position + nil + (simple-condition-format-arguments c)))) + (return)))) + (compile nil `(lambda (x y z f) + (declare (type fixnum y z)) + (catch (if x y z) (funcall f))))) + (error "Where's my style-warning?"))) -- 1.7.10.4