From 7635bc92ae31bbf1a8b2860e7562ede298952354 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 13 Jul 2015 18:46:06 +0300
Subject: [PATCH] Optimize out of line MAP1.

It's rarely used out of line, but some simple modifications allow it
to be faster and cons less.
---
 src/code/list.lisp | 42 ++++++++++++++++++++++--------------------
 1 file changed, 22 insertions(+), 20 deletions(-)

diff --git a/src/code/list.lisp b/src/code/list.lisp
index bdf1ddfb5..5b00a5ce1 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -1237,26 +1237,28 @@
 ;;; way. It is done when any of the arglists runs out. Until then, it
 ;;; CDRs down the arglists calling the function and accumulating
 ;;; results as desired.
-(defun map1 (fun-designator original-arglists accumulate take-car)
-  (let ((fun (%coerce-callable-to-fun fun-designator)))
-    (let* ((arglists (copy-list original-arglists))
-           (ret-list (list nil))
-           (temp ret-list))
-      (do ((res nil)
-           (args '() '()))
-          ((dolist (x arglists nil) (if (null x) (return t)))
-           (if accumulate
-               (cdr ret-list)
-               (car original-arglists)))
-        (do ((l arglists (cdr l)))
-            ((null l))
-          (push (if take-car (caar l) (car l)) args)
-          (setf (car l) (cdar l)))
-        (setq res (apply fun (nreverse args)))
-        (case accumulate
-          (:nconc (setq temp (last (nconc temp res))))
-          (:list (rplacd temp (list res))
-                 (setq temp (cdr temp))))))))
+(defun map1 (fun-designator arglists accumulate take-car)
+  (do* ((fun (%coerce-callable-to-fun fun-designator))
+        (non-acc-result (car arglists))
+        (ret-list (list nil))
+        (temp ret-list)
+        (res nil)
+        (args (make-list (length arglists))))
+       ((dolist (x arglists) (or x (return t)))
+        (if accumulate
+            (cdr ret-list)
+            non-acc-result))
+    (do ((l arglists (cdr l))
+         (arg args (cdr args)))
+        ((null l))
+      (setf (car arg) (if take-car (caar l) (car l)))
+      (setf (car l) (cdar l)))
+    (setq res (apply fun args))
+    (case accumulate
+      (:nconc (setf (cdr temp) res
+                    temp (last res)))
+      (:list (setf (cdr temp) (list res)
+                   temp (cdr temp))))))
 
 (defun mapc (function list &rest more-lists)
   #!+sb-doc
-- 
2.11.4.GIT