peval: Try hard to preserve mutability.

* module/language/tree-il/optimize.scm (peval)[make-values]: Distinguish
  between 1 or another number of values.
  [mutable?, make-value-construction, maybe-unconst]: New procedures.
  Use it in <let>, <letrec>, <toplevel-define>, and <lambda-case>.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests
  for mutability preservation.

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 35b1aec..95b00fa 100644 (file)
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -88,8 +88,11 @@ it should be called before `fix-letrec'."
         (values #f '()))))
 
   (define (make-values src values)
-    (make-application src (make-primitive-ref src 'values)
-                      (map (cut make-const src <>) values)))
+    (match values
+      ((single) single)                           ; 1 value
+      ((_ ...)                                    ; 0, or 2 or more values
+       (make-application src (make-primitive-ref src 'values)
+                         values))))
 
   (define (const*? x)
     (or (const? x) (lambda? x) (void? x)))
@@ -124,6 +127,53 @@ it should be called before `fix-letrec'."
          (and (every loop vals) (loop body)))
         (_ #f))))
 
+  (define (mutable? exp)
+    ;; Return #t if EXP is a mutable object.
+    ;; todo: add an option to assume pairs are immutable
+    (or (pair? exp)
+        (vector? exp)
+        (struct? exp)
+        (string? exp)))
+
+  (define (make-value-construction src exp)
+    ;; Return an expression that builds a fresh copy of EXP at run-time,
+    ;; or #f.
+    (let loop ((exp exp))
+      (match exp
+        ((_ _ ...)                                 ; non-empty proper list
+         (let ((args (map loop exp)))
+           (and (every struct? args)
+                (make-application src (make-primitive-ref src 'list)
+                                  args))))
+        ((h . (? (negate pair?) t))                ; simple pair
+         (let ((h (loop h))
+               (t (loop t)))
+           (and h t
+                (make-application src (make-primitive-ref src 'cons)
+                                  (list h t)))))
+        ((? vector?)                               ; vector
+         (let ((args (map loop (vector->list exp))))
+           (and (every struct? args)
+                (make-application src (make-primitive-ref src 'vector)
+                                  args))))
+        ((? number?) (make-const src exp))
+        ((? string?) (make-const src exp))
+        ((? symbol?) (make-const src exp))
+        ;((? bytevector?) (make-const src exp))
+        (_ #f))))
+
+  (define (maybe-unconst orig new)
+    ;; If NEW is a constant, change it to a non-constant if need be.
+    ;; Expressions that build a mutable object, such as `(list 1 2)',
+    ;; must not be replaced by a constant; this procedure "undoes" the
+    ;; change from `(list 1 2)' to `'(1 2)'.
+    (match new
+      (($ <const> src (? mutable? value))
+       (if (equal? new orig)
+           new
+           (or (make-value-construction src value) orig)))
+      (_ new)))
+
   (catch 'match-error
     (lambda ()
       (let loop ((exp   exp)
@@ -142,11 +192,13 @@ it should be called before `fix-letrec'."
            (let ((val (lookup gensym)))
              (or (and (pure-expression? val) val) exp)))
           (($ <let> src names gensyms vals body)
-           (let* ((vals (map (cut loop <> env calls) vals))
-                  (body (loop body
-                              (fold vhash-consq env gensyms vals)
-                              calls)))
-             (if (const? body)
+           (let* ((vals* (map (cut loop <> env calls) vals))
+                  (vals  (map maybe-unconst vals vals*))
+                  (body* (loop body
+                               (fold vhash-consq env gensyms vals)
+                               calls))
+                  (body  (maybe-unconst body body*)))
+             (if (const? body*)
                  body
                  (let*-values (((stripped) (remove (compose const? car)
                                                    (zip vals gensyms names)))
@@ -158,11 +210,13 @@ it should be called before `fix-letrec'."
            ;; Things could be done more precisely when IN-ORDER? but
            ;; it's OK not to do it---at worst we lost an optimization
            ;; opportunity.
-           (let* ((vals (map (cut loop <> env calls) vals))
-                  (body (loop body
+           (let* ((vals* (map (cut loop <> env calls) vals))
+                  (vals  (map maybe-unconst vals vals*))
+                  (body* (loop body
                               (fold vhash-consq env gensyms vals)
-                              calls)))
-             (if (const? body)
+                              calls))
+                  (body  (maybe-unconst body body*)))
+             (if (const? body*)
                  body
                  (make-letrec src in-order? names gensyms vals body))))
           (($ <toplevel-ref> src (? effect-free-primitive? name))
@@ -177,7 +231,8 @@ it should be called before `fix-letrec'."
           (($ <module-ref>)
            exp)
           (($ <toplevel-define> src name exp)
-           (make-toplevel-define src name (loop exp env '())))
+           (make-toplevel-define src name
+                                 (maybe-unconst exp (loop exp env '()))))
           (($ <primitive-ref>)
            exp)
           (($ <conditional> src condition subsequent alternate)
@@ -207,11 +262,8 @@ it should be called before `fix-letrec'."
                                       (apply-primitive name
                                                        (map const-exp args))))
                           (if success?
-                              (match values
-                                ((value)
-                                 (make-const src value))
-                                (_
-                                 (make-values src values)))
+                              (make-values src (map (cut make-const src <>)
+                                                    values))
                               app))
                         app))
                    (($ <primitive-ref>)
@@ -254,7 +306,7 @@ it should be called before `fix-letrec'."
            (make-lambda src meta (loop body env calls)))
           (($ <lambda-case> src req opt rest kw inits gensyms body alt)
            (make-lambda-case src req opt rest kw inits gensyms
-                             (loop body env calls)
+                             (maybe-unconst body (loop body env calls))
                              alt))
           (($ <sequence> src exps)
            (let ((exps (map (cut loop <> env calls) exps)))

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ab42215..630ef88 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -613,6 +613,49 @@
     (let ((x 1) (y 2)) (+ x y))
     (const 3))
 
+  (pass-if-peval
+    ;; First order, coalesced.
+    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+    (const (0 1 2 3 4 5)))
+
+  (pass-if-peval
+    ;; First order, coalesced, mutability preserved.
+    (define mutable
+      (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
+    (define mutable
+      ;; This must not be a constant.
+      (apply (primitive list)
+             (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
+
+  (pass-if-peval
+    ;; First order, mutability preserved.
+    (define mutable
+      (let loop ((i 3) (r '()))
+        (if (zero? i)
+            r
+            (loop (1- i) (cons (cons i i) r)))))
+    (define mutable
+      (apply (primitive list)
+             (apply (primitive cons) (const 1) (const 1))
+             (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
+    ;; First order, evaluated.
+    (define one
+      (let loop ((i 7)
+                 (r '()))
+        (if (<= i 0)
+            (car r)
+            (loop (1- i) (cons i r)))))
+    (define one (const 1)))
+
   (pass-if-peval
     ;; First order, aliased primitive.
     (let* ((x *) (y (x 1 2))) y)
@@ -782,6 +825,18 @@
              (apply (toplevel vector-set!)
                     (lexical v _) (lexical n _) (lexical n _)))))))
 
+  (pass-if-peval
+    ;; Mutable lexical is not propagated.
+    (let ((v (vector 1 2 3)))
+      (lambda ()
+        v))
+    (let (v) (_)
+         ((apply (primitive vector) (const 1) (const 2) (const 3)))
+         (lambda ()
+           (lambda-case
+            ((() #f #f #f () ())
+             (lexical v _))))))
+
   (pass-if-peval
     ;; Lexical that is not provably pure is not inlined nor propagated.
     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
@@ -813,6 +868,16 @@
                      (apply (lexical g _) (toplevel foo) (toplevel foo))
                      (apply (lexical g _) (toplevel bar) (toplevel bar))))))
 
+  (pass-if-peval
+    ;; Fresh objects are not turned into constants.
+    (let* ((c '(2 3))
+           (x (cons 1 c))
+           (y (cons 0 x)))
+      y)
+    (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
+         (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
+              (lexical y _))))
+
   (pass-if-peval
     ;; Bindings mutated.
     (let ((x 2))
@@ -844,6 +909,16 @@
       (f 2))
     (letrec _ . _))
 
+  (pass-if-peval
+    ;; Bindings possibly mutated.
+    (let ((x (make-foo)))
+      (frob! x) ; may mutate `x'
+      x)
+    (let (x) (_) ((apply (toplevel make-foo)))
+         (begin
+           (apply (toplevel frob!) (lexical x _))
+           (lexical x _))))
+
   (pass-if-peval
     ;; Infinite recursion: `peval' gives up and leaves it as is.
     (letrec ((f (lambda (x) (g (1- x))))