X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=eb3f9df3af6ad488ac4114502b72c29c8205131e;hb=12348c1417becbbd24dd3f109ed4040dbdde62dd;hp=2f3585a1852e446ecdc084b2a9c03f6e61adc6df;hpb=d93e034b8a53d8e3d8d6fa8b768cb5952d3ee548;p=sbcl.git

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 2f3585a..eb3f9df 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -25,20 +25,21 @@
 	element-type-specifier)))
 
 ;;; Array access functions return an object from the array, hence its
-;;; type will be asserted to be array element type.
-(defun extract-element-type (array)
-  (let ((type (continuation-type array)))
-    (if (array-type-p type)
-	(array-type-element-type type)
-	*universal-type*)))
-
-;;; Array access functions return an object from the array, hence its
 ;;; 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
@@ -46,10 +47,20 @@
 (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-element-type type))))
+      (assert-continuation-type
+       new-value
+       (array-type-specialized-element-type type)
+       (lexenv-policy (node-lexenv (continuation-dest new-value))))))
   (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*)
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
+
+;;; 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))
@@ -64,7 +75,8 @@
 (defun assert-array-rank (array rank)
   (assert-continuation-type
    array
-   (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+   (specifier-type `(array * ,(make-list rank :initial-element '*)))
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
 
 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -75,7 +87,8 @@
   ;; 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-element-type array))))
+      (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))
@@ -99,7 +112,7 @@
     (when (array-type-p atype)
       (values-specifier-type
        `(values (simple-array ,(type-specifier
-				(array-type-element-type atype))
+				(array-type-specialized-element-type atype))
 			      (*))
 		index index index)))))
 
@@ -119,23 +132,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
 
@@ -155,13 +187,13 @@
 	 ,n-vec))))
 
 ;;; Just convert it into a MAKE-ARRAY.
