[PATCH] use tail pointer for LOOP (Was: Re: O(N^2) behavior in LOOP)

[Daniel Colascione]

We do this only for the anonymous-variable case, but it's still an
improvement.

---
/Applications/Emacs.app/Contents/Resources/lisp/emacs-lisp/cl-macs.el
2008-01-06 20:07:45.000000000 -0500
+++ cl-macs2.el 2010-05-29 19:52:09.000000000 -0400
@@ -625,6 +625,7 @@
 (defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
 (defvar loop-result) (defvar loop-result-explicit)
 (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
+(defvar loop-accum-tailptr)

 (defmacro loop (&rest args)
   "The Common Lisp `loop' macro.
@@ -650,7 +651,8 @@
          (loop-accum-var nil)  (loop-accum-vars nil)
          (loop-initially nil)  (loop-finally nil)
          (loop-map-form nil)   (loop-first-flag nil)
-         (loop-destr-temps nil) (loop-symbol-macs nil))
+         (loop-destr-temps nil) (loop-symbol-macs nil)
+          (loop-accum-tailptr nil))
       (setq args (append args '(cl-end-loop)))
       (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
       (if loop-finish-flag
@@ -984,28 +986,49 @@

      ((memq word '(collect collecting))
       (let ((what (pop args))
-           (var (cl-loop-handle-accum nil 'nreverse)))
+           (var (cl-loop-handle-accum nil :use-tailptr)))
        (if (eq var loop-accum-var)
-           (push (list 'progn (list 'push what var) t) loop-body)
-         (push (list 'progn
-                     (list 'setq var (list 'nconc var (list 'list what)))
-                     t) loop-body))))
+            ;; Anonymous case; we can use a tail pointer here
+            (push `(progn
+                     (if ,var
+                         (setq ,loop-accum-tailptr
+                               (setcdr ,loop-accum-tailptr (list ,what)))
+                       (setq ,var (list ,what))
+                       (setq ,loop-accum-tailptr ,var))
+                     t)
+                  loop-body)
+
+          ;; 'into' case. We have to use nconc here instead of
+          ;; tail-ptr setup or push-then-nreverse because user code
+          ;; can inspect and modify the given variable at any time.
+          (push `(progn
+                   (setq ,var (nconc ,var (list ,what)))
+                   t)
+                loop-body))))

-     ((memq word '(nconc nconcing append appending))
+     ((memq word '(nconc noncing append appending))
       (let ((what (pop args))
-           (var (cl-loop-handle-accum nil 'nreverse)))
-       (push (list 'progn
-                   (list 'setq var
-                         (if (eq var loop-accum-var)
-                             (list 'nconc
-                                   (list (if (memq word '(nconc nconcing))
-                                             'nreverse 'reverse)
-                                         what)
-                                   var)
-                           (list (if (memq word '(nconc nconcing))
-                                     'nconc 'append)
-                                 var what))) t) loop-body)))
+           (var (cl-loop-handle-accum nil :use-tailptr)))

+        (push (if (eq var loop-accum-var)
+                  (let ((func (if (memq word '(nconc noncing))
+                                  'identity 'copy-sequence)))
+
+                    ;; use tail pointer
+                    `(if ,var
+                         (setq ,loop-accum-tailptr
+                               (last (setcdr ,loop-accum-tailptr
+                                             (,func ,what))))
+                       (setq ,var (,func ,what))
+                       (setq ,loop-accum-tailptr (last ,var))))
+
+                ;; visible variable; no tail pointer
+                (let ((func
+                       (if (memq word '(nconc nconcing)) 'nconc append)))
+                  `(setq ,var (,func ,var ,what))))
+              loop-body)
+        (push t loop-body)))
+
      ((memq word '(concat concating))
       (let ((what (pop args))
            (var (cl-loop-handle-accum "")))
@@ -1144,20 +1167,36 @@
       (list* (if par 'let 'let*)
             (nconc (nreverse temps) (nreverse new)) body))))

-(defun cl-loop-handle-accum (def &optional func)   ; uses args, loop-*
-  (if (eq (car args) 'into)
-      (let ((var (cl-pop2 args)))
-       (or (memq var loop-accum-vars)
-           (progn (push (list (list var def)) loop-bindings)
-                  (push var loop-accum-vars)))
-       var)
-    (or loop-accum-var
-       (progn
-         (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) 
def))
-                  loop-bindings)
-         (setq loop-result (if func (list func loop-accum-var)
-                             loop-accum-var))
-         loop-accum-var))))
+(defun cl-loop-handle-accum (def &optional listp)   ; uses args, loop-*
+  (cond ((eq (car args) 'into) ; accumulate into visible variable
+         (let ((var (cl-pop2 args)))
+           (or (memq var loop-accum-vars)
+               (progn (push (list (list var def)) loop-bindings)
+                      (push var loop-accum-vars)))
+           var))
+
+        ;; Otherwise, if we've already configured our anonymous
+        ;; accumulation variable so just return it.
+        (loop-accum-var)
+
+        ;; We're accumulating a list, so in addition to setting up
+        ;; loop-accum-var, set up loop-accum-tailptr.
+        (listp
+         (push (list (list (setq loop-accum-var (make-symbol
"--cl-accum--")) def))
+               loop-bindings)
+         (push (list (list (setq loop-accum-tailptr
+                                 (make-symbol "--cl-tailptr--")) def))
+               loop-bindings)
+         (setq loop-result loop-accum-var)
+         loop-accum-var)
+
+        ;; We're accumulating something else.
+        (t
+         (push (list (list (setq loop-accum-var (make-symbol
"--cl-var--")) def))
+               loop-bindings)
+         (setq loop-result (if func (list func loop-accum-var)
+                             loop-accum-var))
+         loop-accum-var)))

 (defun cl-loop-build-ands (clauses)
   (let ((ands nil)

signature.asc
Description: OpenPGP digital signature