[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-111-g1eb4886

[Andy Wingo]

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=1eb4886ffa9c4c81c946af7fed8fb39020fcde12

The branch, stable-2.0 has been updated
       via  1eb4886ffa9c4c81c946af7fed8fb39020fcde12 (commit)
      from  8d06538e821c3e6cdd4861e1d8b1ec25ed930453 (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 1eb4886ffa9c4c81c946af7fed8fb39020fcde12
Author: Andy Wingo <address@hidden>
Date:   Sat Sep 24 18:57:59 2011 +0200

    peval: don't propagate expressions that access memory
    
    * module/language/tree-il/optimize.scm (peval): Rename
      `pure-expression?' to `constant-expression?', in the sense of GCC's
      `pure' and `const'.  A <toplevel-ref> is not constant, because it can
      be mutated.  A <dynref> isn't constant either, for the same reason.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add a test, and
      update existing tests that assumed that toplevel-ref would propagate.

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

Summary of changes:
 module/language/tree-il/optimize.scm |   15 ++--
 test-suite/tests/tree-il.test        |  142 ++++++++++++++++++---------------
 2 files changed, 83 insertions(+), 74 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 8d626ea..b96e801 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -318,11 +318,10 @@ it does not handle <fix> and <let-values>, it should be 
called before
   (define (const*? x)
     (or (const? x) (lambda? x) (void? x)))
 
-  (define (pure-expression? x)
-    ;; Return true if X is pure---i.e., if it is known to have no
-    ;; effects and does not allocate storage for a mutable object.
-    ;; Note: <module-ref> is not "pure" because it loads a module as a
-    ;; side-effect.
+  (define (constant-expression? x)
+    ;; Return true if X is constant---i.e., if it is known to have no
+    ;; effects, does not allocate storage for a mutable object, and does
+    ;; not access mutable data (like `car' or toplevel references).
     (let loop ((x x))
       (match x
         (($ <void>) #t)
@@ -331,9 +330,7 @@ it does not handle <fix> and <let-values>, it should be 
called before
         (($ <lambda-case> _ req opt rest kw inits _ body alternate)
          (and (every loop inits) (loop body) (loop alternate)))
         (($ <lexical-ref>) #t)
-        (($ <toplevel-ref>) #t)
         (($ <primitive-ref>) #t)
-        (($ <dynref> _ fluid) (loop fluid))
         (($ <conditional> _ condition subsequent alternate)
          (and (loop condition) (loop subsequent) (loop alternate)))
         (($ <application> _ ($ <primitive-ref> _ name) args)
@@ -447,7 +444,7 @@ it does not handle <fix> and <let-values>, it should be 
called before
              ((effect) (make-void #f))
              (else
               (let ((val (lookup gensym)))
-                (if (pure-expression? val)
+                (if (constant-expression? val)
                     (case ctx
                       ;; fixme: cache this?  it is a divergence from
                       ;; O(n).
@@ -616,7 +613,7 @@ it does not handle <fix> and <let-values>, it should be 
called before
                           (nreq   (length req))
                           (nopt   (if opt (length opt) 0)))
                       (if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
-                               (every pure-expression? args))
+                               (every constant-expression? args))
                           (let* ((params
                                   (append args
                                           (drop inits
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index b641883..3040d74 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -776,16 +776,23 @@
                                      (const 2)
                                      (toplevel top))
                               (const 3)))
-                (apply (primitive +)              ; (f something 2)
-                       (apply (primitive *)
-                              (toplevel something)
-                              (toplevel top))
+                (apply (lexical f _)    ; (f something 2)
+                       ;; This arg is not const, so the lambda does not
+                       ;; fold.  We will fix this in the future when we
+                       ;; inline lambda to `let'.  That will offer the
+                       ;; possibility of creating a lexical binding for
+                       ;; `something', to preserve the order of effects.
+                       (toplevel something)
                        (const 2)))))
 
   (pass-if-peval
     ;; First order, with lambda inlined & specialized 3 times.
     (let ((f (lambda (x y) (if (> x 0) y x))))
-      (+ (f -1 x) (f 2 y) (f z y)))
+      (+ (f -1 0)
+         (f 1 0)
+         (f -1 y)
+         (f 2 y)
+         (f z y)))
     (let (f) (_)
          ((lambda (_)
             (lambda-case
@@ -794,8 +801,12 @@
                   (lexical y _)
                   (lexical x _))))))
          (apply (primitive +)
-                (const -1)                        ; (f -1 x)
-                (toplevel y)                      ; (f 2 y)
+                (const -1)                        ; (f -1 0)
+                (const 0)                         ; (f 1 0)
+                (apply (lexical f _)              ; (f -1 y)
+                       (const -1) (toplevel y))
+                (apply (lexical f _)              ; (f 2 y)
+                       (const 2) (toplevel y))
                 (apply (lexical f _)              ; (f z y)
                        (toplevel z) (toplevel y)))))
 
@@ -822,6 +833,17 @@
     (const 13))
 
   (pass-if-peval
+   ;; Don't propagate toplevel references, as intervening expressions
+   ;; could alter their bindings.
+   (let ((x top))
+     (foo)
+     x)
+   (let (x) (_) ((toplevel top))
+        (begin
+          (apply (toplevel foo))
+          (lexical x _))))
+
+  (pass-if-peval
     ;; Higher order.
     ((lambda (f x)
        (f (* (car x) (cadr x))))
@@ -895,49 +917,35 @@
                        (apply (primitive -) (lexical x2 _) (const 1))))))))
 
   (pass-if "inlined lambdas are alpha-renamed"
-    ;; In this example, the two anonymous lambdas are inlined more than
-    ;; once; thus, they should use different gensyms for their
-    ;; arguments, because the variable allocation process assumes
-    ;; globally unique gensyms.
+    ;; In this example, `make-adder' is inlined more than once; thus,
+    ;; they should use different gensyms for their arguments, because
+    ;; the various optimization passes assume uniquely-named variables.
     ;;
     ;; Bug reported at
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
     (pmatch (unparse-tree-il
              (peval (compile
-                     '(let ((f (lambda (g x)
-                                 (+ (g x) (g (+ x 1))))))
-                        (f (lambda (x0) (* x0 x0)) y))
+                     '(let ((make-adder
+                             (lambda (x) (lambda (y) (+ x y)))))
+                        (cons (make-adder 1) (make-adder 2)))
                      #:to 'tree-il)))
-      ((let (f) (_)
-            ((lambda ((name . f))
-               (lambda-case
-                (((g x) #f #f #f () (_ _))
-                 (apply (primitive +)
-                        (apply (lexical g _) (lexical x _))
-                        (apply (lexical g _)
-                               (apply (primitive +)
-                                      (lexical x _) (const 1))))))))
-            (apply (primitive +)
-                   (apply (lambda ()
-                            (lambda-case
-                             (((x0) #f #f #f () (,gensym1))
-                              (apply (primitive *)
-                                     (lexical x0 ,ref1a)
-                                     (lexical x0 ,ref1b)))))
-                          (toplevel y))
-                   (apply (lambda ()
-                            (lambda-case
-                             (((x0) #f #f #f () (,gensym2))
-                              (apply (primitive *)
-                                     (lexical x0 ,ref2a)
-                                     (lexical x0 ,ref2b)))))
-                          (apply (primitive +)
-                                 (toplevel y) (const 1)))))
-       (and (eq? gensym1 ref1a)
-            (eq? gensym1 ref1b)
-            (eq? gensym2 ref2a)
-            (eq? gensym2 ref2b)
+      ((let (make-adder) (_) (_)
+            (apply (primitive cons)
+                   (lambda ()
+                     (lambda-case
+                      (((y) #f #f #f () (,gensym1))
+                       (apply (primitive +)
+                              (const 1)
+                              (lexical y ,ref1)))))
+                   (lambda ()
+                     (lambda-case
+                      (((y) #f #f #f () (,gensym2))
+                       (apply (primitive +)
+                              (const 2)
+                              (lexical y ,ref2)))))))
+       (and (eq? gensym1 ref1)
+            (eq? gensym2 ref2)
             (not (eq? gensym1 gensym2))))
       (_ #f)))
 
@@ -1017,22 +1025,24 @@
 
   (pass-if-peval
     ;; Procedure only called with dynamic args is not inlined.
-    (let* ((g (lambda (x y) (+ x y)))
-           (f (lambda (g x) (g x x))))
-      (+ (f g foo) (f g bar)))
-    (let (g) (_)
-         ((lambda _                              ; g
-             (lambda-case
-              (((x y) #f #f #f () (_ _))
-               (apply (primitive +) (lexical x _) (lexical y _))))))
-         (let (f) (_)
-              ((lambda _                         ; f
-                 (lambda-case
-                  (((g x) #f #f #f () (_ _))
-                   (apply (lexical g _) (lexical x _) (lexical x _))))))
-              (apply (primitive +)
-                     (apply (lexical g _) (toplevel foo) (toplevel foo))
-                     (apply (lexical g _) (toplevel bar) (toplevel bar))))))
+   (let ((foo top-foo) (bar top-bar))
+     (let* ((g (lambda (x y) (+ x y)))
+            (f (lambda (g x) (g x x))))
+       (+ (f g foo) (f g bar))))
+   (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
+        (let (g) (_)
+             ((lambda _                 ; g
+                (lambda-case
+                 (((x y) #f #f #f () (_ _))
+                  (apply (primitive +) (lexical x _) (lexical y _))))))
+             (let (f) (_)
+                  ((lambda _            ; f
+                     (lambda-case
+                      (((g x) #f #f #f () (_ _))
+                       (apply (lexical g _) (lexical x _) (lexical x _))))))
+                  (apply (primitive +)
+                         (apply (lexical g _) (lexical foo _) (lexical foo _))
+                         (apply (lexical g _) (lexical bar _) (lexical bar 
_)))))))
 
   (pass-if-peval
     ;; Fresh objects are not turned into constants.
@@ -1100,12 +1110,14 @@
 
   (pass-if-peval
     ;; Recursion on the 2nd argument is fully evaluated.
-    (let loop ((x x) (y 10))
-      (if (> y 0)
-          (loop x (1- y))
-          (foo x y)))
-    (letrec (loop) (_) (_)
-            (apply (toplevel foo) (toplevel x) (const 0))))
+    (let ((x (top)))
+      (let loop ((x x) (y 10))
+        (if (> y 0)
+            (loop x (1- y))
+            (foo x y))))
+    (let (x) (_) ((apply (toplevel top)))
+         (letrec (loop) (_) (_)
+                 (apply (toplevel foo) (lexical x _) (const 0)))))
 
   (pass-if-peval
     ;; Inlining aborted when residual code contains recursive calls.


hooks/post-receive
-- 
GNU Guile