master 7feb5b2da7 3/3: Optimise `append` calls

[Mattias Engdegård]

branch: master
commit 7feb5b2da7f369a8ab1fea81975989aa30cbb397
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Optimise `append` calls
    
    Add the transforms
    
      (append) -> nil
      (append X) -> X
      (append '(X) Y) -> (cons 'X Y)
      (append (list X) Y) -> (cons X Y)
      (append (list X...) nil) -> (list X...)
    
    and the argument transforms:
    
      (list X...) (list Y...) -> (list X... Y...)
      nil -> ;nothing
      CONST1 CONST2 -> CONST1++CONST2
      (list CONSTANTS...) -> '(CONSTANTS...)
    
    (the last three for non-tail arguments only)
    
    * lisp/emacs-lisp/byte-opt.el: New.
---
 lisp/emacs-lisp/byte-opt.el | 78 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 480b652342..ce73a5e91f 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1295,6 +1295,84 @@ See Info node `(elisp) Integer Basics'."
   ;; (list) -> nil
   (and (cdr form) form))
 
+(put 'append 'byte-optimizer #'byte-optimize-append)
+(defun byte-optimize-append (form)
+  ;; There is (probably) too much code relying on `append' to return a
+  ;; new list for us to do full constant-folding; these transformations
+  ;; preserve the allocation semantics.
+  (and (cdr form)                       ; (append) -> nil
+       (named-let loop ((args (cdr form)) (newargs nil))
+         (let ((arg (car args))
+               (prev (car newargs)))
+           (cond
+            ;; Flatten nested `append' forms.
+            ((and (consp arg) (eq (car arg) 'append))
+             (loop (append (cdr arg) (cdr args)) newargs))
+
+            ;; Merge consecutive `list' forms.
+            ((and (consp arg) (eq (car arg) 'list)
+                  newargs (consp prev) (eq (car prev) 'list))
+             (loop (cons (cons (car prev) (append (cdr prev) (cdr arg)))
+                         (cdr args))
+                   (cdr newargs)))
+
+            ;; non-terminal arg
+            ((cdr args)
+             (cond
+              ((macroexp-const-p arg)
+               ;; constant arg
+               (let ((val (eval arg)))
+                 (cond
+                  ;; Elide empty arguments (nil, empty string, etc).
+                  ((zerop (length val))
+                   (loop (cdr args) newargs))
+                  ;; Merge consecutive constants.
+                  ((and newargs (macroexp-const-p prev))
+                   (loop (cdr args)
+                         (cons
+                          (list 'quote
+                                (append (eval prev) val nil))
+                          (cdr newargs))))
+                  (t (loop (cdr args) (cons arg newargs))))))
+
+              ;; (list CONSTANTS...) -> '(CONSTANTS...)
+              ((and (consp arg) (eq (car arg) 'list)
+                    (not (memq nil (mapcar #'macroexp-const-p (cdr arg)))))
+               (loop (cons (list 'quote (eval arg)) (cdr args)) newargs))
+
+              (t (loop (cdr args) (cons arg newargs)))))
+
+            ;; At this point, `arg' is the last (tail) argument.
+
+            ;; (append X) -> X
+            ((null newargs) arg)
+
+            ;; (append (list Xs...) nil) -> (list Xs...)
+            ((and (null arg)
+                  newargs (null (cdr newargs))
+                  (consp prev) (eq (car prev) 'list))
+             prev)
+
+            ;; (append '(X) Y)     -> (cons 'X Y)
+            ;; (append (list X) Y) -> (cons X Y)
+            ((and newargs (null (cdr newargs))
+                  (consp prev)
+                  (cond ((eq (car prev) 'quote)
+                         (and (consp (cadr prev))
+                              (= (length (cadr prev)) 1)))
+                        ((eq (car prev) 'list)
+                         (= (length (cdr prev)) 1))))
+             (list 'cons (if (eq (car prev) 'quote)
+                             (macroexp-quote (caadr prev))
+                           (cadr prev))
+                   arg))
+
+            (t
+             (let ((new-form (cons 'append (nreverse (cons arg newargs)))))
+               (if (equal new-form form)
+                   form
+                 new-form))))))))
+
 ;; Fixme: delete-char -> delete-region (byte-coded)
 
 (put 'set 'byte-optimizer #'byte-optimize-set)