From 3d2bcd2c350384ffaf96b79fa6096c9d77ea113e Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 5 Jul 2012 20:30:18 +0200
Subject: [PATCH] optimize (apply foo 0 (list 1 2)) => (foo 0 1 2)

* module/language/tree-il/peval.scm (peval): Inline applications where
  we know the contents of the tail.

* test-suite/tests/peval.test ("partial evaluation"): Add tests.
---
 module/language/tree-il/peval.scm | 11 +++++++++++
 test-suite/tests/peval.test       | 10 +++++++++-
 2 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 15c7164aa..16485e812 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1094,6 +1094,17 @@ top-level bindings from ENV and return the resulting expression."
                     (every singly-valued-expression? vals))
                (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
                (make-application src (make-primitive-ref #f 'values) vals))))))
+      (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
+          (proc args ... tail))
+       (match (for-value tail)
+         (($ <const> _ (args* ...))
+          (let ((args* (map (lambda (x) (make-const #f x)) args*)))
+            (for-tail (make-application src proc (append args args*)))))
+         (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+          (for-tail (make-application src proc (append args args*))))
+         (tail
+          (let ((args (append (map for-value args) (list tail))))
+            (make-application src apply (cons (for-value proc) args))))))
       (($ <application> src orig-proc orig-args)
        ;; todo: augment the global env with specialized functions
        (let ((proc (visit orig-proc 'operator)))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index aefb2e04e..1f641d93c 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1055,4 +1055,12 @@
                              (apply (toplevel baz) (toplevel x))
                              (apply (lexical failure _)))))
                  (apply (lexical failure _)))
-             (apply (lexical failure _))))))
+             (apply (lexical failure _)))))
+
+  (pass-if-peval resolve-primitives
+    (apply (lambda (x y) (cons x y)) '(1 2))
+    (apply (primitive cons) (const 1) (const 2)))
+
+  (pass-if-peval resolve-primitives
+    (apply (lambda (x y) (cons x y)) (list 1 2))
+    (apply (primitive cons) (const 1) (const 2))))
-- 
2.20.1