[Guile-commits] GNU Guile branch, wip-cse, updated. v2.0.5-112-gc7bfcc2

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

The branch, wip-cse has been updated
       via  c7bfcc251e273e7ad8932bbfd37d6c343035bf89 (commit)
       via  43e0fadf6adb47ecf118a80a36fa6397611f342e (commit)
      from  6260c0e2594d983c3521e156d83dc329749562f7 (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 c7bfcc251e273e7ad8932bbfd37d6c343035bf89
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 16 16:25:19 2012 -0700

    fix replacement of CSE with lexical-ref
    
    * module/language/tree-il/cse.scm (cse): Fix dominator unrolling for
      lexical propagation.
    
    * test-suite/tests/cse.test ("cse"): Add test.

commit 43e0fadf6adb47ecf118a80a36fa6397611f342e
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 16 12:42:31 2012 -0700

    cse hashing tweak
    
    * module/language/tree-il/cse.scm (cse): Minor tweak to hash depth based
      on time profile of compiling peval.scm.

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

Summary of changes:
 module/language/tree-il/cse.scm |   29 +++++++++++++++++------------
 test-suite/tests/cse.test       |    9 ++++++++-
 2 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 3d8a7f8..f55c481 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -193,7 +193,7 @@
     (/ (string-length (symbol->string (struct-layout x))) 2))
 
   (define hash-bits (logcount most-positive-fixnum))
-  (define hash-depth 3)
+  (define hash-depth 4)
   (define hash-width 3)
   (define (hash-expression exp)
     (define (hash-exp exp depth)
@@ -353,29 +353,30 @@
          (expressions-equal? exp exp*))
         (_ #f)))
       
-    (define (unroll db from to)
-      (or (<= from to)
-          (match (vlist-ref db (1- from))
+    (define (unroll db base n)
+      (or (zero? n)
+          (match (vlist-ref db base)
             (('lambda . h*)
              ;; See note in find-dominating-expression.
              (and (not (depends-on-effects? effects &all-effects))
-                  (unroll db (1- from) to)))
+                  (unroll db (1+ base) (1- n))))
             ((#(exp* effects* ctx*) . h*)
              (and (effects-commute? effects effects*)
-                  (unroll db (1- from) to))))))
+                  (unroll db (1+ base) (1- n)))))))
 
     (let ((h (hash-expression exp)))
       (and (effect-free? (exclude-effects effects &type-check))
            (vhash-assoc exp env entry-matches? (hasher h))
-           (let ((env-len (vlist-length env)))
-             (let lp ((n 0) (db-len (vlist-length db)))
+           (let ((env-len (vlist-length env))
+                 (db-len (vlist-length db)))
+             (let lp ((n 0) (m 0))
                (and (< n env-len)
                     (match (vlist-ref env n)
                       ((#(exp* name sym db-len*) . h*)
-                       (and (unroll db db-len db-len*)
+                       (and (unroll db m (- db-len db-len*))
                             (if (and (= h h*) (expressions-equal? exp* exp))
                                 (make-lexical-ref (tree-il-src exp) name sym)
-                                (lp (1+ n) db-len*)))))))))))
+                                (lp (1+ n) (- db-len db-len*))))))))))))
 
   (define (intersection db+ db-)
     (vhash-fold-right
@@ -414,8 +415,12 @@
                                      (logior &zero-values
                                              &allocation)))
                    (has-dominating-effect? exp effects db)))
-          (log 'elide ctx (unparse-tree-il exp))
-          (values (make-void #f) db*))
+          (cond
+           ((void? exp)
+            (values exp db*))
+           (else
+            (log 'elide ctx (unparse-tree-il exp))
+            (values (make-void #f) db*))))
          ((and (boolean-valued-expression? exp ctx)
                (find-dominating-test exp effects db))
           => (lambda (exp)
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 7195a4d..a6308d5 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -249,4 +249,11 @@
                           (apply (primitive struct-ref) (lexical x _) (const 
1))
                           (apply (primitive 'throw) (const 'foo))))
              (apply (primitive +) (lexical z _)
-                    (apply (primitive struct-ref) (lexical x _) (const 
2)))))))))
+                    (apply (primitive struct-ref) (lexical x _) (const 
2))))))))
+
+  ;; Replacing named expressions with lexicals.
+  (pass-if-cse
+   (let ((x (car y)))
+     (cons x (car y)))
+   (let (x) (_) ((apply (primitive car) (toplevel y)))
+        (apply (primitive cons) (lexical x _) (lexical x _)))))


hooks/post-receive
-- 
GNU Guile