X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=0d6d07ff721817c174be7d709950917355867856;hb=ff57884e206ac28660af6af34315bc9b81697f57;hp=f92cd13cba2f17b9cf6029d878ce4eca92681ab1;hpb=1bbb76fcfb9baddf0dc96412c87575d8aeb69c6d;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index f92cd13..0d6d07f 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -26,27 +26,32 @@
 	  (tests `(endp ,v))
 	  (args-to-fn (if take-car `(car ,v) v))))
 
-      (let ((call `(funcall ,fn . ,(args-to-fn)))
-	    (endtest `(or ,@(tests))))
+      (let* ((fn-sym (gensym))  ; for ONCE-ONLY-ish purposes
+	     (call `(funcall ,fn-sym . ,(args-to-fn)))
+	     (endtest `(or ,@(tests))))
 	(ecase accumulate
 	  (:nconc
 	   (let ((temp (gensym))
 		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
+	     `(let ((,fn-sym ,fn)
+		    (,map-result (list nil)))
 		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
 			      (,endtest (cdr ,map-result))
 		  (setq ,temp (last (nconc ,temp ,call)))))))
 	  (:list
 	   (let ((temp (gensym))
 		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
+	     `(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 ((,n-first ,(first arglists)))
+	   `(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))
@@ -71,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
@@ -116,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.
 ;;;
@@ -128,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)
@@ -157,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
@@ -215,17 +237,33 @@
 		 ;; 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)
+                        (vector * &rest *)
+                        *)
+  "open code"
+  (let ((seqs-names (mapcar (lambda (x)
+                              (declare (ignore x))
+                              (gensym))
+                            seqs)))
+    `(lambda (result fun ,@seqs-names)
+       ,(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
 ;;; arrays is over, we should also transform the calls to (AND (ARRAY
@@ -531,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)
@@ -684,33 +722,31 @@
 			   (t &rest simple-string)
 			   simple-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
 
@@ -807,26 +843,10 @@
 			      :important t)
   "expand inline"
   '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
-			;; I'm having difficulty believing I'm
-			;; reading it right, but as far as I can see,
-			;; the only guidance that ANSI gives for the
-			;; order of arguments to asymmetric tests is
-			;; the character-set dependent example from
-			;; the definition of FIND,
-			;;   (find #\d "here are some.." :test #'char>)
-			;;     => #\Space
-			;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.)
-			;; (Neither the POSITION definition page nor
-			;; section 17.2 ("Rules about Test Functions")
-			;; seem to consider the possibility of
-			;; asymmetry.)
-			;;
-			;; So, judging from the example, we want to
-			;; do (FUNCALL TEST-FUN ITEM I), because
-			;; (FUNCALL #'CHAR> #\d #\SPACE)=>T.
-			;;
-			;; -- WHN (whose attention was drawn to it by
-			;;         Alexey Dejneka's bug report/fix)
+			;; The order of arguments for asymmetric tests
+			;; (e.g. #'<, as opposed to order-independent
+			;; tests like #'=) is specified in the spec
+			;; section 17.2.1 -- the O/Zi stuff there.
 			(lambda (i)
 			  (funcall test-fun item i)))
 		      sequence
@@ -845,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)
@@ -880,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
@@ -894,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
@@ -905,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
@@ -949,44 +963,48 @@
 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
 ;;; POSITION-IF, etc.
 (define-source-transform effective-find-position-test (test test-not)
-  `(cond
-    ((and ,test ,test-not)
-     (error "can't specify both :TEST and :TEST-NOT"))
-    (,test (%coerce-callable-to-fun ,test))
-    (,test-not
-     ;; (Without DYNAMIC-EXTENT, this is potentially horribly
-     ;; inefficient, but since the TEST-NOT option is deprecated
-     ;; anyway, we don't care.)
-     (complement (%coerce-callable-to-fun ,test-not)))
-    (t #'eql)))
+  (once-only ((test test)
+	      (test-not test-not))
+    `(cond
+      ((and ,test ,test-not)
+       (error "can't specify both :TEST and :TEST-NOT"))
+      (,test (%coerce-callable-to-fun ,test))
+      (,test-not
+       ;; (Without DYNAMIC-EXTENT, this is potentially horribly
+       ;; inefficient, but since the TEST-NOT option is deprecated
+       ;; anyway, we don't care.)
+       (complement (%coerce-callable-to-fun ,test-not)))
+      (t #'eql))))
 (define-source-transform effective-find-position-key (key)
-  `(if ,key
-       (%coerce-callable-to-fun ,key)
-       #'identity))
+  (once-only ((key key))
+    `(if ,key
+	 (%coerce-callable-to-fun ,key)
+	 #'identity)))
 
 (macrolet ((define-find-position (fun-name values-index)
-	       `(define-source-transform ,fun-name (item sequence &key
-						    from-end (start 0) end
-						    key test test-not)
-		 `(nth-value ,,values-index
-		   (%find-position ,item ,sequence
-		    ,from-end ,start
-		    ,end
-		    (effective-find-position-key ,key)
-		    (effective-find-position-test ,test ,test-not))))))
+	     `(deftransform ,fun-name ((item sequence &key
+					     from-end (start 0) end
+					     key test test-not))
+		'(nth-value ,values-index
+			    (%find-position item sequence
+					    from-end start
+					    end
+					    (effective-find-position-key key)
+					    (effective-find-position-test
+					     test test-not))))))
   (define-find-position find 0)
   (define-find-position position 1))
 
 (macrolet ((define-find-position-if (fun-name values-index)
-	       `(define-source-transform ,fun-name (predicate sequence &key
-						    from-end (start 0)
-						    end key)
-		 `(nth-value
-		   ,,values-index
-		   (%find-position-if (%coerce-callable-to-fun ,predicate)
-		    ,sequence ,from-end
-		    ,start ,end
-		    (effective-find-position-key ,key))))))
+	     `(deftransform ,fun-name ((predicate sequence &key
+						  from-end (start 0)
+						  end key))
+		'(nth-value
+		  ,values-index
+		  (%find-position-if (%coerce-callable-to-fun predicate)
+				     sequence from-end
+				     start end
+				     (effective-find-position-key key))))))
   (define-find-position-if find-if 0)
   (define-find-position-if position-if 1))
 
@@ -1011,14 +1029,14 @@
 ;;; FIXME: Maybe remove uses of these deprecated functions (and
 ;;; definitely of :TEST-NOT) within the implementation of SBCL.
 (macrolet ((define-find-position-if-not (fun-name values-index)
-	       `(define-source-transform ,fun-name (predicate sequence &key
-						    from-end (start 0)
-						    end key)
-		 `(nth-value
-		   ,,values-index
-		   (%find-position-if-not (%coerce-callable-to-fun ,predicate)
-		    ,sequence ,from-end
-		    ,start ,end
-		    (effective-find-position-key ,key))))))
+	       `(deftransform ,fun-name ((predicate sequence &key
+					  from-end (start 0)
+					  end key))
+		 '(nth-value
+		   ,values-index
+		   (%find-position-if-not (%coerce-callable-to-fun predicate)
+		    sequence from-end
+		    start end
+		    (effective-find-position-key key))))))
   (define-find-position-if-not find-if-not 0)
   (define-find-position-if-not position-if-not 1))