[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-65-gaaae0d5

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

The branch, master has been updated
       via  aaae0d5ab3d0a867b7005d1a6bf38dc345195a93 (commit)
      from  eca29b020267c477bddc3f9df6f087f461f7c8b9 (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 aaae0d5ab3d0a867b7005d1a6bf38dc345195a93
Author: Andy Wingo <address@hidden>
Date:   Wed Aug 12 20:44:30 2009 +0200

    "fix" <let>-bound lambda expressions too
    
    * module/language/tree-il/compile-glil.scm (compile-glil): Compute
      warnings before optimizing, as unreferenced variables will be
      optimized out.
    
    * libguile/_scm.h: Fix C99 comment.
    
    * module/language/tree-il/fix-letrec.scm (partition-vars): Also analyze
      let-bound vars.
      (fix-letrec!): Fix a bug whereby a set! to an unreffed var would be
      called for value, not effect. Also "fix" <let>-bound lambda
      expressions -- really speeds up pmatch.
    
    * test-suite/tests/tree-il.test ("lexical sets", "the or hack"): Update
      to take into account the new optimizations.

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

Summary of changes:
 libguile/_scm.h                          |    2 +-
 module/language/tree-il/compile-glil.scm |   14 +++---
 module/language/tree-il/fix-letrec.scm   |   62 +++++++++++++++++++++++++++++-
 test-suite/tests/tree-il.test            |   25 ++++++++----
 4 files changed, 85 insertions(+), 18 deletions(-)

diff --git a/libguile/_scm.h b/libguile/_scm.h
index 737e01e..627c51e 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -170,7 +170,7 @@
 /* The word size marker in objcode.  */
 #define SCM_OBJCODE_WORD_SIZE  SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
 
-// major and minor versions must be single characters
+/* Major and minor versions must be single characters. */
 #define SCM_OBJCODE_MAJOR_VERSION 0
 #define SCM_OBJCODE_MINOR_VERSION B
 #define SCM_OBJCODE_MAJOR_VERSION_STRING        \
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 503e0a4..8886fa3 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -53,16 +53,16 @@
     (or (and=> (memq #:warnings opts) cadr)
         '()))
 
-  (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
-         (x (optimize! x e opts))
-         (allocation (analyze-lexicals x)))
-
-    ;; Go throught the warning passes.
-    (for-each (lambda (kind)
+  ;; Go throught the warning passes.
+  (for-each (lambda (kind)
                 (let ((warn (assoc-ref %warning-passes kind)))
                   (and (procedure? warn)
                        (warn x))))
-              warnings)
+            warnings)
+
+  (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+         (x (optimize! x e opts))
+         (allocation (analyze-lexicals x)))
 
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()
diff --git a/module/language/tree-il/fix-letrec.scm 
b/module/language/tree-il/fix-letrec.scm
index 0ed7b6b..9b66d9e 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -78,6 +78,13 @@
                                simple
                                lambda*
                                complex))
+                      ((<let> vars)
+                       (values (append vars unref)
+                               ref
+                               set
+                               simple
+                               lambda*
+                               complex))
                       (else
                        (values unref ref set simple lambda* complex))))
                   (lambda (x unref ref set simple lambda* complex)
@@ -108,6 +115,39 @@
                           (else
                            (lp (cdr vars) (cdr vals)
                                s l (cons (car vars) c))))))
+                      ((<let> (orig-vars vars) vals)
+                       ;; The point is to compile let-bound lambdas as
+                       ;; efficiently as we do letrec-bound lambdas, so
+                       ;; we use the same algorithm for analyzing the
+                       ;; vars. There is no problem recursing into the
+                       ;; bindings after the let, because all variables
+                       ;; have been renamed.
+                       (let lp ((vars orig-vars) (vals vals)
+                                (s '()) (l '()) (c '()))
+                         (cond
+                          ((null? vars)
+                           (values unref
+                                   ref
+                                   set
+                                   (append s simple)
+                                   (append l lambda*)
+                                   (append c complex)))
+                          ((memq (car vars) unref)
+                           (lp (cdr vars) (cdr vals)
+                               s l c))
+                          ((memq (car vars) set)
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c)))
+                          ((and (lambda? (car vals))
+                                (not (memq (car vars) set)))
+                           (lp (cdr vars) (cdr vals)
+                               s (cons (car vars) l) c))
+                          ;; There is no difference between simple and
+                          ;; complex, for the purposes of let. Just lump
+                          ;; them all into complex.
+                          (else
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c))))))
                       (else
                        (values unref ref set simple lambda* complex))))
                   '()
@@ -128,7 +168,7 @@
          ;; expression, called for effect.
          ((<lexical-set> gensym exp)
           (if (memq gensym unref)
-              (make-sequence #f (list (make-void #f) exp))
+              (make-sequence #f (list exp (make-void #f)))
               x))
 
          ((<letrec> src names vars vals body)
@@ -176,5 +216,25 @@
                        ;; Finally, the body.
                        body)))))))))
 
+         ((<let> src names vars vals body)
+          (let ((binds (map list vars names vals)))
+            (define (lookup set)
+              (map (lambda (v) (assq v binds))
+                   (lset-intersection eq? vars set)))
+            (let ((u (lookup unref))
+                  (l (lookup lambda*))
+                  (c (lookup complex)))
+              (make-sequence
+               src
+               (append
+                ;; unreferenced bindings, called for effect.
+                (map caddr u)
+                (list
+                 ;; unassigned lambdas use fix.
+                 (make-fix src (map cadr l) (map car l) (map caddr l)
+                           ;; and the "complex" bindings.
+                           (make-let src (map cadr c) (map car c) (map caddr c)
+                                     body))))))))
+         
          (else x)))
      x)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index d993e4f..73ea9c1 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -151,25 +151,33 @@
 
 (with-test-prefix "lexical sets"
   (assert-tree-il->glil
-   (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
+   ;; unreferenced sets may be optimized away -- make sure they are ref'd
+   (let (x) (y) ((const 1))
+        (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
    (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (void) (call return 1)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
+            (void) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
-   (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
+   (let (x) (y) ((const 1))
+        (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+               (lexical x y)))
    (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (const #f) (call return 1)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
+            (lexical #t #t ref 0) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-     (apply (primitive null?) (set! (lexical x y) (const 2))))
+     (apply (primitive null?)
+            (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
    (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 
1)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
+            (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "module refs"
@@ -413,20 +421,19 @@
             (unbind))
    (eq? l1 l2))
 
+  ;; second bound var is unreferenced
   (assert-tree-il->glil/pmatch
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical x y))))
-   (program 0 0 2 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (branch br-if-not ,l1)
             (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a #f 1)) (lexical #t #f set 1)
             (lexical #t #f ref 0) (call return 1)
-            (unbind)
             (unbind))
    (eq? l1 l2)))
 


hooks/post-receive
-- 
GNU Guile