[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-78-g870dfc6

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=870dfc609b0bf090d38878d7224e65843c355485

The branch, stable-2.0 has been updated
       via  870dfc609b0bf090d38878d7224e65843c355485 (commit)
       via  89436781e8758ee4df98f5d720f3ade50c2439fa (commit)
       via  d5f76917820a00ea94f9904c3fd1dcef1c37bd95 (commit)
      from  fe1336405062c69ff08fd7ad0d98c3f2aca7766f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 870dfc609b0bf090d38878d7224e65843c355485
Author: Ludovic Courtès <address@hidden>
Date:   Sun Sep 11 00:41:23 2011 +0200

    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.

commit 89436781e8758ee4df98f5d720f3ade50c2439fa
Author: Ludovic Courtès <address@hidden>
Date:   Sun Sep 11 00:00:39 2011 +0200

    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.

commit d5f76917820a00ea94f9904c3fd1dcef1c37bd95
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 10 15:31:55 2011 +0200

    doc: Fix typo regarding vhashes.
    
    * doc/ref/api-compound.texi (VHashes): s/vlist-/alist-/.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/api-compound.texi            |    2 +-
 module/language/tree-il/optimize.scm |  102 ++++++++++++++++++++++++++--------
 test-suite/tests/tree-il.test        |   99 +++++++++++++++++++++++++++++++++
 3 files changed, 178 insertions(+), 25 deletions(-)

diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index da8813b..c52fed4 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -3207,7 +3207,7 @@ key is typically a constant-time operation.
 
 The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
 that of association lists found in SRFI-1, with procedure names prefixed by
address@hidden instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
address@hidden instead of @code{alist-} (@pxref{SRFI-1 Association Lists}).
 
 In addition, vhashes can be manipulated using VList operations:
 
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 35b1aec..15b8ec0 100644
--- 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)
@@ -190,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.)
@@ -207,11 +263,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>)
@@ -224,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
@@ -247,14 +301,14 @@ 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)
            (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..cffd3ac 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -614,6 +614,50 @@
     (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)))))
+
+  (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.
+    (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)
     (const 2))
@@ -783,6 +827,18 @@
                     (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)))
            (y (* x 2)))
@@ -795,6 +851,29 @@
                      (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)))
            (f (lambda (g x) (g x x))))
@@ -814,6 +893,16 @@
                      (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))
       (set! x 3)
@@ -845,6 +934,16 @@
     (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))))
              (g (lambda (x) (h (1+ x))))


hooks/post-receive
-- 
GNU Guile