X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=c0ae9dcc3c1f5f3af5f3c6a964cfe5d023e354e2;hb=cd1f265dd851941557ed3f764248c339c07493a9;hp=d67fb41b78bec65f81cfa171dace9b0e2660e5d6;hpb=6a756846fe0fe89835ec5eb68327b612c93f82c4;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index d67fb41..c0ae9dc 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -44,13 +44,14 @@
 	     `(let ((,fn-sym ,fn)
 		    (,map-result (list nil)))
 		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
-			      (,endtest (cdr ,map-result))
+			      (,endtest (truly-the list (cdr ,map-result)))
 		  (rplacd ,temp (setq ,temp (list ,call)))))))
 	  ((nil)
 	   `(let ((,fn-sym ,fn)
 		  (,n-first ,(first arglists)))
 	      (do-anonymous ,(do-clauses)
-			    (,endtest ,n-first) ,call))))))))
+			    (,endtest (truly-the list ,n-first))
+                            ,call))))))))
 
 (define-source-transform mapc (function list &rest more-lists)
   (mapfoo-transform function (cons list more-lists) nil t))
@@ -75,8 +76,8 @@
 ;;; MAP is %MAP plus a check to make sure that any length specified in
 ;;; the result type matches the actual result. We also wrap it in a
 ;;; TRULY-THE for the most specific type we can determine.
