local rewrite for apply to a let-bound rest list

* module/language/tree-il/peval.scm (peval): Add a special-case inlining
  pattern for apply to a let-bound rest arg that preserves effect
  ordering.

* test-suite/tests/peval.test ("partial evaluation"): Add a test, and
  update an older test with a better result.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 8955313..da3f4a8 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -437,6 +437,13 @@ top-level bindings from ENV and return the resulting expression."
              new))
          vars))
 
+  (define (fresh-temporaries ls)
+    (map (lambda (elt)
+           (let ((new (gensym "tmp ")))
+             (record-new-temporary! 'tmp new 1)
+             new))
+         ls))
+
   (define (assigned-lexical? sym)
     (var-set? (lookup-var sym)))
 
@@ -872,6 +879,31 @@ top-level bindings from ENV and return the resulting expression."
              (begin
                (record-operand-use op)
                (make-lexical-set src name (operand-sym op) (for-value exp))))))
+      (($ <let> src
+          (names ... rest)
+          (gensyms ... rest-sym)
+          (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
+          ($ <application> asrc
+             ($ <primitive-ref> _ (or 'apply '@apply))
+             (proc args ...
+                   ($ <lexical-ref> _
+                      (? (cut eq? <> rest))
+                      (? (lambda (sym)
+                           (and (eq? sym rest-sym)
+                                (= (lexical-refcount sym) 1))))))))
+       (let* ((tmps (make-list (length rest-args) 'tmp))
+              (tmp-syms (fresh-temporaries tmps)))
+         (for-tail
+          (make-let src
+                    (append names tmps)
+                    (append gensyms tmp-syms)
+                    (append vals rest-args)
+                    (make-application
+                     asrc
+                     proc
+                     (append args
+                             (map (cut make-lexical-ref #f <> <>)
+                                  tmps tmp-syms)))))))
       (($ <let> src names gensyms vals body)
        (define (compute-alias exp)
          ;; It's very common for macros to introduce something like:

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index da63344..923b0d1 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -940,15 +940,36 @@
          ;; The effects of `(foo!)' must be visible before this effect.
          z
          args)))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
+        (let (_) (_) ((apply (toplevel foo!)))
+             (let (z) (_) ((toplevel z))
+                  (apply (primitive 'list)
+                         (lexical z _)
+                         (lexical _ _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Rest args referenced more than once are not destructured.
+    (lambda ()
+      (let ((args (list 'foo)))
+        (set-car! args 'bar)
+        (@apply
+         (lambda (z x)
+           (list z x))
+         z
+         args)))
     (lambda ()
       (lambda-case
        ((() #f #f #f () ())
         (let (args) (_)
-             ((apply (primitive list) (apply (toplevel foo!))))
-             (apply (primitive @apply)
-                    (lambda . _)
-                    (toplevel z)
-                    (lexical args _)))))))
+             ((apply (primitive list) (const foo)))
+             (begin
+               (apply (primitive set-car!) (lexical args _) (const bar))
+               (apply (primitive @apply)
+                     (lambda . _)
+                     (toplevel z)
+                     (lexical args _))))))))
 
   (pass-if-peval resolve-primitives
     ;; Let-values inlining, even with consumers with rest args.