fix MAP-INTO performance

* remove the O(n^2) algorithm for lists

* use (MAP NIL ...) for all sequence types

* avoid unnecessary LENGTH calls

* update fill pointer after mapping succeeds, not before

* add tests for MAP-INTO (there were none!)

* add some WITH-TESTs to tests/map-tests.impure.lisp

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 3a70741..96a67b3 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1045,34 +1045,74 @@ many elements are copied."
          first-sequence
          more-sequences))
 
-;;; KLUDGE: MAP has been rewritten substantially since the fork from
-;;; CMU CL in order to give reasonable performance, but this
-;;; implementation of MAP-INTO still has the same problems as the old
-;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in
-;;; the same way that the corresponding cases of MAP have been
-;;; rewritten. Instead of doing it now, though, it's easier to wait
-;;; until we have DYNAMIC-EXTENT, at which time it should become
-;;; extremely easy to define a reasonably efficient MAP-INTO in terms
-;;; of (MAP NIL ..). -- WHN 20000920
+;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
+;;; computing the length of the result sequence since we can detect
+;;; the end during mapping (if MAP even gets that far).
 (defun map-into (result-sequence function &rest sequences)
-  (let* ((fp-result
-          (and (arrayp result-sequence)
-               (array-has-fill-pointer-p result-sequence)))
-         (len (apply #'min
-                     (if fp-result
-                         (array-dimension result-sequence 0)
-                         (length result-sequence))
-                     (mapcar #'length sequences))))
-
-    (when fp-result
-      (setf (fill-pointer result-sequence) len))
-
-    (let ((really-fun (%coerce-callable-to-fun function)))
-      (dotimes (index len)
-        (setf (elt result-sequence index)
-              (apply really-fun
-                     (mapcar (lambda (seq) (elt seq index))
-                             sequences))))))
+  (declare (truly-dynamic-extent sequences))
+  (let ((really-fun (%coerce-callable-to-fun function)))
+    ;; For each result type, define a mapping function which is
+    ;; responsible for replacing RESULT-SEQUENCE elements and for
+    ;; terminating itself if the end of RESULT-SEQUENCE is reached.
+    ;;
+    ;; The mapping function is defined with the MAP-LAMBDA macrolet,
+    ;; whose syntax matches that of LAMBDA.
+    (macrolet ((map-lambda (params &body body)
+                 `(flet ((f ,params ,@body))
+                    (declare (truly-dynamic-extent #'f))
+                    ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a
+                    ;; different animal, hence the awkward flip
+                    ;; between MAP and LOOP.
+                    (if sequences
+                        (apply #'map nil #'f sequences)
+                        (loop (f))))))
+      ;; Optimize MAP-LAMBDAs since they are the inner loops. Because
+      ;; we are manually doing bounds checking with known types, turn
+      ;; off safety for vectors and lists but keep it for generic
+      ;; sequences.
+      (etypecase result-sequence
+        (vector
+         (locally (declare (optimize speed (safety 0)))
+           (with-array-data ((data result-sequence) (start) (end)
+                             ;; MAP-INTO ignores fill pointer when mapping
+                             :check-fill-pointer nil)
+             (let ((index start))
+               (declare (type index index))
+               (macrolet ((dispatch ()
+                            `(block mapping
+                               (map-lambda (&rest args)
+                                 (declare (truly-dynamic-extent args))
+                                 (when (eql index end)
+                                   (return-from mapping))
+                                 (setf (aref data index)
+                                       (apply really-fun args))
+                                 (incf index)))))
+                 (typecase data
+                   (simple-vector (dispatch))
+                   (otherwise (dispatch))))
+               (when (array-has-fill-pointer-p result-sequence)
+                 (setf (fill-pointer result-sequence) (- index start)))))))
+        (list
+         (let ((node result-sequence))
+           (declare (type list node))
+           (map-lambda (&rest args)
+             (declare (truly-dynamic-extent args) (optimize speed (safety 0)))
+             (when (null node)
+               (return-from map-into result-sequence))
+             (setf (car node) (apply really-fun args))
+             (setf node (cdr node)))))
+        (sequence
+         (multiple-value-bind (iter limit from-end)
+             (sb!sequence:make-sequence-iterator result-sequence)
+           (map-lambda (&rest args)
+             (declare (truly-dynamic-extent args) (optimize speed))
+             (when (sb!sequence:iterator-endp result-sequence
+                                              iter limit from-end)
+               (return-from map-into result-sequence))
+             (setf (sb!sequence:iterator-element result-sequence iter)
+                   (apply really-fun args))
+             (setf iter (sb!sequence:iterator-step result-sequence
+                                                   iter from-end))))))))
   result-sequence)
 \f
 ;;;; quantifiers

diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp
index ec999b5..d8a11d4 100644 (file)
--- a/tests/map-tests.impure.lisp
+++ b/tests/map-tests.impure.lisp
@@ -11,15 +11,81 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "test-util.lisp")
 (load "assertoid.lisp")
 (use-package "ASSERTOID")
 
 ;;; tests of MAP
 ;;; FIXME: Move these into their own file.
