0.8.1.9:

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index e7f96e9..f9a4947 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -41,6 +41,12 @@
        ;; 2002-08-21
        *wild-type*)))
 
+(defun extract-declared-element-type (array)
+  (let ((type (continuation-type array)))
+    (if (array-type-p type)
+       (array-type-element-type type)
+       *wild-type*)))
+
 ;;; The ``new-value'' for array setters must fit in the array, and the
 ;;; return type is going to be the same as the new-value for SETF
 ;;; functions.
@@ -111,11 +117,10 @@
 (defoptimizer (%with-array-data derive-type) ((array start end))
   (let ((atype (continuation-type array)))
     (when (array-type-p atype)
-      (values-specifier-type
-       `(values (simple-array ,(type-specifier
-                               (array-type-specialized-element-type atype))
-                             (*))
-               index index index)))))
+      (specifier-type
+       `(simple-array ,(type-specifier
+                       (array-type-specialized-element-type atype))
+                     (*))))))
 
 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -137,14 +142,20 @@
          `(,(if simple 'simple-array 'array)
             ,(cond ((not element-type) t)
                    ((constant-continuation-p element-type)
-                    (continuation-value element-type))
+                   (let ((ctype (careful-specifier-type
+                                 (continuation-value element-type))))
+                     (cond
+                       ((or (null ctype) (unknown-type-p ctype)) '*)
+                       (t (sb!xc:upgraded-array-element-type
+                           (continuation-value element-type))))))
                    (t
                     '*))
-            ,(cond ((not simple)
-                    '*)
-                   ((constant-continuation-p dims)
-                    (let ((val (continuation-value dims)))
-                      (if (listp val) val (list val))))
+            ,(cond ((constant-continuation-p dims)
+                    (let* ((val (continuation-value dims))
+                          (cdims (if (listp val) val (list val))))
+                     (if simple
+                         cdims
+                         (length cdims))))
                    ((csubtypep (continuation-type dims)
                                (specifier-type 'integer))
                     '(*))
@@ -303,8 +314,7 @@
           (when (constant-continuation-p initial-element)
             (let ((value (continuation-value initial-element)))
               (cond
-                ((not (csubtypep (ctype-of value)
-                                 (saetp-ctype saetp)))
+                ((not (ctypep value (saetp-ctype saetp)))
                  ;; this case will cause an error at runtime, so we'd
                  ;; better WARN about it now.
                  (compiler-warn "~@<~S is not a ~S (which is the ~
@@ -312,7 +322,7 @@
                                 value
                                 (type-specifier (saetp-ctype saetp))
                                 eltype))
-                ((not (csubtypep (ctype-of value) eltype-type))
+                ((not (ctypep value eltype-type))
                  ;; this case will not cause an error at runtime, but
                  ;; it's still worth STYLE-WARNing about.
                  (compiler-style-warn "~S is not a ~S."
@@ -339,8 +349,14 @@
         (len (if (constant-continuation-p length)
                  (continuation-value length)
                  '*))
-        (result-type-spec `(simple-array ,eltype (,len)))
         (eltype-type (ir1-transform-specifier-type eltype))
+        (result-type-spec
+         `(simple-array
+           ,(if (unknown-type-p eltype-type)
+                (give-up-ir1-transform
+                 "ELEMENT-TYPE is an unknown type: ~S" eltype)
+                (sb!xc:upgraded-array-element-type eltype))
+           (,len)))
         (saetp (find-if (lambda (saetp)
                           (csubtypep eltype-type (saetp-ctype saetp)))
                         *specialized-array-element-type-properties*)))
@@ -416,8 +432,11 @@
               (rank (length dims))
               (spec `(simple-array
                       ,(cond ((null element-type) t)
-                             ((constant-continuation-p element-type)
-                              (continuation-value element-type))
+                             ((and (constant-continuation-p element-type)
+                                   (ir1-transform-specifier-type
+                                    (continuation-value element-type)))
+                              (sb!xc:upgraded-array-element-type
+                               (continuation-value element-type)))
                              (t '*))
                           ,(make-list rank :initial-element '*))))
          `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
@@ -509,9 +528,10 @@
 
 ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
 ;;; compile-time constant.
-(deftransform vector-length ((vector) ((simple-array * (*))))
+(deftransform vector-length ((vector))
   (let ((vtype (continuation-type vector)))
-    (if (array-type-p vtype)
+    (if (and (array-type-p vtype)
+            (not (array-type-complexp vtype)))
        (let ((dim (first (array-type-dimensions vtype))))
          (when (eq dim '*) (give-up-ir1-transform))
          dim)
@@ -558,14 +578,14 @@
 ;;; Primitive used to verify indices into arrays. If we can tell at
 ;;; compile-time or we are generating unsafe code, don't bother with
 ;;; the VOP.
-(deftransform %check-bound ((array dimension index))
-  (unless (constant-continuation-p dimension)
-    (give-up-ir1-transform))
-  (let ((dim (continuation-value dimension)))
-    `(the (integer 0 ,dim) index)))
-(deftransform %check-bound ((array dimension index) * *
-                           :policy (and (> speed safety) (= safety 0)))
-  'index)
+(deftransform %check-bound ((array dimension index) * * :node node)
+  (cond ((policy node (and (> speed safety) (= safety 0)))
+         'index)
+        ((not (constant-continuation-p dimension))
+         (give-up-ir1-transform))
+        (t
+         (let ((dim (continuation-value dimension)))
+           `(the (integer 0 (,dim)) index)))))
 \f
 ;;;; WITH-ARRAY-DATA
 
@@ -821,7 +841,7 @@
       (cond ((csubtypep type (specifier-type '(simple-array * (*))))
             ;; no array header
             nil)
-           ((and (listp dims) (> (length dims) 1))
+           ((and (listp dims) (/= (length dims) 1))
             ;; multi-dimensional array, will have a header
             t)
            (t