X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=2194cfaf649b11f078097f3a06a5a35532de8f8d;hb=2fe7ca730f378505f86a7553462fa3241185d444;hp=ddb8f20f41958d82e0d179c6dc3de5d70be04939;hpb=3f9b95517d494e4df59fbaafa8c95d7fb34b96d2;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index ddb8f20..2194cfa 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -28,9 +28,18 @@
 ;;; type is going to be the array upgraded element type.
 (defun extract-upgraded-element-type (array)
   (let ((type (continuation-type array)))
+    ;; Note that this IF mightn't be satisfied even if the runtime
+    ;; value is known to be a subtype of some specialized ARRAY, because
+    ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+    ;; which are represented in the compiler as INTERSECTION-TYPE, not
+    ;; array type.
     (if (array-type-p type)
 	(array-type-specialized-element-type type)
-	*universal-type*)))
+	;; KLUDGE: there is no good answer here, but at least
+	;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+	;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+	;; 2002-08-21
+	*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
@@ -38,10 +47,16 @@
 (defun assert-new-value-type (new-value array)
   (let ((type (continuation-type array)))
     (when (array-type-p type)
-      (assert-continuation-type new-value (array-type-specialized-element-type type))))
+      (assert-continuation-type new-value
+				(array-type-specialized-element-type type))))
   (continuation-type new-value))
 
-;;; Return true if Arg is NIL, or is a constant-continuation whose
+(defun assert-array-complex (array)
+  (assert-continuation-type array
+			    (make-array-type :complexp t
+					     :element-type *wild-type*)))
+
+;;; Return true if ARG is NIL, or is a constant-continuation whose
 ;;; value is NIL, false otherwise.
 (defun unsupplied-or-nil (arg)
   (declare (type (or continuation null) arg))
@@ -111,23 +126,42 @@
   (let ((simple (and (unsupplied-or-nil adjustable)
 		     (unsupplied-or-nil displaced-to)
 		     (unsupplied-or-nil fill-pointer))))
-    (specifier-type
-     `(,(if simple 'simple-array 'array)
-       ,(cond ((not element-type) t)
-	      ((constant-continuation-p 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))))
-	      ((csubtypep (continuation-type dims)
-			  (specifier-type 'integer))
-	       '(*))
-	      (t
-	       '*))))))
+    (or (careful-specifier-type
+         `(,(if simple 'simple-array 'array)
+            ,(cond ((not element-type) t)
+                   ((constant-continuation-p 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))))
+                   ((csubtypep (continuation-type dims)
+                               (specifier-type 'integer))
+                    '(*))
+                   (t
+                    '*))))
+        (specifier-type 'array))))
+
+;;; Complex array operations should assert that their array argument
+;;; is complex.  In SBCL, vectors with fill-pointers are complex.
+(defoptimizer (fill-pointer derive-type) ((vector))
+  (assert-array-complex vector))
+(defoptimizer (%set-fill-pointer derive-type) ((vector index))
+  (declare (ignorable index))
+  (assert-array-complex vector))
+
+(defoptimizer (vector-push derive-type) ((object vector))
+  (declare (ignorable object))
+  (assert-array-complex vector))
+(defoptimizer (vector-push-extend derive-type)
+    ((object vector &optional index))
+  (declare (ignorable object index))
+  (assert-array-complex vector))
+(defoptimizer (vector-pop derive-type) ((vector))
+  (assert-array-complex vector))
 
 ;;;; constructors
 
@@ -234,7 +268,7 @@
 			 "ELEMENT-TYPE is not constant."))
 		       (t
 			(continuation-value element-type))))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*))
@@ -246,7 +280,7 @@
 
     (unless saetp
       (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
-    
+
     (cond ((or (null initial-element)
 	       (and (constant-continuation-p initial-element)
 		    (eql (continuation-value initial-element)
@@ -274,7 +308,7 @@
 		 (%data-vector-and-index array 0)
 	       (fill vector initial-element))
 	     array)))))
-			 
+
 ;;; The integer type restriction on the length ensures that it will be
 ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
 ;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
@@ -292,7 +326,7 @@
 		  (continuation-value length)
 		  '*))
 	 (result-type-spec `(simple-array ,eltype (,len)))
-	 (eltype-type (specifier-type eltype))
+	 (eltype-type (ir1-transform-specifier-type eltype))
 	 (saetp (find-if (lambda (saetp)
 			   (csubtypep eltype-type (saetp-ctype saetp)))
 			 *specialized-array-element-type-properties*)))
@@ -545,7 +579,9 @@
 		  `(if (<= ,n-svalue ,n-end ,n-len)
 		       ;; success
 		       (values ,n-array ,n-svalue ,n-end 0)
-		       (failed-%with-array-data ,n-array ,n-svalue ,n-evalue))))
+		       (failed-%with-array-data ,n-array
+						,n-svalue
+						,n-evalue))))
 	     (,(if force-inline '%with-array-data-macro '%with-array-data)
 	      ,n-array ,n-svalue ,n-evalue))
        ,@forms)))