-(deftransform map ((result-type-arg fun &rest seqs) * * :node node)
-  (let* ((seq-names (make-gensym-list (length seqs)))
+(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node)
+  (let* ((seq-names (make-gensym-list (1+ (length seqs))))
 	 (bare `(%map result-type-arg fun ,@seq-names))
 	 (constant-result-type-arg-p (constant-continuation-p result-type-arg))
 	 ;; what we know about the type of the result. (Note that the
@@ -120,6 +121,54 @@
 		       ;; subtype of VECTOR but not an ARRAY-TYPE?
 		       bare))))))))
 
+;;; Return a DO loop, mapping a function FUN to elements of
+;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of
+;;; variables, bound to sequences, INTO - a variable, which is used in
+;;; MAP-INTO. RESULT and BODY are forms, which can use variables
+;;; FUNCALL-RESULT, containing the result of application of FUN, and
+;;; INDEX, containing the current position in sequences.
+(defun build-sequence-iterator (seqs seq-names &key result into body)
+  (declare (type list seqs seq-names)
+           (type symbol into))
+  (collect ((bindings)
+	    (declarations)
+            (vector-lengths)
+            (tests)
+            (places))
+    (let ((found-vector-p nil))
+      (flet ((process-vector (length)
+               (unless found-vector-p
+                 (setq found-vector-p t)
+                 (bindings `(index 0 (1+ index)))
+                 (declarations `(type index index)))
+               (vector-lengths length)))
+        (loop for seq of-type continuation in seqs
+           for seq-name in seq-names
+           for type = (continuation-type seq)
+           do (cond ((csubtypep type (specifier-type 'list))
+		     (with-unique-names (index)
+                       (bindings `(,index ,seq-name (cdr ,index)))
+                       (declarations `(type list ,index))
+                       (places `(car ,index))
+                       (tests `(endp ,index))))
+                    ((csubtypep type (specifier-type 'vector))
+                     (process-vector `(length ,seq-name))
+                     (places `(aref ,seq-name index)))
+                    (t
+                     (give-up-ir1-transform
+                      "can't determine sequence argument type"))))
+        (when into
+          (process-vector `(array-dimension ,into 0))))
+      (when found-vector-p
+        (bindings `(length (min ,@(vector-lengths))))
+        (tests `(= index length)))
+      `(do (,@(bindings))
+           ((or ,@(tests)) ,result)
+         (declare ,@(declarations))
+         (let ((funcall-result (funcall fun ,@(places))))
+           (declare (ignorable funcall-result))
+           ,body)))))
+
 ;;; Try to compile %MAP efficiently when we can determine sequence
 ;;; argument types at compile time.
 ;;;
@@ -132,27 +181,19 @@
 ;;; handle that case more efficiently, but it's left as an exercise to
 ;;; the reader, because the code is complicated enough already and I
 ;;; don't happen to need that functionality right now. -- WHN 20000410
-(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space))
+(deftransform %map ((result-type fun seq &rest seqs) * *
+		    :policy (>= speed space))
   "open code"
-  (unless seqs (abort-ir1-transform "no sequence args"))
   (unless (constant-continuation-p result-type)
     (give-up-ir1-transform "RESULT-TYPE argument not constant"))
-  (labels (;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
+  (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
 	   (fn-1subtypep (fn x y)
 	     (multiple-value-bind (subtype-p valid-p) (funcall fn x y)
 	       (if valid-p
 		   subtype-p
 		   (give-up-ir1-transform
 		    "can't analyze sequence type relationship"))))
-	   (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))
-	   (1csubtypep (x y) (fn-1subtypep #'csubtypep x y))
-	   (seq-supertype (seq)
-	     (let ((ctype (continuation-type seq)))
-	       (cond ((1csubtypep ctype (specifier-type 'vector)) 'vector)
-		     ((1csubtypep ctype (specifier-type 'list)) 'list)
-		     (t
-		      (give-up-ir1-transform
-		       "can't determine sequence argument type"))))))
+	   (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)))
     (let* ((result-type-value (continuation-value result-type))
 	   (result-supertype (cond ((null result-type-value) 'null)
 				   ((1subtypep result-type-value 'vector)
@@ -161,55 +202,32 @@
 				    'list)
 				   (t
 				    (give-up-ir1-transform
-				     "can't determine result type"))))
-	   (seq-supertypes (mapcar #'seq-supertype seqs)))
-      (cond ((and result-type-value (= 1 (length seqs)))
+				     "can't determine result type")))))
+      (cond ((and result-type-value (null seqs))
 	     ;; The consing arity-1 cases can be implemented
 	     ;; reasonably efficiently as function calls, and the cost
 	     ;; of consing should be significantly larger than
 	     ;; function call overhead, so we always compile these
 	     ;; cases as full calls regardless of speed-versus-space
 	     ;; optimization policy.
-	     (cond ((subtypep 'list result-type-value)
-		    '(apply #'%map-to-list-arity-1 fun seqs))
-		   (;; (This one can be inefficient due to COERCE, but
+	     (cond ((subtypep result-type-value 'list)
+		    '(%map-to-list-arity-1 fun seq))
+		   ( ;; (This one can be inefficient due to COERCE, but
 		    ;; the current open-coded implementation has the
 		    ;; same problem.)
 		    (subtypep result-type-value 'vector)
-		    `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
+		    `(coerce (%map-to-simple-vector-arity-1 fun seq)
 			     ',result-type-value))
 		   (t (bug "impossible (?) sequence type"))))
 	    (t
-	     (let* ((seq-args (make-gensym-list (length seqs)))
-		    (index-bindingoids
-		     (mapcar (lambda (seq-arg seq-supertype)
-			       (let ((i (gensym "I"))) 
-				 (ecase seq-supertype
-				   (vector `(,i 0 (1+ ,i)))
-				   (list `(,i ,seq-arg (rest ,i))))))
-			     seq-args seq-supertypes))
-		    (indices (mapcar #'first index-bindingoids))
-		    (index-decls (mapcar (lambda (index seq-supertype)
-					   `(type ,(ecase seq-supertype
-						     (vector 'index)
-						     (list 'list))
-						  ,index))
-					 indices seq-supertypes))
-		    (tests (mapcar (lambda (seq-arg seq-supertype index)
-				     (ecase seq-supertype
-				       (vector `(>= ,index (length ,seq-arg)))
-				       (list `(endp ,index))))
-				   seq-args seq-supertypes indices))
-		    (values (mapcar (lambda (seq-arg seq-supertype index)
-				      (ecase seq-supertype
-					(vector `(aref ,seq-arg ,index))
-					(list `(first ,index))))
-				    seq-args seq-supertypes indices)))
-	       (multiple-value-bind (push-dacc final-result)
+	     (let* ((seqs (cons seq seqs))
+		    (seq-args (make-gensym-list (length seqs))))
+	       (multiple-value-bind (push-dacc result)
 		   (ecase result-supertype
 		     (null (values nil nil))
-		     (list (values `(push dacc acc) `(nreverse acc)))
-		     (vector (values `(push dacc acc)
+		     (list (values `(push funcall-result acc)
+                                   `(nreverse acc)))
+		     (vector (values `(push funcall-result acc)
 				     `(coerce (nreverse acc)
 					      ',result-type-value))))
 		 ;; (We use the same idiom, of returning a LAMBDA from
@@ -219,17 +237,14 @@
 		 ;; of the &REST vars.)
 		 `(lambda (result-type fun ,@seq-args)
 		    (declare (ignore result-type))
-		    (do ((really-fun (%coerce-callable-to-fun fun))
-			 ,@index-bindingoids
-			 (acc nil))
-		    ((or ,@tests)
-		     ,final-result)
-		    (declare ,@index-decls)
-		    (declare (type list acc))
-		    (declare (ignorable acc))
-		    (let ((dacc (funcall really-fun ,@values)))
-		      (declare (ignorable dacc))
-		      ,push-dacc))))))))))
+                    (let ((fun (%coerce-callable-to-fun fun))
+                          (acc nil))
+                      (declare (type list acc))
+                      (declare (ignorable acc))
+                      ,(build-sequence-iterator
+                        seqs seq-args
+                        :result result
+                        :body push-dacc))))))))))
 
 ;;; MAP-INTO
 (deftransform map-into ((result fun &rest seqs)
@@ -241,25 +256,13 @@
                               (gensym))
                             seqs)))
     `(lambda (result fun ,@seqs-names)
-       (let ((length (array-dimension result 0))
-             (i 0))
-         (declare (type index i))
-         (declare (ignorable i))
-         ,(cond ((null seqs)
-                 `(dotimes (j length (setq i length))
-                    (setf (aref result j) (funcall fun))))
-                (t
-                 `(block nil
-                    (map nil
-                         (lambda (,@seqs-names)
-                           (when (= i length) (return))
-                           (setf (aref result i)
-                                 (funcall fun ,@seqs-names))
-                           (incf i))
-                         ,@seqs-names))))
-         (when (array-has-fill-pointer-p result)
-           (setf (fill-pointer result) i))
-         result))))
+       ,(build-sequence-iterator
+         seqs seqs-names
+         :result '(when (array-has-fill-pointer-p result)
+                   (setf (fill-pointer result) index))
+         :into 'result
+         :body '(setf (aref result index) funcall-result))
+       result)))
 
 
 ;;; FIXME: once the confusion over doing transforms with known-complex
@@ -566,7 +569,7 @@
 				(specifier-type 'function)))
 		(when (policy *compiler-error-context*
 			      (> speed inhibit-warnings))
-		  (compiler-note
+		  (compiler-notify
 		   "~S may not be a function, so must coerce at run-time."
 		   n-fun))
 		(once-only ((n-fun `(if (functionp ,n-fun)
@@ -618,10 +621,10 @@
 ;;; Return a form that tests the free variables STRING1 and STRING2
 ;;; for the ordering relationship specified by LESSP and EQUALP. The
 ;;; start and end are also gotten from the environment. Both strings
-;;; must be SIMPLE-STRINGs.
+;;; must be SIMPLE-BASE-STRINGs.
 (macrolet ((def (name lessp equalp)
              `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
-                                    (simple-string simple-string t t t t) *)
+                                    (simple-base-string simple-base-string t t t t) *)
                 `(let* ((end1 (if (not end1) (length string1) end1))
                         (end2 (if (not end2) (length string2) end2))
                         (index (sb!impl::%sp-string-compare
@@ -647,7 +650,7 @@
 
 (macrolet ((def (name result-fun)
              `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
-                                   (simple-string simple-string t t t t) *)
+                                   (simple-base-string simple-base-string t t t t) *)
                 `(,',result-fun
                   (sb!impl::%sp-string-compare
                    string1 start1 (or end1 (length string1))
@@ -680,7 +683,7 @@
 
 (deftransform replace ((string1 string2 &key (start1 0) (start2 0)
 				end1 end2)
-		       (simple-string simple-string &rest t)
+		       (simple-base-string simple-base-string &rest t)
 		       *
 		       ;; FIXME: consider replacing this policy test
 		       ;; with some tests for the STARTx and ENDx
@@ -716,36 +719,34 @@
 ;;;
 ;;; FIXME: currently KLUDGEed because of bug 188
 (deftransform concatenate ((rtype &rest sequences)
-			   (t &rest simple-string)
-			   simple-string
+			   (t &rest simple-base-string)
+			   simple-base-string
 			   :policy (< safety 3))
-  (collect ((lets)
-	    (forms)
-	    (all-lengths)
-	    (args))
-    (dolist (seq sequences)
-      (declare (ignorable seq))
-      (let ((n-seq (gensym))
-	    (n-length (gensym)))
-	(args n-seq)
-	(lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
-	(all-lengths n-length)
-	(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
-			       res start
-			       ,n-length))
-	(forms `(setq start (opaque-identity (+ start ,n-length))))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       ;; 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)))))
+  (loop for rest-seqs on sequences
+        for n-seq = (gensym "N-SEQ")
+        for n-length = (gensym "N-LENGTH")
+        for start = vector-data-bit-offset then next-start
+        for next-start = (gensym "NEXT-START")
+        collect n-seq into args
+        collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+        collect n-length into all-lengths
+        collect next-start into starts
+        collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+                                res ,start ,n-length)
+                into forms
+        collect `(setq ,next-start (+ ,start ,n-length)) into forms
+        finally
+        (return
+          `(lambda (rtype ,@args)
+             (declare (ignore rtype))
+             (let* (,@lets
+                      (res (make-string (truncate (the index (+ ,@all-lengths))
+                                                  sb!vm:n-byte-bits))))
+               (declare (type index ,@all-lengths))
+               (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+                 (declare (type index ,@starts))
+                 ,@forms)
+               res)))))
 
 ;;;; CONS accessor DERIVE-TYPE optimizers
 
@@ -864,13 +865,7 @@
 							    end-arg
 							    element
 							    done-p-expr)
-  (let ((offset (gensym "OFFSET"))
-	(block (gensym "BLOCK"))
-	(index (gensym "INDEX"))
-	(n-sequence (gensym "N-SEQUENCE-"))
-	(sequence (gensym "SEQUENCE"))
-	(n-end (gensym "N-END-"))
-	(end (gensym "END-")))
+  (with-unique-names (offset block index n-sequence sequence n-end end)
     `(let ((,n-sequence ,sequence-arg)
 	   (,n-end ,end-arg))
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
@@ -899,7 +894,7 @@
 
 (def!macro %find-position-vector-macro (item sequence
 					     from-end start end key test)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
@@ -913,7 +908,7 @@
 
 (def!macro %find-position-if-vector-macro (predicate sequence
 						     from-end start end key)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
@@ -924,7 +919,7 @@
 
 (def!macro %find-position-if-not-vector-macro (predicate sequence
 							 from-end start end key)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end