[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-5-gacdf4fc

[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=acdf4fcc059df325f66698090359b3455725c865

The branch, stable-2.0 has been updated
       via  acdf4fcc059df325f66698090359b3455725c865 (commit)
       via  8ee0b28b4d51dac704c151bf7f6d1874018ed3ae (commit)
       via  5e9b9059a334be0427eeb37eee6627dd595dc567 (commit)
       via  16d3e0133d9e5fd1052be69bfeec3b243d832ed4 (commit)
      from  d825841db0eb920150d6734b8928b6a3decbca0e (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 acdf4fcc059df325f66698090359b3455725c865
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 9 16:44:59 2011 +0100

    simplify primitives.scm for dynwind
    
    * module/language/tree-il/primitives.scm (*primitive-expand-table*):
      Remove a dynwind hack, as we have a good inliner now.

commit 8ee0b28b4d51dac704c151bf7f6d1874018ed3ae
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 9 15:23:58 2011 +0100

    peval: fix dynwind bug.
    
    * module/language/tree-il/peval.scm (peval): The <dynwind> compiler will
      copy the winder and unwinder values, so make sure that they are
      constant, and if not, create lexical bindings.  Fixes
      http://debbugs.gnu.org/9844.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): Add a couple
      <dynwind> tests.

commit 5e9b9059a334be0427eeb37eee6627dd595dc567
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 9 16:41:56 2011 +0100

    fix <dynwind> serialization.
    
    * module/language/tree-il.scm (unparse-tree-il): Fix <dynwind>
      serialization.

commit 16d3e0133d9e5fd1052be69bfeec3b243d832ed4
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 9 15:22:01 2011 +0100

    peval: don't copy assigned lexical bindings
    
    * module/language/tree-il/peval.scm (peval): Since constant-expression?
      is used to determine whether to copy values, return #f if any lexical
      is assigned.

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

Summary of changes:
 module/language/tree-il.scm            |    6 ++--
 module/language/tree-il/peval.scm      |   63 +++++++++++++++++++++++++-------
 module/language/tree-il/primitives.scm |   43 +++++++---------------
 test-suite/tests/tree-il.test          |   20 ++++++++++
 4 files changed, 86 insertions(+), 46 deletions(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index da51152..1d391c4 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -310,9 +310,9 @@
     ((<let-values> exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    ((<dynwind> body winder unwinder)
-     `(dynwind ,(unparse-tree-il body)
-               ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
+    ((<dynwind> winder body unwinder)
+     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
+               ,(unparse-tree-il unwinder)))
 
     ((<dynlet> fluids vals body)
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 0d6abb2..634c6c9 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -530,16 +530,18 @@ top-level bindings from ENV and return the resulting 
expression."
                    (make-sequence src (append head (list tail)))))))))))
 
   (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).
+    ;; Return true if X is constant, for the purposes of copying or
+    ;; elision---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)
         (($ <const>) #t)
         (($ <lambda>) #t)
-        (($ <lambda-case> _ req opt rest kw inits _ body alternate)
-         (and (every loop inits) (loop body)
+        (($ <lambda-case> _ req opt rest kw inits syms body alternate)
+         (and (not (any assigned-lexical? syms))
+              (every loop inits) (loop body)
               (or (not alternate) (loop alternate))))
         (($ <lexical-ref> _ _ gensym)
          (not (assigned-lexical? gensym)))
@@ -556,10 +558,12 @@ top-level bindings from ENV and return the resulting 
expression."
          (and (loop body) (every loop args)))
         (($ <sequence> _ exps)
          (every loop exps))
-        (($ <let> _ _ _ vals body)
-         (and (every loop vals) (loop body)))
-        (($ <letrec> _ _ _ _ vals body)
-         (and (every loop vals) (loop body)))
+        (($ <let> _ _ syms vals body)
+         (and (not (any assigned-lexical? syms))
+              (every loop vals) (loop body)))
+        (($ <letrec> _ _ _ syms vals body)
+         (and (not (any assigned-lexical? syms))
+              (every loop vals) (loop body)))
         (($ <fix> _ _ _ vals body)
          (and (every loop vals) (loop body)))
         (($ <let-values> _ exp body)
@@ -830,8 +834,10 @@ top-level bindings from ENV and return the resulting 
expression."
                  (ops (make-bound-operands vars new vals visit))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
-         (if (and (const? body*)
-                  (every constant-expression? vals))
+         (if (and (const? body*) (every constant-expression? vals))
+             ;; We may have folded a loop completely, even though there
+             ;; might be cyclical references between the bound values.
+             ;; Handle this degenerate case specially.
              body*
              (prune-bindings ops in-order? body* counter ctx
                              (lambda (names gensyms vals body)
@@ -864,8 +870,39 @@ top-level bindings from ENV and return the resulting 
expression."
                (_ #f))
              (make-let-values lv-src producer (for-tail consumer)))))
       (($ <dynwind> src winder body unwinder)
-       (make-dynwind src (for-value winder) (for-tail body)
-                     (for-value unwinder)))
+       (let ((pre (for-value winder))
+             (body (for-tail body))
+             (post (for-value unwinder)))
+         (cond
+          ((not (constant-expression? pre))
+           (cond
+            ((not (constant-expression? post))
+             (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (record-new-temporary! 'post post-sym 1)
+               (make-let src '(pre post) (list pre-sym post-sym) (list pre 
post)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       (make-lexical-ref #f 'post post-sym)))))
+            (else
+             (let ((pre-sym (gensym "pre ")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (make-let src '(pre) (list pre-sym) (list pre)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       post))))))
+          ((not (constant-expression? post))
+           (let ((post-sym (gensym "post ")))
+             (record-new-temporary! 'post post-sym 1)
+             (make-let src '(post) (list post-sym) (list post)
+                       (make-dynwind src
+                                     pre
+                                     body
+                                     (make-lexical-ref #f 'post post-sym)))))
+          (else
+           (make-dynwind src pre body post)))))
       (($ <dynlet> src fluids vals body)
        (make-dynlet src (map for-value fluids) (map for-value vals)
                     (for-tail body)))
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 172150b..f7bb5ca 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -473,36 +473,19 @@
             'dynamic-wind
             (case-lambda
               ((src pre thunk post)
-               ;; Here we will make concessions to the fact that our inliner is
-               ;; lame, and add a hack.
-               (cond
-                ((lambda? thunk)
-                 (let ((PRE (gensym " pre"))
-                       (POST (gensym " post")))
-                   (make-let
-                    src
-                    '(pre post)
-                    (list PRE POST)
-                    (list pre post)
-                    (make-dynwind
-                     src
-                     (make-lexical-ref #f 'pre PRE)
-                     (make-application #f thunk '())
-                     (make-lexical-ref #f 'post POST)))))
-                (else
-                 (let ((PRE (gensym " pre"))
-                       (THUNK (gensym " thunk"))
-                       (POST (gensym " post")))
-                   (make-let
-                    src
-                    '(pre thunk post)
-                    (list PRE THUNK POST)
-                    (list pre thunk post)
-                    (make-dynwind
-                     src
-                     (make-lexical-ref #f 'pre PRE)
-                     (make-application #f (make-lexical-ref #f 'thunk THUNK) 
'())
-                     (make-lexical-ref #f 'post POST)))))))
+               (let ((PRE (gensym " pre"))
+                     (THUNK (gensym " thunk"))
+                     (POST (gensym " post")))
+                 (make-let
+                  src
+                  '(pre thunk post)
+                  (list PRE THUNK POST)
+                  (list pre thunk post)
+                  (make-dynwind
+                   src
+                   (make-lexical-ref #f 'pre PRE)
+                   (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
+                   (make-lexical-ref #f 'post POST)))))
               (else #f)))
 
 (hashq-set! *primitive-expand-table*
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 011fef5..e9ac34f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1457,6 +1457,26 @@
   
   (pass-if-peval
    resolve-primitives
+   ;; Non-constant guards get lexical bindings.
+   (dynamic-wind foo (lambda () bar) baz)
+   (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
+        (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+  
+  (pass-if-peval
+   resolve-primitives
+   ;; Constant guards don't need lexical bindings.
+   (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+   (dynwind
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ()) (toplevel foo))))
+    (toplevel bar)
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ()) (toplevel baz))))))
+  
+  (pass-if-peval
+   resolve-primitives
    ;; Prompt is removed if tag is unreferenced
    (let ((tag (make-prompt-tag)))
      (call-with-prompt tag


hooks/post-receive
-- 
GNU Guile