X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=660f804fcde86c6f5d64336cf66b408d5d9f797b;hb=c41d75f1d2defd6234e644ef2b40440a5d1526c5;hp=6b4f15484971d0092e0dea031b1412fa5c5ab8d7;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 6b4f154..660f804 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -87,20 +87,33 @@
 				result-type-arg-value)))))
     `(lambda (result-type-arg fun ,@seq-names)
        (truly-the ,result-type
-	 ,(cond ((policy node (> speed safety))
+	 ,(cond ((policy node (< safety 3))
+		 ;; ANSI requires the length-related type check only
+		 ;; when the SAFETY quality is 3... in other cases, we
+		 ;; skip it, because it could be expensive.
 		 bare)
 		((not constant-result-type-arg-p)
 		 `(sequence-of-checked-length-given-type ,bare
 							 result-type-arg))
 		(t
-		 (let ((result-ctype (specifier-type result-type)))
+		 (let ((result-ctype (ir1-transform-specifier-type
+				      result-type)))
 		   (if (array-type-p result-ctype)
-		       (let* ((dims (array-type-dimensions result-ctype))
-			      (dim (first dims)))
-			 (if (eq dim '*)
-			     bare
-			     `(vector-of-checked-length-given-length ,bare
-								     ,dim)))
+		       (let ((dims (array-type-dimensions result-ctype)))
+			 (unless (and (listp dims) (= (length dims) 1))
+			   (give-up-ir1-transform "invalid sequence type"))
+			 (let ((dim (first dims)))
+			   (if (eq dim '*)
+			       bare
+			       `(vector-of-checked-length-given-length ,bare
+				                                       ,dim))))
+		       ;; FIXME: this is wrong, as not all subtypes of
+		       ;; VECTOR are ARRAY-TYPEs [consider, for
+		       ;; example, (OR (VECTOR T 3) (VECTOR T
+		       ;; 4))]. However, it's difficult to see what we
+		       ;; should put here... maybe we should
+		       ;; GIVE-UP-IR1-TRANSFORM if the type is a
+		       ;; subtype of VECTOR but not an ARRAY-TYPE?
 		       bare))))))))
 
 ;;; Try to compile %MAP efficiently when we can determine sequence
@@ -214,13 +227,13 @@
 		      (declare (ignorable dacc))
 		      ,push-dacc))))))))))
 
-(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+(deftransform elt ((s i) ((simple-array * (*)) *) *)
   '(aref s i))
 
-(deftransform elt ((s i) (list *) * :when :both)
+(deftransform elt ((s i) (list *) *)
   '(nth i s))
 
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
   '(%aset s i v))
 
 (deftransform %setelt ((s i v) (list * *))
@@ -228,7 +241,7 @@
 
 (macrolet ((def (name)
              `(deftransform ,name ((e l &key (test #'eql)) * *
-				   :node node :when :both)
+				   :node node)
                 (unless (constant-continuation-p l)
                   (give-up-ir1-transform))
 
@@ -293,17 +306,22 @@
 		    :policy (> speed space))
   "open code"
   (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
-    `(with-array-data ((data seq)
-		       (start start)
-		       (end end))
+    (values 
+     `(with-array-data ((data seq)
+			(start start)
+			(end end))
        (declare (type (simple-array ,element-type 1) data))
+       (declare (type fixnum start end))
        (do ((i start (1+ i)))
 	   ((= i end) seq)
 	 (declare (type index i))
 	 ;; WITH-ARRAY-DATA did our range checks once and for all, so
-	 ;; it'd be wasteful to check again on every AREF.
+	 ;; it'd be wasteful to check again on every AREF...
 	 (declare (optimize (safety 0))) 
-	 (setf (aref data i) item)))))
+	 (setf (aref data i) item)))
+     ;; ... though we still need to check that the new element can fit
+     ;; into the vector in safe code. -- CSR, 2002-07-05
+     `((declare (type ,element-type item))))))
 
 ;;;; utilities
 
@@ -605,6 +623,15 @@
 ;;;; calls when all arguments are vectors with the same element type,
 ;;;; rather than restricting them to STRINGs only.
 
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp
+;;;
+;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+;;; use that here, so that the compiler is born knowing this value.
+;;; FIXME: Add a comment telling whether this holds for all vectors
+;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+(def!constant vector-data-bit-offset
+  (* sb!vm:vector-data-offset sb!vm:n-word-bits))
+
 ;;; FIXME: Shouldn't we be testing for legality of
 ;;;   * START1, START2, END1, and END2 indices?
 ;;;   * size of copied string relative to destination string?
@@ -638,15 +665,18 @@
 ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
 ;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
 ;;; at least once DYNAMIC-EXTENT works.
+;;;
+;;; FIXME: currently KLUDGEed because of bug 188
 (deftransform concatenate ((rtype &rest sequences)
 			   (t &rest simple-string)
-			   simple-string)
+			   simple-string
+			   :policy (< safety 3))
   (collect ((lets)
 	    (forms)
 	    (all-lengths)
 	    (args))
     (dolist (seq sequences)
-      (declare (ignore seq))
+      (declare (ignorable seq))
       (let ((n-seq (gensym))
 	    (n-length (gensym)))
 	(args n-seq)
@@ -655,16 +685,19 @@
 	(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
 			       res start
 			       ,n-length))
-	(forms `(setq start (+ start ,n-length)))))
+	(forms `(setq start (opaque-identity (+ start ,n-length))))))
     `(lambda (rtype ,@(args))
        (declare (ignore rtype))
-       (let* (,@(lets)
-	      (res (make-string (truncate (the index (+ ,@(all-lengths)))
-					  sb!vm:n-byte-bits)))
-	      (start ,vector-data-bit-offset))
-	 (declare (type index start ,@(all-lengths)))
-	 ,@(forms)
-	 res))))
+       ;; KLUDGE
+       (flet ((opaque-identity (x) x))
+	 (declare (notinline opaque-identity))
+	 (let* (,@(lets)
+		  (res (make-string (truncate (the index (+ ,@(all-lengths)))
+					      sb!vm:n-byte-bits)))
+		  (start ,vector-data-bit-offset))
+	   (declare (type index start ,@(all-lengths)))
+	   ,@(forms)
+	   res)))))
 
 ;;;; CONS accessor DERIVE-TYPE optimizers