Re: Performance issue w/ `cl-loop`s `collect...into`

[Tianxiang Xiong <tianxiang.xiong@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 396 bytes --]

Here's a first attempt at a patch, if someone'd take a look.

On Sun, Apr 8, 2018 at 9:07 AM, Stefan Monnier <monnier@iro.umontreal.ca>
wrote:

> > I'd *guess* the fix would be applied in `cl--parse-loop-clause`?
> > Perhaps Stefan could give some pointers?
>
> Maybe I'm one of the least unknowledgeable about this code, but it's
> still pretty obscure for me, sorry,
>
>
>         Stefan
>
>
>

[-- Attachment #1.2: Type: text/html, Size: 780 bytes --]

[-- Attachment #2: 0001-Optimize-collect.into.patch --]
[-- Type: text/x-patch, Size: 7423 bytes --]

From c98679670ad541017aaaa98a5cfe4c36116f71c7 Mon Sep 17 00:00:00 2001
From: Tianxiang Xiong <tianxiang.xiong@gmail.com>
Date: Sun, 8 Apr 2018 12:36:41 -0700
Subject: [PATCH] Optimize `collect...into`

Avoid O(n^2) nconc-ing by keeping track of tail of collection.
---
 lisp/emacs-lisp/cl-macs.el | 127 ++++++++++++++++++++++++++-------------------
 1 file changed, 73 insertions(+), 54 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 9600230c07..523bfc5a9a 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1537,59 +1537,63 @@ cl--parse-loop-clause
 	(push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body)))
 
      ((memq word '(collect collecting))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum nil 'nreverse)))
-	(if (eq var cl--loop-accum-var)
-	    (push `(progn (push ,what ,var) t) cl--loop-body)
-	  (push `(progn
-                   (setq ,var (nconc ,var (list ,what)))
-                   t)
-                cl--loop-body))))
+      (let ((what (pop cl--loop-args)))
+        (cl-multiple-value-bind (var var-tail)
+            (cl--loop-handle-accum nil 'nreverse)
+          (if (eq var cl--loop-accum-var)
+              (push `(progn (push ,what ,var) t) cl--loop-body)
+            (push `(progn
+                     (if (null ,var-tail)
+                         (setq ,var (list ,what) ,var-tail (last ,var))
+                       (setq ,var-tail (setcdr ,var-tail (list ,what))))
+                     t)
+                  cl--loop-body)))))
 
      ((memq word '(nconc nconcing append appending))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum nil 'nreverse)))
-	(push `(progn
-                 (setq ,var
-                       ,(if (eq var cl--loop-accum-var)
-                            `(nconc
-                              (,(if (memq word '(nconc nconcing))
-                                    #'nreverse #'reverse)
-                               ,what)
-                              ,var)
-                          `(,(if (memq word '(nconc nconcing))
-                                 #'nconc #'append)
-                            ,var ,what)))
-                 t)
-              cl--loop-body)))
+      (let ((what (pop cl--loop-args)))
+	(cl-destructuring-bind (var) (cl--loop-handle-accum nil 'nreverse)
+          (push `(progn
+                   (setq ,var
+                         ,(if (eq var cl--loop-accum-var)
+                              `(nconc
+                                (,(if (memq word '(nconc nconcing))
+                                      #'nreverse #'reverse)
+                                 ,what)
+                                ,var)
+                            `(,(if (memq word '(nconc nconcing))
+                                   #'nconc #'append)
+                              ,var ,what)))
+                   t)
+                cl--loop-body))))
 
      ((memq word '(concat concating))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum "")))
-	(push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
+      (let ((what (pop cl--loop-args)))
+	(cl-destructuring-bind (var) (cl--loop-handle-accum "" nil 'string)
+          (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))))
 
      ((memq word '(vconcat vconcating))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum [])))
-	(push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
+      (let ((what (pop cl--loop-args)))
+	(cl-destructuring-bind (var) (cl--loop-handle-accum [] nil 'vector)
+          (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))))
 
      ((memq word '(sum summing))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum 0)))
-	(push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
+      (let ((what (pop cl--loop-args)))
+	(cl-destructuring-bind (var) (cl--loop-handle-accum 0 nil 'number)
+          (push `(progn (cl-incf ,var ,what) t) cl--loop-body))))
 
      ((memq word '(count counting))
-      (let ((what (pop cl--loop-args))
-	    (var (cl--loop-handle-accum 0)))
-	(push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
+      (let ((what (pop cl--loop-args)))
+	(cl-destructuring-bind (var) (cl--loop-handle-accum 0 nil 'number)
+          (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))))
 
      ((memq word '(minimize minimizing maximize maximizing))
       (push `(progn ,(macroexp-let2 macroexp-copyable-p temp
                                     (pop cl--loop-args)
-                       (let* ((var (cl--loop-handle-accum nil))
-                              (func (intern (substring (symbol-name word)
-                                                       0 3))))
-                         `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
+                       (let ((func (intern (substring (symbol-name word)
+                                                      0 3))))
+                         (cl-destructuring-bind (var)
+                             (cl--loop-handle-accum nil)
+                           `(setq ,var (if ,var (,func ,var ,temp) ,temp)))))
                     t)
             cl--loop-body))
 
@@ -1726,22 +1730,37 @@ cl--loop-let
       `(,(if par 'let 'let*)
         ,(nconc (nreverse temps) (nreverse new)) ,@body))))
 
-(defun cl--loop-handle-accum (def &optional func) ; uses loop-*
-  (if (eq (car cl--loop-args) 'into)
+(defun cl--loop-handle-accum (def &optional func type) ; uses loop-*
+  (setq type (or type 'list))
+  (let ((intop (eq (car cl--loop-args) 'into)))
+    (cond
+     ((and intop (eq 'list type))
+      (let* ((var (cl--pop2 cl--loop-args))
+             (var-tail (gensym (concat (symbol-name var) "-tail-"))))
+        (if (memq var cl--loop-accum-vars)
+            (push `((,var-tail ,(last def))) cl--loop-bindings)
+          (push `((,var ,def)) cl--loop-bindings)
+          (push `((,var-tail ,(last def))) cl--loop-bindings)
+          (push var cl--loop-accum-vars))
+        (list var var-tail)))
+
+     ((and intop (not (eq 'list type)))
       (let ((var (cl--pop2 cl--loop-args)))
-	(or (memq var cl--loop-accum-vars)
-	    (progn (push (list (list var def)) cl--loop-bindings)
-		   (push var cl--loop-accum-vars)))
-	var)
-    (or cl--loop-accum-var
-	(progn
-	  (push (list (list
-                       (setq cl--loop-accum-var (make-symbol "--cl-var--"))
-                       def))
-                cl--loop-bindings)
-	  (setq cl--loop-result (if func (list func cl--loop-accum-var)
-                                  cl--loop-accum-var))
-	  cl--loop-accum-var))))
+        (or (memq var cl--loop-accum-vars)
+            (progn (push `((,var ,def)) cl--loop-bindings)
+                   (push var cl--loop-accum-vars)))
+        (list var)))
+
+     (t (if cl--loop-accum-var
+            (list cl--loop-accum-var)
+          (progn
+            (push (list (list
+                         (setq cl--loop-accum-var (make-symbol "--cl-var--"))
+                         def))
+                  cl--loop-bindings)
+            (setq cl--loop-result (if func (list func cl--loop-accum-var)
+                                    cl--loop-accum-var))
+            (list cl--loop-accum-var)))))))
 
 (defun cl--loop-build-ands (clauses)
   "Return various representations of (and . CLAUSES).
-- 
2.14.3