[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-84-g2ae0775

[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=2ae0775e405de414e2da4806588b674c07793b8e

The branch, stable-2.0 has been updated
       via  2ae0775e405de414e2da4806588b674c07793b8e (commit)
      from  3f2d6efc7b61999a4522b1c35d6f4a875a2c74c0 (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 2ae0775e405de414e2da4806588b674c07793b8e
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 17 16:49:41 2011 +0200

    peval: Alpha-rename anonymous lambdas that are duplicated.
    
    * module/language/tree-il/optimize.scm (alpha-rename): New procedure.
      (peval)[maybe-unlambda]: Use it.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add two test
      cases for 
<https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.

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

Summary of changes:
 module/language/tree-il/optimize.scm |   71 ++++++++++++++++++++++++++++++++++
 test-suite/tests/tree-il.test        |   58 +++++++++++++++++++++++++++
 2 files changed, 129 insertions(+), 0 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 86f1f2f..cb7bdf6 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -41,6 +41,70 @@
      (peval (expand-primitives! (resolve-primitives! x env))
             env)))))
 
+
+;;;
+;;; Partial evaluation.
+;;;
+
+(define (alpha-rename exp)
+  "Alpha-rename EXP.  For any lambda in EXP, generate new symbols and
+replace all lexical references to the former symbols with lexical
+references to the new symbols."
+  ;; XXX: This should be factorized somehow.
+  (let loop ((exp     exp)
+             (mapping vlist-null))             ; maps old to new gensyms
+    (match exp
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       ;; Create new symbols to replace GENSYMS and propagate them down
+       ;; in BODY and ALT.
+       (let* ((new     (map (compose gensym symbol->string) gensyms))
+              (mapping (fold vhash-consq mapping gensyms new)))
+         (make-lambda-case src req opt rest kw inits new
+                           (loop body mapping)
+                           (and alt (loop alt mapping)))))
+      (($ <lexical-ref> src name gensym)
+       ;; Possibly replace GENSYM by the new gensym defined in MAPPING.
+       (let ((val (vhash-assq gensym mapping)))
+         (if val
+             (make-lexical-ref src name (cdr val))
+             exp)))
+      (($ <lambda> src meta body)
+       (make-lambda src meta (loop body mapping)))
+      (($ <let> src names gensyms vals body)
+       ;; As for `lambda-case' rename GENSYMS to avoid any collision.
+       (let* ((new     (map (compose gensym symbol->string) gensyms))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-let src names new vals body)))
+      (($ <letrec> src in-order? names gensyms vals body)
+       ;; Likewise.
+       (let* ((new     (map (compose gensym symbol->string) gensyms))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-letrec src in-order? names new vals body)))
+      (($ <const>)
+       exp)
+      (($ <void>)
+       exp)
+      (($ <toplevel-ref>)
+       exp)
+      (($ <module-ref>)
+       exp)
+      (($ <primitive-ref>)
+       exp)
+      (($ <conditional> src condition subsequent alternate)
+       (make-conditional src
+                         (loop condition mapping)
+                         (loop subsequent mapping)
+                         (loop alternate mapping)))
+      (($ <application> src proc args)
+       (make-application src (loop proc mapping)
+                         (map (cut loop <> mapping) args)))
+      (($ <sequence> src exps)
+       (make-sequence src (map (cut loop <> mapping) exps))))))
+
 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
   "Partially evaluate EXP in compilation environment CENV, with
 top-level bindings from ENV and return the resulting expression.  Since
@@ -189,6 +253,13 @@ it does not handle <fix> and <let-values>, it should be 
called before
                        (make-lexical-ref src name (car x))))
                 (vlist-fold cons '() env))        ; todo: optimize
            new))
+      (($ <lambda> src ()
+          (and lc ($ <lambda-case>)))
+       ;; This is an anonymous lambda that we're going to inline.  The
+       ;; variable allocation process assumes globally unique gensyms to
+       ;; alpha-rename the lambda to avoid any collision with other
+       ;; copies of it.
+       (make-lambda src '() (alpha-rename lc)))
       (_ new)))
 
   (catch 'match-error
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 1876d42..156a435 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -829,6 +829,64 @@
                        (toplevel top)))))
 
   (pass-if-peval
+    ;; 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.  This test in itself doesn't check that;
+    ;; we rely on the next one to catch any error.
+    ;;
+    ;; 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>.
+    (letrec ((fold (lambda (f x3 b null? car cdr)
+                     (if (null? x3)
+                         b
+                         (f (car x3) (fold f (cdr x3) b null? car cdr))))))
+      (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+    (letrec (fold) (_) (_)
+            (if (apply (primitive zero?) (toplevel x))
+                (const 1)
+                (apply (primitive *)              ; f
+                       (apply (lambda ()          ; car
+                                (lambda-case
+                                 (((x1) #f #f #f () (_))
+                                  (lexical x1 _))))
+                              (toplevel x))
+                       (apply (lexical fold _)    ; fold
+                              (primitive *)
+                              (apply (lambda ()   ; cdr
+                                       (lambda-case
+                                        (((x2) #f #f #f () (_))
+                                         (apply (primitive -)
+                                                (lexical x2 _) (const 1)))))
+                                     (toplevel x))
+                              (const 1)
+                              (primitive zero?)
+                              (lambda ()          ; car
+                                (lambda-case
+                                 (((x1) #f #f #f () (_))
+                                  (lexical x1 _))))
+                              (lambda ()          ; cdr
+                                (lambda-case
+                                 (((x2) #f #f #f () (_))
+                                  (apply (primitive -)
+                                         (lexical x2 _) (const 1))))))))))
+
+  (pass-if "inlined lambdas are alpha-renamed"
+    ;; This one should compile without errors; see above for an
+    ;; explanation.
+    (and (compile
+          '(letrec ((fold (lambda (f x3 b null? car cdr)
+                            (if (null? x3)
+                                b
+                                (f (car x3)
+                                   (fold f (cdr x3) b null? car cdr))))))
+             (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+          #:opts '(#:partial-eval? #t)
+          #:to 'glil)
+         #t))
+
+  (pass-if-peval
     ;; Higher order, mutually recursive procedures.
     (letrec ((even? (lambda (x)
                       (or (= 0 x)


hooks/post-receive
-- 
GNU Guile