X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=fa3e7aa6991ac4d01704344b867b46567914749f;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=d425b3697ad26451f183d8a53244f9f80c100786;hpb=9767de1cecfe50560fe1da69fd458b6148a66da3;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index d425b36..fa3e7aa 100644
--- 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.
@@ -85,11 +91,6 @@
 
 (defoptimizer (aref derive-type) ((array &rest indices) node)
   (assert-array-rank array (length indices))
-  ;; If the node continuation has a single use then assert its type.
-  (let ((cont (node-cont node)))
-    (when (= (length (find-uses cont)) 1)
-      (assert-continuation-type cont (extract-upgraded-element-type array)
-                                (lexenv-policy (node-lexenv node)))))
   (extract-upgraded-element-type array))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
@@ -136,7 +137,12 @@
          `(,(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 ((constant-continuation-p dims)
@@ -268,8 +274,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 (sb!vm:saetp-ctype saetp)))
 			 sb!vm:*specialized-array-element-type-properties*)))
@@ -345,8 +357,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)))
@@ -495,7 +510,7 @@
          (give-up-ir1-transform))
         (t
          (let ((dim (continuation-value dimension)))
-           `(the (integer 0 ,dim) index)))))
+           `(the (integer 0 (,dim)) index)))))
 
 ;;;; WITH-ARRAY-DATA
 
@@ -716,7 +731,7 @@
                    (make-array (length bit-array-1) :element-type 'bit)))
                ;; If result is T, make it the first arg.
                (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
-                                   (bit-vector bit-vector (member t)) *)
+                                   (bit-vector bit-vector (eql t)) *)
                  `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
   (def bit-and)
   (def bit-ior)
@@ -736,23 +751,21 @@
   '(bit-not bit-array-1
 	    (make-array (length bit-array-1) :element-type 'bit)))
 (deftransform bit-not ((bit-array-1 result-bit-array)
-		       (bit-vector (constant-arg t)))
+		       (bit-vector (eql t)))
   '(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
-;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
-;;; value?
 
 ;;; Pick off some constant cases.
-(deftransform array-header-p ((array) (array))
+(defoptimizer (array-header-p derive-type) ((array))
   (let ((type (continuation-type array)))
-    (unless (array-type-p type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions type)))
-      (cond ((csubtypep type (specifier-type '(simple-array * (*))))
-	     ;; no array header
-	     nil)
-	    ((and (listp dims) (/= (length dims) 1))
-	     ;; multi-dimensional array, will have a header
-	     t)
-	    (t
-	     (give-up-ir1-transform))))))
+    (cond ((not (array-type-p type))
+           nil)
+          (t
+           (let ((dims (array-type-dimensions type)))
+             (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+                    ;; no array header
+                    (specifier-type 'null))
+                   ((and (listp dims) (/= (length dims) 1))
+                    ;; multi-dimensional array, will have a header
+                    (specifier-type '(eql t)))
+                   (t
+                    nil)))))))