peval: Propagate only pure expressions to lambdas.

* module/language/tree-il/optimize.scm (peval): Propagate ARGS to BODY
  only when all of ARGS are pure.  Change APP to use `maybe-unconst' for
  its arguments.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests for
  mutability preservation and non-propagation of non-constant arguments
  to lambdas.

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 95b00fa..15b8ec0 100644 (file)
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -245,11 +245,12 @@ it should be called before `fix-letrec'."
                  (make-conditional src condition
                                    (loop subsequent env calls)
                                    (loop alternate env calls)))))
-          (($ <application> src proc* args*)
+          (($ <application> src proc* orig-args)
            ;; todo: augment the global env with specialized functions
-           (let* ((proc (loop proc* env calls))
-                  (args (map (cut loop <> env calls) args*))
-                  (app  (make-application src proc args)))
+           (let* ((proc  (loop proc* env calls))
+                  (args  (map (cut loop <> env calls) orig-args))
+                  (args* (map maybe-unconst orig-args args))
+                  (app   (make-application src proc args*)))
              ;; If ARGS are constants and this call hasn't already been
              ;; expanded before (to avoid infinite recursion), then
              ;; expand it (todo: emit an infinite recursion warning.)
@@ -276,7 +277,8 @@ it should be called before `fix-letrec'."
                     (let ((nargs  (length args))
                           (nreq   (length req))
                           (nopt   (if opt (length opt) 0)))
-                      (if (and (>= nargs nreq) (<= nargs (+ nreq nopt)))
+                      (if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
+                               (every pure-expression? args))
                           (loop body
                                 (fold vhash-consq env gensyms
                                       (append args
@@ -299,7 +301,7 @@ it should be called before `fix-letrec'."
                                     (if (lambda? evaled)
                                         raw
                                         evaled))
-                                  args*
+                                  orig-args
                                   args)))
                    (make-application src proc args)))))
           (($ <lambda> src meta body)

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 630ef88..cffd3ac 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -640,11 +640,12 @@
              (apply (primitive cons) (const 2) (const 2))
              (apply (primitive cons) (const 3) (const 3)))))
 
-  ;; FIXME: The test below fails.
-  ;; (pass-if-peval
-  ;;   ;; Mutability preserved.
-  ;;   ((lambda (x y z) (list x y z)) 1 2 3)
-  ;;   (apply (primitive list) (const 1) (const 2) (const 3)))
+  (pass-if-peval
+    ;; Mutability preserved.
+    (define mutable
+      ((lambda (x y z) (list x y z)) 1 2 3))
+    (define mutable
+      (apply (primitive list) (const 1) (const 2) (const 3))))
 
   (pass-if-peval
     ;; First order, evaluated.
@@ -849,6 +850,29 @@
               (apply (primitive +) (lexical x _) (lexical x _)
                      (apply (primitive *) (lexical x _) (const 2))))))
 
+  (pass-if-peval
+    ;; Non-constant arguments not propagated to lambdas.
+    ((lambda (x y z)
+       (vector-set! x 0 0)
+       (set-car! y 0)
+       (set-cdr! z '()))
+     (vector 1 2 3)
+     (make-list 10)
+     (list 1 2 3))
+    (apply (lambda ()
+             (lambda-case
+              (((x y z) #f #f #f () (_ _ _))
+               (begin
+                 (apply (toplevel vector-set!)
+                        (lexical x _) (const 0) (const 0))
+                 (apply (toplevel set-car!)
+                        (lexical y _) (const 0))
+                 (apply (toplevel set-cdr!)
+                        (lexical z _) (const ()))))))
+           (apply (primitive vector) (const 1) (const 2) (const 3))
+           (apply (toplevel make-list) (const 10))
+           (apply (primitive list) (const 1) (const 2) (const 3))))
+
   (pass-if-peval
     ;; Procedure only called with non-constant args is not inlined.
     (let* ((g (lambda (x y) (+ x y)))