From: Christophe Rhodes <csr21@cantab.net>
Date: Sun, 23 Aug 2009 21:36:13 +0000 (+0000)
Subject: 1.0.30.51: fix for COERCE compilation regression
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d5b2c7d4ea394fe94bab07e4a1a9d6f4320b822a;p=sbcl.git

1.0.30.51: fix for COERCE compilation regression

Code of the form
  (defun foo (x)
    (declare (type simple-vector x))
    (coerce x '(vector (unsigned-byte 8))))
should not cause a full WARNING, but with the new COERCE transforms,
expanded into one of those IFs where one branch is dead, but the
compiler couldn't prove it.

Define a whole heap of new backend type predicates for all specialized
vectors, generalizing VECTOR-T-P.  (Some specialized vectors are
implemented using widetags, and so are excluded from these new
definitions).
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index b0caa93..76c9ad8 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1652,7 +1652,21 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "VALUES-TYPE-OUT" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
                "VALUES-TYPE-REST" "VALUES-TYPE-UNION"
                "VALUES-TYPE-TYPES" "VALUES-TYPES"
-               "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
+               "VALUES-TYPES-EQUAL-OR-INTERSECT"
+
+               "*VECTOR-WITHOUT-COMPLEX-TYPECODE-INFOS*"
+               "VECTOR-SINGLE-FLOAT-P" "VECTOR-DOUBLE-FLOAT-P"
+               "VECTOR-UNSIGNED-BYTE-2-P" "VECTOR-UNSIGNED-BYTE-4-P"
+               "VECTOR-UNSIGNED-BYTE-7-P" "VECTOR-UNSIGNED-BYTE-8-P"
+               "VECTOR-UNSIGNED-BYTE-15-P" "VECTOR-UNSIGNED-BYTE-16-P"
+               "VECTOR-UNSIGNED-BYTE-29-P" "VECTOR-UNSIGNED-BYTE-31-P"
+               "VECTOR-UNSIGNED-BYTE-32-P" "VECTOR-UNSIGNED-BYTE-60-P"
+               "VECTOR-UNSIGNED-BYTE-63-P" "VECTOR-UNSIGNED-BYTE-64-P"
+               "VECTOR-SIGNED-BYTE-8-P" "VECTOR-SIGNED-BYTE-16-P"
+               "VECTOR-FIXNUM-P" "VECTOR-SIGNED-BYTE-32-P"
+               "VECTOR-SIGNED-BYTE-64-P" "VECTOR-COMPLEX-SINGLE-FLOAT-P"
+               "VECTOR-COMPLEX-DOUBLE-FLOAT-P" "VECTOR-T-P"
+
                "VECTOR-NIL-P"
                "VECTOR-FILL*"
                "VECTOR-SUBSEQ*"
diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 346e388..417b1c0 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -17,12 +17,18 @@
 (defun streamp (stream)
   (typep stream 'stream))
 
-;;; Is X a (VECTOR T)?
-(defun vector-t-p (x)
-  (or (simple-vector-p x)
-      (and (complex-vector-p x)
-           (do ((data (%array-data-vector x) (%array-data-vector data)))
-               ((not (array-header-p data)) (simple-vector-p data))))))
+;;; various (VECTOR FOO) type predicates, not implemented as simple
+;;; widetag tests
+(macrolet
+    ((def ()
+       `(progn
+          ,@(loop for (name spec) in *vector-without-complex-typecode-infos*
+                  collect `(defun ,name (x)
+                             (or (typep x '(simple-array ,spec (*)))
+                                 (and (complex-vector-p x)
+                                      (do ((data (%array-data-vector x) (%array-data-vector data)))
+                                          ((not (array-header-p data)) (typep data '(simple-array ,spec (*))))))))))))
+  (def))
 
 ;;; Is X an extended sequence?
 (defun extended-sequence-p (x)
diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp
index f2a37c6..7f976a3 100644
--- a/src/compiler/generic/vm-array.lisp
+++ b/src/compiler/generic/vm-array.lisp
@@ -198,6 +198,21 @@
   "An alist for mapping simple array element types to their
 corresponding primitive types.")
 
+(defvar *vector-without-complex-typecode-infos*
+  #+sb-xc-host
+  (loop for saetp across *specialized-array-element-type-properties*
+        for specifier = (saetp-specifier saetp)
+        unless (saetp-complex-typecode saetp)
+        collect (list (if (atom specifier)
+                          (intern (format nil "VECTOR-~A-P" specifier))
+                          ;; at the moment, all specialized array
+                          ;; specifiers are either atoms or
+                          ;; two-element lists.
+                          (intern (format nil "VECTOR-~A-~A-P" (car specifier) (cadr specifier))))
+                      specifier))
+  #-sb-xc-host
+  '#.*vector-without-complex-typecode-infos*)
+
 (in-package "SB!C")
 
 (defun find-saetp (element-type)
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index a47798e..492238f 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -63,9 +63,12 @@
            unsigned-byte-64-p
            #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
            signed-byte-64-p
-           vector-t-p weak-pointer-p code-component-p lra-p
+           weak-pointer-p code-component-p lra-p
            funcallable-instance-p)
   (t) boolean (movable foldable flushable))
+(defknown #.(loop for (name) in *vector-without-complex-typecode-infos*
+                  collect name)
+  (t) boolean (movable foldable flushable))
 
 ;;;; miscellaneous "sub-primitives"
 
diff --git a/src/compiler/generic/vm-typetran.lisp b/src/compiler/generic/vm-typetran.lisp
index 05a08eb..ae7d8e6 100644
--- a/src/compiler/generic/vm-typetran.lisp
+++ b/src/compiler/generic/vm-typetran.lisp
@@ -104,13 +104,16 @@
 (define-type-predicate unsigned-byte-64-p (unsigned-byte 64))
 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
 (define-type-predicate signed-byte-64-p (signed-byte 64))
-(define-type-predicate vector-t-p (vector t))
 (define-type-predicate vector-nil-p (vector nil))
 (define-type-predicate weak-pointer-p weak-pointer)
 (define-type-predicate code-component-p code-component)
 (define-type-predicate lra-p lra)
 (define-type-predicate fdefn-p fdefn)
-
+(macrolet
+    ((def ()
+       `(progn ,@(loop for (name spec) in *vector-without-complex-typecode-infos*
+                       collect `(define-type-predicate ,name (vector ,spec))))))
+  (def))
 ;;; Unlike the un-%'ed versions, these are true type predicates,
 ;;; accepting any type object.
 (define-type-predicate %standard-char-p standard-char)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e3a1caf..fd89794 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3300,3 +3300,14 @@
          (ret (funcall fun sap 0)))
     ;; test for either endianness
     (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
+
+(with-test (:name :coerce-type-warning)
+  (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 
+                  (signed-byte 8) (signed-byte 16) (signed-byte 32)))
+    (multiple-value-bind (fun warningsp failurep)
+        (compile nil `(lambda (x)
+                        (declare (type simple-vector x))
+                        (coerce x '(vector ,type))))
+      (assert (null warningsp))
+      (assert (null failurep))
+      (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 67c6dba..044d9aa 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".)
-"1.0.30.50"
+"1.0.30.51"