compiler: inline-lambda: optimize constant apply list.

* share/txr/stdlib/compiler.tl (comp-inline-lambda): Pass nil
to new argument of lambda-apply-transform, indicating
top-level call.
(lambda-apply-transform): Takes new argument indicating
whether it's a recursive call. If the apply list expression is
constant, then it is evaluated and treated as a list of
arguments which are then turned into quoted constants
individually and passed as fixed args in a recursive call.
This eliminates the generation of code dealing with run-time
evaluation and destructuring of the apply arguments.

1 files changed, 75 insertions, 65 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index ba7ffb68..5d7a9daa 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1070,7 +1070,8 @@
            apply-list-arg (car (last args))))
     me.(compile oreg env (expand (lambda-apply-transform lambda
                                                          reg-args
-                                                         apply-list-arg)))))
+                                                         apply-list-arg
+                                                         nil)))))
 
 (defmeth compiler comp-for (me oreg env form)
   (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form
@@ -1497,70 +1498,79 @@
   (mac-param-bind form (op name def) form
     ^(sys:rt-defsymacro ',name ',def)))
 
-(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr)
-  (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr
-    (let* ((pars (new (fun-param-parser lm-args lm-expr)))
-           (fix-vals (mapcar (ret (gensym)) fix-arg-exprs))
-           (ign-sym (gensym))
-           (al-val (gensym))
-           (shadow-p (let ((all-vars (append pars.req pars.(opt-syms)
-                                             (if pars.rest (list pars.rest)))))
-                       (or (isec all-vars fix-arg-exprs)
-                           (member apply-list-expr all-vars)))))
-      ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs)
-         (let* ,(build
-                  (if apply-list-expr
-                    (add ^(,al-val ,apply-list-expr)))
-                  (while (and fix-vals pars.req)
-                    (add ^(,(pop pars.req) ,(pop fix-vals))))
-                  (while (and fix-vals pars.opt)
-                    (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
-                      (add ^(,var-sym ,(pop fix-vals)))
-                      (if have-sym
-                        (add ^(,have-sym t)))))
-                  (cond
-                    ((and (null pars.req)
-                          (null pars.opt))
-                     (if fix-vals
-                       (if pars.rest
-                         (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr)))
-                         (lambda-too-many-args lm-expr))
-                       (when (or pars.rest apply-list-expr)
-                         (add ^(,(or pars.rest ign-sym) ,apply-list-expr)))))
-                    ((and fix-vals apply-list-expr)
-                     (lambda-too-many-args lm-expr))
-                    (apply-list-expr
-                      (when pars.req
-                        (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req))
-                                          (lambda-short-apply-list)))))
-                      (while pars.req
-                        (add ^(,(pop pars.req) (pop ,al-val))))
-                      (while pars.opt
-                        (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
-                          (cond
-                            (have-sym
-                              (add ^(,var-sym (if ,al-val
-                                                (car ,al-val)
-                                                ,init-form)))
-                              (add ^(,have-sym (when ,al-val
-                                                 (pop ,al-val)
-                                                 t))))
-                            (t (add ^(,var-sym (if ,al-val
-                                                 (pop ,al-val)
-                                                 ,init-form)))))))
-                      (when pars.rest
-                        (add ^(,pars.rest ,al-val))))
-                    (pars.req
-                      (lambda-too-few-args lm-expr))
-                    (pars.opt
-                      (while pars.opt
-                        (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
-                          (add ^(,var-sym ,init-form))
-                          (if have-sym
-                            (add ^(,have-sym)))))
-                      (when pars.rest
-                        (add ^(,pars.rest))))))
-           ,*lm-body)))))
+(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed)
+  (if (and (not recursed)
+           apply-list-expr
+           (constantp apply-list-expr))
+    (let* ((apply-list-val (eval apply-list-expr))
+           (apply-atom (nthlast 0 apply-list-val))
+           (apply-fixed (butlastn 0 apply-list-val)))
+      (lambda-apply-transform lm-expr (append fix-arg-exprs
+                                              (mapcar (ret ^',@1) apply-fixed))
+                              ^',apply-atom t))
+    (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr
+      (let* ((pars (new (fun-param-parser lm-args lm-expr)))
+             (fix-vals (mapcar (ret (gensym)) fix-arg-exprs))
+             (ign-sym (gensym))
+             (al-val (gensym))
+             (shadow-p (let ((all-vars (append pars.req pars.(opt-syms)
+                                               (if pars.rest (list pars.rest)))))
+                         (or (isec all-vars fix-arg-exprs)
+                             (member apply-list-expr all-vars)))))
+        ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs)
+           (let* ,(build
+                    (if apply-list-expr
+                      (add ^(,al-val ,apply-list-expr)))
+                    (while (and fix-vals pars.req)
+                      (add ^(,(pop pars.req) ,(pop fix-vals))))
+                    (while (and fix-vals pars.opt)
+                      (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+                        (add ^(,var-sym ,(pop fix-vals)))
+                        (if have-sym
+                          (add ^(,have-sym t)))))
+                    (cond
+                      ((and (null pars.req)
+                            (null pars.opt))
+                       (if fix-vals
+                         (if pars.rest
+                           (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr)))
+                           (lambda-too-many-args lm-expr))
+                         (when (or pars.rest apply-list-expr)
+                           (add ^(,(or pars.rest ign-sym) ,apply-list-expr)))))
+                      ((and fix-vals apply-list-expr)
+                       (lambda-too-many-args lm-expr))
+                      (apply-list-expr
+                        (when pars.req
+                          (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req))
+                                            (lambda-short-apply-list)))))
+                        (while pars.req
+                          (add ^(,(pop pars.req) (pop ,al-val))))
+                        (while pars.opt
+                          (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+                            (cond
+                              (have-sym
+                                (add ^(,var-sym (if ,al-val
+                                                  (car ,al-val)
+                                                  ,init-form)))
+                                (add ^(,have-sym (when ,al-val
+                                                   (pop ,al-val)
+                                                   t))))
+                              (t (add ^(,var-sym (if ,al-val
+                                                   (pop ,al-val)
+                                                   ,init-form)))))))
+                        (when pars.rest
+                          (add ^(,pars.rest ,al-val))))
+                      (pars.req
+                        (lambda-too-few-args lm-expr))
+                      (pars.opt
+                        (while pars.opt
+                          (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+                            (add ^(,var-sym ,init-form))
+                            (if have-sym
+                              (add ^(,have-sym)))))
+                        (when pars.rest
+                          (add ^(,pars.rest))))))
+             ,*lm-body))))))
 
 (defun system-symbol-p (sym)
   (member (symbol-package sym)