From: Alexey Dejneka <adejneka@comail.ru>
Date: Sun, 7 Mar 2004 07:50:51 +0000 (+0000)
Subject: 0.8.8.18:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=086056ed379d22ed5d8a792778f2f35fc6cf56c6;p=sbcl.git

0.8.8.18:
        * VALID-FUN-USE:
        ** when checking result type, intersect NODE-DERIVED-TYPE with
           the trusted type assertion, if it exists;
        ** recognize NIL for RESULT-TEST as "always succeeds".
---

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 64dce3b..33c772a 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)))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 46ab1ba..c7ac819 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -831,7 +831,7 @@
 	 (recognize-known-call call ir1-converting-not-optimizing-p))
 	((valid-fun-use call type
 			:argument-test #'always-subtypep
-			:result-test #'always-subtypep
+			:result-test nil
 			;; KLUDGE: Common Lisp is such a dynamic
 			;; language that all we can do here in
 			;; general is issue a STYLE-WARNING. It
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 7240363..53d6b4d 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1134,3 +1134,21 @@
               do
               (dolist (x '(nil t))
                 (assert (eql (funcall f1 x) (funcall f2 x)))))))
+
+;;;
+(handler-case (compile nil '(lambda (x)
+                             (declare (optimize (speed 3) (safety 0)))
+                             (the double-float (sqrt (the double-float x)))))
+  (sb-ext:compiler-note ()
+    (error "Compiler does not trust result type assertion.")))
+
+(let ((f (compile nil '(lambda (x)
+                        (declare (optimize speed (safety 0)))
+                        (block nil
+                          (the double-float
+                            (multiple-value-prog1
+                                (sqrt (the double-float x))
+                              (when (< x 0)
+                                (return :minus)))))))))
+  (assert (eql (funcall f -1d0) :minus))
+  (assert (eql (funcall f 4d0) 2d0)))
diff --git a/version.lisp-expr b/version.lisp-expr
index b2bcece..479d5ba 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.8.17"
+"0.8.8.18"