From 99f9e1f5885e3b219dd1f2fe3557feabc084048d Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 27 May 2012 13:44:12 +0300
Subject: [PATCH] add DO-VECTOR-DATA, remove special case from VECTOR-MAP-INTO

  DO-VECTOR-DATA is like DOVECTOR, but uses WITH-ARRAY-DATA and grabs the
  right reffer function so there's no per-element dispatch.

  Since MAP used DOSEQUENCE for for-effect/arity-1 case, and DOSEQEUNCE in
  turn uses DOVECTOR, replacing DOVECTOR there with DO-VECTOR-DATA we get the
  a performance boost while being able to drop the special case in
  VECTOR-MAP-INTO.

  Add a test for which the special case was broken: mapping a list into a
  vector.
---
 src/code/array.lisp         |   25 +++++++++++++++++++++++--
 src/code/seq.lisp           |   27 ++++++++-------------------
 tests/map-tests.impure.lisp |    5 +++++
 3 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 55c172d..0d44b09 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -339,9 +339,30 @@ of specialized arrays is supported."
                        (svref ,',table-name tag)))))))
   (def !find-data-vector-setter %%data-vector-setters%%)
   (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
-  (def !find-data-vector-reffer %%data-vector-reffers%%)
+  ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
+  ;; meaning we can have post-build dependences on this.
+  (def %find-data-vector-reffer %%data-vector-reffers%%)
   (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
 
+;;; Like DOVECTOR, but more magical -- can't use this on host.
+(defmacro do-vector-data ((elt vector &optional result) &body body)
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (with-unique-names (index vec start end ref)
+      `(with-array-data ((,vec ,vector)
+                         (,start)
+                         (,end)
+                         :check-fill-pointer t)
+         (let ((,ref (%find-data-vector-reffer ,vec)))
+           (do ((,index ,start (1+ ,index)))
+               ((>= ,index ,end)
+                (let ((,elt nil))
+                  ,@(filter-dolist-declarations decls)
+                  ,elt
+                  ,result))
+             (let ((,elt (funcall ,ref ,vec ,index)))
+               ,@decls
+               (tagbody ,@forms))))))))
+
 (macrolet ((%ref (accessor-getter extra-params)
              `(funcall (,accessor-getter array) array index ,@extra-params))
            (define (accessor-name slow-accessor-name accessor-getter
@@ -375,7 +396,7 @@ of specialized arrays is supported."
                         (declare (ignore end))
                         (,accessor-name vector index ,@extra-params)))))))
   (define hairy-data-vector-ref slow-hairy-data-vector-ref
-    !find-data-vector-reffer
+    %find-data-vector-reffer
     nil (progn))
   (define hairy-data-vector-set slow-hairy-data-vector-set
     !find-data-vector-setter
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 32d6c8d..bc678fd 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -781,7 +781,7 @@ many elements are copied."
         (let ((,sequence ,s))
           (seq-dispatch ,sequence
             (dolist (,e ,sequence ,return) ,@body)
-            (dovector (,e ,sequence ,return) ,@body)
+            (do-vector-data (,e ,sequence ,return) ,@body)
             (multiple-value-bind (state limit from-end step endp elt)
                 (sb!sequence:make-sequence-iterator ,sequence)
               (do ((state state (funcall step ,sequence state from-end)))
@@ -1070,24 +1070,13 @@ many elements are copied."
            (type list sequences))
   (let ((index start))
     (declare (type index index))
-    (if (and sequences (null (rest sequences)))
-        ;; do it manually when there is 1 input sequence
-        (with-array-data ((src (first sequences)) (src-start) (src-end)
-                          :check-fill-pointer t)
-          (let ((src-index src-start))
-            (declare (type index src-index))
-            (loop until (or (eql src-index src-end)
-                            (eql index end))
-                  do (setf (aref data index) (funcall fun (aref src src-index)))
-                     (incf index)
-                     (incf src-index))))
-        (block mapping
-          (map-into-lambda sequences (&rest args)
-            (declare (truly-dynamic-extent args))
-            (when (eql index end)
-              (return-from mapping))
-            (setf (aref data index) (apply fun args))
-            (incf index))))
+    (block mapping
+      (map-into-lambda sequences (&rest args)
+        (declare (truly-dynamic-extent args))
+        (when (eql index end)
+          (return-from mapping))
+        (setf (aref data index) (apply fun args))
+        (incf index)))
     index))
 
 ;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp
index d8a11d4..ee984dd 100644
--- a/tests/map-tests.impure.lisp
+++ b/tests/map-tests.impure.lisp
@@ -182,4 +182,9 @@
            :arg-seqs (*list-2* *list-2* *vector-30*)
            :arg-types (list list vector)))
 
+(test-util:with-test (:name :map-into-vector-from-list)
+  (map-into (eval (make-array 10))
+            #'list
+            (make-list 10)))
+
 ;;; success
-- 
1.7.10.4