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.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 15c7164..16485e8 100644 (file)
--- 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 aefb2e0..1f641d9 100644 (file)
--- 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))))