-(define-source-transform make-string (length &key
-					     (element-type ''base-char)
-					     (initial-element
-					      '#.*default-init-char-form*))
-  `(make-array (the index ,length)
-	       :element-type ,element-type
-	       :initial-element ,initial-element))
+(deftransform make-string ((length &key
+				   (element-type 'base-char)
+				   (initial-element
+				    #.*default-init-char-form*)))
+  '(make-array (the index length)
+               :element-type element-type
+               :initial-element initial-element))
 
 (defstruct (specialized-array-element-type-properties
 	    (:conc-name saetp-)
@@ -204,6 +236,15 @@
 	 #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128
 				   ,sb!vm:simple-array-long-float-widetag)
 	 (bit 0 1 ,sb!vm:simple-bit-vector-widetag)
+	 ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
+	 ;; before their SIGNED-BYTE partners is significant in the
+	 ;; implementation of the compiler; some of the cross-compiler
+	 ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
+	 ;; src/compiler/debug-dump.lisp) attempts to create an array
+	 ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
+	 ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
+	 ;; not careful we could get the wrong specialized array when
+	 ;; we try to FIND-IF, below. -- CSR, 2002-07-08
 	 ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag)
 	 ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag)
 	 ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag)
@@ -222,10 +263,68 @@
 			,sb!vm:simple-array-complex-long-float-widetag)
 	 (t 0 32 ,sb!vm:simple-vector-widetag))))
 
+(deftransform make-array ((dims &key initial-element element-type
+				     adjustable fill-pointer)
+			  (t &rest *))
+  (when (null initial-element)
+    (give-up-ir1-transform))
+  (let* ((eltype (cond ((not element-type) t)
+		       ((not (constant-continuation-p element-type))
+			(give-up-ir1-transform
+			 "ELEMENT-TYPE is not constant."))
+		       (t
+			(continuation-value element-type))))
+	 (eltype-type (ir1-transform-specifier-type eltype))
+	 (saetp (find-if (lambda (saetp)
+			   (csubtypep eltype-type (saetp-ctype saetp)))
+			 *specialized-array-element-type-properties*))
+	 (creation-form `(make-array dims
+			  :element-type ',(type-specifier (saetp-ctype saetp))
+			  ,@(when fill-pointer
+				  '(:fill-pointer fill-pointer))
+			  ,@(when adjustable
+				  '(:adjustable adjustable)))))
+
+    (unless saetp
+      (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
+
+    (cond ((and (constant-continuation-p initial-element)
+		(eql (continuation-value initial-element)
+		     (saetp-initial-element-default saetp)))
+	   creation-form)
+	  (t
+	   ;; error checking for target, disabled on the host because
+	   ;; (CTYPE-OF #\Null) is not possible.
+	   #-sb-xc-host
+	   (when (constant-continuation-p initial-element)
+	     (let ((value (continuation-value initial-element)))
+	       (cond
+		 ((not (csubtypep (ctype-of 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 ~
+                                 UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
+				 value
+				 (type-specifier (saetp-ctype saetp))
+				 eltype))
+		 ((not (csubtypep (ctype-of 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."
+				       value eltype)))))
+	   `(let ((array ,creation-form))
+	     (multiple-value-bind (vector)
+		 (%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.
-(deftransform make-array ((length &key initial-element element-type)
+;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
+;;; :INITIAL-ELEMENT relies on another transform to deal with that
+;;; kind of initialization efficiently.
+(deftransform make-array ((length &key element-type)
 			  (integer &rest *))
   (let* ((eltype (cond ((not element-type) t)
 		       ((not (constant-continuation-p element-type))
@@ -237,16 +336,30 @@
 		  (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*)))
     (unless saetp
       (give-up-ir1-transform
        "cannot open-code creation of ~S" result-type-spec))
-
-    (let* ((initial-element-default (saetp-initial-element-default saetp))
-	   (n-bits-per-element (saetp-n-bits saetp))
+    #-sb-xc-host
+    (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+		       eltype-type)
+      ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+      ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+      ;; INITIAL-ELEMENT is not supplied, the consequences of later
+      ;; reading an uninitialized element of new-array are undefined,"
+      ;; so this could be legal code as long as the user plans to
+      ;; write before he reads, and if he doesn't we're free to do
+      ;; anything we like. But in case the user doesn't know to write
+      ;; elements before he reads elements (or to read manuals before
+      ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+      ;; didn't realize this.
+      (compiler-style-warn "The default initial element ~S is not a ~S."
+			   (saetp-initial-element-default saetp)
+			   eltype))
+    (let* ((n-bits-per-element (saetp-n-bits saetp))
 	   (typecode (saetp-typecode saetp))
 	   (n-pad-elements (saetp-n-pad-elements saetp))
 	   (padded-length-form (if (zerop n-pad-elements)
@@ -260,47 +373,22 @@
 		(let ((n-elements-per-word (/ sb!vm:n-word-bits
 					      n-bits-per-element)))
 		  (declare (type index n-elements-per-word)) ; i.e., not RATIO
-		  `(ceiling ,padded-length-form ,n-elements-per-word))))
-	   (bare-constructor-form
-	    `(truly-the ,result-type-spec
-			(allocate-vector ,typecode length ,n-words-form)))
-	   (initial-element-form (if initial-element
-				     'initial-element
-				     initial-element-default)))
+		  `(ceiling ,padded-length-form ,n-elements-per-word)))))
       (values
-       (cond (;; Can we skip the FILL step?
-	      (or (null initial-element)
-		  (and (constant-continuation-p initial-element)
-		       (eql (continuation-value initial-element)
-			    initial-element-default)))
-	      (unless (csubtypep (ctype-of initial-element-default)
-				 eltype-type)
-		;; This situation arises e.g. in
-		;;   (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5))
-		;; ANSI's definition of MAKE-ARRAY says "If
-		;; INITIAL-ELEMENT is not supplied, the consequences
-		;; of later reading an uninitialized element of
-		;; new-array are undefined," so this could be legal
-		;; code as long as the user plans to write before he
-		;; reads, and if he doesn't we're free to do anything
-		;; we like. But in case the user doesn't know to write
-		;; elements before he reads elements (or to read
-		;; manuals before he writes code:-), we'll signal a
-		;; STYLE-WARNING in case he didn't realize this.
-		(compiler-note "The default initial element ~S is not a ~S."
-			       initial-element-default
-			       eltype))
-	      bare-constructor-form)
-	     (t
-	      `(truly-the ,result-type-spec
-			  (fill ,bare-constructor-form
-				,initial-element-form))))
+       `(truly-the ,result-type-spec
+	 (allocate-vector ,typecode length ,n-words-form))
        '((declare (type index length)))))))
 
 ;;; The list type restriction does not ensure that the result will be a
 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
 ;;; and displaced-to keywords ensures that it will be simple.
-(deftransform make-array ((dims &key initial-element element-type)
+;;;
+;;; FIXME: should we generalize this transform to non-simple (though
+;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
+;;; deal with those? Maybe when the DEFTRANSFORM
+;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
+;;; CSR, 2002-07-01
+(deftransform make-array ((dims &key element-type)
 			  (list &rest *))
   (unless (or (null element-type) (constant-continuation-p element-type))
     (give-up-ir1-transform
@@ -315,8 +403,6 @@
        dims))
     (if (= (length dims) 1)
 	`(make-array ',(car dims)
-		     ,@(when initial-element
-			 '(:initial-element initial-element))
 		     ,@(when element-type
 			 '(:element-type element-type)))
 	(let* ((total-size (reduce #'* dims))
@@ -334,9 +420,7 @@
 	     (setf (%array-data-vector header)
 		   (make-array ,total-size
 			       ,@(when element-type
-				   '(:element-type element-type))
-			       ,@(when initial-element
-				   '(:initial-element initial-element))))
+				   '(:element-type element-type))))
 	     (setf (%array-displaced-p header) nil)
 	     ,@(let ((axis -1))
 		 (mapcar (lambda (dim)
@@ -520,12 +604,9 @@
 		  `(if (<= ,n-svalue ,n-end ,n-len)
 		       ;; success
 		       (values ,n-array ,n-svalue ,n-end 0)
-		       ;; failure: Make a NOTINLINE call to
-		       ;; %WITH-ARRAY-DATA with our bad data
-		       ;; to cause the error to be signalled.
-		       (locally
-			 (declare (notinline %with-array-data))
-			 (%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)))
@@ -548,14 +629,21 @@
 	      (cond (,end
 		     (unless (or ,unsafe? (<= ,end ,size))
 		       ,(if fail-inline?
-			    `(error "End ~W is greater than total size ~W."
-				    ,end ,size)
+			    `(error 'bounding-indices-bad-error
+			      :datum (cons ,start ,end)
+			      :expected-type `(cons (integer 0 ,',size)
+					            (integer ,',start ,',size))
+			      :object ,array)
 			    `(failed-%with-array-data ,array ,start ,end)))
 		     ,end)
 		    (t ,size))))
        (unless (or ,unsafe? (<= ,start ,defaulted-end))
 	 ,(if fail-inline?
-	      `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
+	      `(error 'bounding-indices-bad-error
+		:datum (cons ,start ,end)
+		:expected-type `(cons (integer 0 ,',size)
+				      (integer ,',start ,',size))
+		:object ,array)
 	      `(failed-%with-array-data ,array ,start ,end)))
        (do ((,data ,array (%array-data-vector ,data))
 	    (,cumulative-offset 0
@@ -569,16 +657,12 @@
 	 (declare (type index ,cumulative-offset))))))
 
 (deftransform %with-array-data ((array start end)
-				;; Note: This transform is limited to
-				;; VECTOR only because I happened to
-				;; create it in order to get sequence
-				;; function operations to be more
-				;; efficient. It might very well be
-				;; reasonable to allow general ARRAY
-				;; here, I just haven't tried to
-				;; understand the performance issues
-				;; involved. -- WHN
-				(vector index (or index null))
+				;; It might very well be reasonable to
+				;; allow general ARRAY here, I just
+				;; haven't tried to understand the
+				;; performance issues involved. --
+				;; WHN, and also CSR 2002-05-26
+				((or vector simple-array) index (or index null))
 				*
 				:important t
 				:node node