-(assertoid (map 'vector #'+ '(1 2 3) '(30 20))
-           :expected-equalp #(31 22))
-(assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
-           :expected-equal '(201))
+(test-util:with-test (:name :map)
+  (assertoid (map 'vector #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+  (assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
+             :expected-equal '(201)))
+
+;;; tests of MAP-INTO
+
+(test-util:with-test (:name :map-into)
+  (assertoid (map-into (vector) #'+ '(1 2 3) '(30 20))
+             :expected-equalp #())
+  (assertoid (map-into (vector 99) #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31))
+  (assertoid (map-into (vector 99 88) #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+  (assertoid (map-into (vector 99 88 77) #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22 77))
+
+  (assertoid (map-into (list) #'+ '(1 2 3) '(30 20))
+             :expected-equalp '())
+  (assertoid (map-into (list 99) #'+ '(1 2 3) '(30 20))
+             :expected-equalp '(31))
+  (assertoid (map-into (list 99 88) #'+ '(1 2 3) '(30 20))
+             :expected-equalp '(31 22))
+  (assertoid (map-into (list 99 88 77) #'+ '(1 2 3) '(30 20))
+             :expected-equalp '(31 22 77))
+
+  (assertoid (map-into (vector 99 99 99) (constantly 5))
+             :expected-equalp #(5 5 5))
+  (assertoid (map-into (vector 99 99 99) (let ((x 0)) (lambda () (incf x))))
+             :expected-equalp #(1 2 3))
+
+  (assertoid (map-into (list 99 99 99) (constantly 5))
+             :expected-equalp '(5 5 5))
+  (assertoid (map-into (list 99 99 99) (let ((x 0)) (lambda () (incf x))))
+             :expected-equalp '(1 2 3))
+
+  (assertoid (map-into (make-array 0 :element-type 'fixnum)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #())
+  (assertoid (map-into (make-array 1 :element-type 'fixnum :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31))
+  (assertoid (map-into (make-array 2 :element-type 'fixnum :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+  (assertoid (map-into (make-array 3 :element-type 'fixnum :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22 99))
+
+  (assertoid (map-into (make-array 0 :fill-pointer 0 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #())
+  (assertoid (map-into (make-array 1 :fill-pointer 0 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31))
+  (assertoid (map-into (make-array 2 :fill-pointer 0 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+  (assertoid (map-into (make-array 3 :fill-pointer 0 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+
+  (assertoid (map-into (make-array 9 :fill-pointer 9 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22))
+  (assertoid (map-into (make-array 9 :fill-pointer 5 :initial-element 99)
+                       #'+ '(1 2 3) '(30 20))
+             :expected-equalp #(31 22)))
 
 (defmacro with-mapnil-test-fun (fun-name &body body)
   `(let ((reversed-result nil))
@@ -27,15 +93,17 @@
               (push rest reversed-result)))
        ,@body
        (nreverse reversed-result))))
-(assertoid (with-mapnil-test-fun fun
-             (map nil #'fun #(1)))
-           :expected-equal '((1)))
-(assertoid (with-mapnil-test-fun fun
-             (map nil #'fun #() '(1 2 3)))
-           :expected-equal '())
-(assertoid (with-mapnil-test-fun fun
-             (map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
-           :expected-equal '((a alpha aleph) (b beta beth)))
+
+(test-util:with-test (:name :map-nil)
+  (assertoid (with-mapnil-test-fun fun
+               (map nil #'fun #(1)))
+             :expected-equal '((1)))
+  (assertoid (with-mapnil-test-fun fun
+               (map nil #'fun #() '(1 2 3)))
+             :expected-equal '())
+  (assertoid (with-mapnil-test-fun fun
+               (map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
+             :expected-equal '((a alpha aleph) (b beta beth))))
 
 ;;; Exercise MAP repeatedly on the same dataset by providing various
 ;;; combinations of sequence type arguments, declarations, and so
@@ -82,7 +150,11 @@
             (arrange
              `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
                          :expected-equalp (coerce ,result-seq
-                                                  ',result-type)))))
+                                                  ',result-type))))
+          (arrange
+           `(assertoid (map-into (fill (copy-seq ,result-seq) 9999)
+                                 ,fun ,@(args-with-type-decls))
+                       :expected-equalp ,result-seq)))
         (arrange
          `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
                              (with-mapnil-test-fun mtf
@@ -95,17 +167,19 @@
                                     ,@(args-with-type-decls))))
                      :expected-equal (coerce ,result-seq 'list)))))
     `(progn ,@(nreverse reversed-assertoids))))
-(maptest :result-seq '(2 3)
-         :fun-name 1+
-         :arg-seqs (*list-2*)
-         :arg-types (list))
-(maptest :result-seq '(nil nil nil)
-         :fun-name oddp
-         :arg-seqs (*vector-30*)
-         :arg-types (vector))
-(maptest :result-seq '(12 24)
-         :fun-name +
-         :arg-seqs (*list-2* *list-2* *vector-30*)
-         :arg-types (list list vector))
+
+(test-util:with-test (:name :maptest)
+  (maptest :result-seq '(2 3)
+           :fun-name 1+
+           :arg-seqs (*list-2*)
+           :arg-types (list))
+  (maptest :result-seq '(nil nil nil)
+           :fun-name oddp
+           :arg-seqs (*vector-30*)
+           :arg-types (vector))
+  (maptest :result-seq '(12 24)
+           :fun-name +
+           :arg-seqs (*list-2* *list-2* *vector-30*)
+           :arg-types (list list vector)))
 
 ;;; success