From c98679670ad541017aaaa98a5cfe4c36116f71c7 Mon Sep 17 00:00:00 2001 From: Tianxiang Xiong 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