[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-81-g7352495

[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=735249513a0a2966f6570ee32cd2988b3bc6524d

The branch, stable-2.0 has been updated
       via  735249513a0a2966f6570ee32cd2988b3bc6524d (commit)
       via  61237fa4b96d020e96388cca4fd065ddf43bca60 (commit)
       via  1e8ace33d17a3156c184e8121eb291a7c9324ccc (commit)
      from  870dfc609b0bf090d38878d7224e65843c355485 (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 735249513a0a2966f6570ee32cd2988b3bc6524d
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 13 18:54:01 2011 +0200

    peval: Inline thunks.
    
    * module/language/tree-il/optimize.scm (peval): Inline thunks.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add test.

commit 61237fa4b96d020e96388cca4fd065ddf43bca60
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 13 18:25:09 2011 +0200

    peval: Use the right scope when replacing a lambda by a lexical-ref.
    
    * module/language/tree-il/optimize.scm (peval)[maybe-unlambda]: New
      procedures.
      Use it to de-duplicate named lambdas.  This fixes the scoping bug
      described at 
<https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add tests to
      reproduce the bug.

commit 1e8ace33d17a3156c184e8121eb291a7c9324ccc
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 13 14:31:18 2011 +0200

    peval: Add tests for inlining with both static & dynamic arguments.
    
    * module/language/tree-il/optimize.scm (peval): Improve comment on the
      inlining heuristics.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add two tests.

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

Summary of changes:
 module/language/tree-il/optimize.scm |   48 ++++++++++++++++----------
 test-suite/tests/tree-il.test        |   62 +++++++++++++++++++++++++++++++++-
 2 files changed, 90 insertions(+), 20 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 15b8ec0..5525784 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -174,6 +174,22 @@ it should be called before `fix-letrec'."
            (or (make-value-construction src value) orig)))
       (_ new)))
 
+  (define (maybe-unlambda orig new env)
+    ;; If NEW is a named lambda and ORIG is what it looked like before
+    ;; partial evaluation, then attempt to replace NEW with a lexical
+    ;; ref, to avoid code duplication.
+    (match new
+      (($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
+          ($ <lambda-case> _ req opt rest kw inits gensyms body))
+       ;; Look for NEW in the current environment, starting from the
+       ;; outermost frame.
+       (or (any (lambda (x)
+                  (and (equal? (cdr x) new)
+                       (make-lexical-ref src name (car x))))
+                (vlist-fold cons '() env))        ; todo: optimize
+           new))
+      (_ new)))
+
   (catch 'match-error
     (lambda ()
       (let loop ((exp   exp)
@@ -245,16 +261,20 @@ it should be called before `fix-letrec'."
                  (make-conditional src condition
                                    (loop subsequent env calls)
                                    (loop alternate env calls)))))
-          (($ <application> src proc* orig-args)
+          (($ <application> src orig-proc orig-args)
            ;; todo: augment the global env with specialized functions
-           (let* ((proc  (loop proc* env calls))
+           (let* ((proc  (loop orig-proc env calls))
+                  (proc* (maybe-unlambda orig-proc proc env))
                   (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.)
-             (if (and (any const*? args)
+                  (args* (map (cut maybe-unlambda <> <> env)
+                              orig-args
+                              (map maybe-unconst orig-args args)))
+                  (app   (make-application src proc* args*)))
+             ;; If at least one of ARGS is static (to avoid infinite
+             ;; inlining) and this call hasn't already been expanded
+             ;; before (to avoid infinite recursion), then expand it
+             ;; (todo: emit an infinite recursion warning.)
+             (if (and (or (null? args) (any const*? args))
                       (not (member (cons proc args) calls)))
                  (match proc
                    (($ <primitive-ref> _ (? effect-free-primitive? name))
@@ -293,17 +313,7 @@ it should be called before `fix-letrec'."
                    (($ <toplevel-ref>)
                     app))
 
-                 ;; There are no constant arguments, so don't substitute
-                 ;; lambdas---i.e., prefer (lexical f) over an inline
-                 ;; copy of `f'.
-                 (let ((proc (if (lambda? proc) proc* proc))
-                       (args (map (lambda (raw evaled)
-                                    (if (lambda? evaled)
-                                        raw
-                                        evaled))
-                                  orig-args
-                                  args)))
-                   (make-application src proc args)))))
+                 app)))
           (($ <lambda> src meta body)
            (make-lambda src meta (loop body env calls)))
           (($ <lambda-case> src req opt rest kw inits gensyms body alt)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index cffd3ac..1876d42 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -614,6 +614,13 @@
     (const 3))
 
   (pass-if-peval
+    ;; First order, thunk.
+    (let ((x 1) (y 2))
+      (let ((f (lambda () (+ x y))))
+        (f)))
+    (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)))
@@ -800,6 +807,28 @@
     (const 42))
 
   (pass-if-peval
+    ;; Higher order.
+    ((lambda (f) (f x)) (lambda (x) x))
+    (apply (lambda ()
+             (lambda-case
+              (((x) #f #f #f () (_))
+               (lexical x _))))
+           (toplevel x)))
+
+  (pass-if-peval
+    ;; Bug reported at
+    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+    (let ((fold (lambda (f g) (f (g top)))))
+      (fold 1+ (lambda (x) x)))
+    (let (fold) (_) (_)
+         (apply (primitive 1+)
+                (apply (lambda ()
+                         (lambda-case
+                          (((x) #f #f #f () (_))
+                           (lexical x _))))
+                       (toplevel top)))))
+
+  (pass-if-peval
     ;; Higher order, mutually recursive procedures.
     (letrec ((even? (lambda (x)
                       (or (= 0 x)
@@ -874,7 +903,7 @@
            (apply (primitive list) (const 1) (const 2) (const 3))))
 
   (pass-if-peval
-    ;; Procedure only called with non-constant args is not inlined.
+    ;; 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)))
@@ -944,6 +973,37 @@
            (lexical x _))))
 
   (pass-if-peval
+    ;; Inlining stops at recursive calls with dynamic arguments.
+    (let loop ((x x))
+      (if (< x 0) x (loop (1- x))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x) #f #f #f () (_))
+                            (if _ _
+                                (apply (lexical loop _)
+                                       (apply (primitive 1-)
+                                              (lexical x _))))))))
+            (apply (lexical loop _) (toplevel x))))
+
+  (pass-if-peval
+    ;; Inlining stops at recursive calls (mixed static/dynamic arguments).
+    (let loop ((x x) (y 0))
+      (if (> y 0)
+          (loop (1+ x) (1+ y))
+          (if (< x 0) x (loop (1- x)))))
+    (letrec (loop) (_) ((lambda (_)
+                          (lambda-case
+                           (((x y) #f #f #f () (_ _))
+                            (if (apply (primitive >)
+                                       (lexical y _) (const 0))
+                                _ _)))))
+            ;; call to (loop x 0) is inlined & specialized
+            (if (apply (primitive <) (toplevel x) (const 0))
+                (toplevel x)
+                (apply (lexical loop _)
+                       (apply (primitive 1-) (toplevel 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