compiler: add list construction optimizations.

The raw size of the library compiled files shrinks by over 2%
from this optimization, not to mention that some list
construction code is faster.

* share/txr/stdlib/compiler.tl (compiler comp-fun-form):
Reduce common list construction primitives via reduce-lisp
function which algebraically transforms to a form with fewer
function calls.
(reduce-lisp): New function.

1 files changed, 35 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index fa209a4b..d406c6bc 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1159,12 +1159,18 @@
        ((or (eql-comparable a)
             (eql-comparable b))
         (set form ^(eql ,a ,b)))))
+    ((@(or append cons list list*) . @args)
+     (set form (reduce-lisp form)))
     ((@(@bin [%bin-op% @sym]) @a @b)
      (set form ^(,bin ,a ,b)))
     ((- @a)
      (set form ^(neg ,a)))
     ((@(or identity + * min max) @a)
      (return-from comp-fun-form me.(compile oreg env a))))
+
+  (when (or (atom form) (special-operator-p (car form)))
+    (return-from comp-fun-form me.(compile oreg env form)))
+
   (tree-bind (sym . args) form
     (let* ((fbind env.(lookup-fun sym t))
            (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
@@ -1457,6 +1463,35 @@
 (defun simplify-or (form)
   (reduce-or (flatten-or form)))
 
+(defun reduce-lisp (form)
+  (let (oform)
+    (while* (nequal oform form)
+      (set oform form
+           form (match-case form
+                  ((append (list . @largs) . @aargs)
+                   ^(list* ,*largs (append ,*aargs)))
+                  ((append @arg) arg)
+                  (@(require (list* . @(listp @args))
+                             (equal '(nil) (last args)))
+                    ^(list ,*(butlastn 1 args)))
+                  (@(with (list* . @(listp @args))
+                          ((@(and @op @(or list list*)) . @largs)) (last args))
+                    ^(,op ,*(butlast args) ,*largs))
+                  (@(with (list* . @(listp @args))
+                          ((append . @aargs)) (last args))
+                    ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs))))
+                  ((@(or append list list*)) nil)
+                  ((cons @a @b)
+                   (let* ((lstar ^(list* ,a ,b))
+                          (rstar (reduce-lisp lstar)))
+                     (if (eq lstar rstar) form rstar)))
+                  ((cons @a (cons @b @c))
+                   ^(list* ,a ,b ,c))
+                  ((cons @a (@(and @op @(or list list*)) . @args))
+                   ^(,op ,a ,*args))
+                  (@else else))))
+    form))
+
 (defun expand-quasi-mods (obj mods : form)
   (let (plist num sep rng-ix scalar-ix-p flex gens)
     (flet ((get-sym (exp)