[Guile-commits] GNU Guile branch, master, updated. v2.1.0-48-g3c65e3f

[Noah Lavine]

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=3c65e3fda512cda13de244e853afd0fa0e7b5962

The branch, master has been updated
       via  3c65e3fda512cda13de244e853afd0fa0e7b5962 (commit)
      from  6978c673393a960d7caf604b8c72ff2b5fe0f4ec (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 3c65e3fda512cda13de244e853afd0fa0e7b5962
Author: Noah Lavine <address@hidden>
Date:   Sat Feb 18 10:55:49 2012 -0500

    Optimize Equality Primitives
    
    * module/language/tree-il/primitives.scm: add equality-primitive?,
      which is true for eq?, eqv?, and equal?
    * module/language/tree-il/peval.scm: if an equality primitive is
      applied to the same variable twice, fold it to #t
    * test-suite/tests/tree-il.test: add tests for pevaling equality
      primitives

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

Summary of changes:
 module/language/tree-il/peval.scm      |   11 +++++++++++
 module/language/tree-il/primitives.scm |   11 ++++++++++-
 test-suite/tests/tree-il.test          |   10 ++++++++++
 3 files changed, 31 insertions(+), 1 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 9aac24c..a588b68 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1103,6 +1103,17 @@ top-level bindings from ENV and return the resulting 
expression."
          ((name . args)
           (fold-constants src name args ctx))))
 
+      (($ <primcall> src (? equality-primitive? name) (a b))
+       (let ((val-a (for-value a))
+             (val-b (for-value b)))
+         (log 'equality-primitive name val-a val-b)
+         (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
+                     (eq? (lexical-ref-gensym val-a)
+                          (lexical-ref-gensym val-b)))
+                (for-tail (make-const #f #t)))
+               (else
+                (fold-constants src name (list val-a val-b) ctx)))))
+      
       (($ <primcall> src (? effect-free-primitive? name) args)
        (fold-constants src name (map for-value args) ctx))
 
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index f192c4f..157aaa1 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,7 @@
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
-            singly-valued-primitive?))
+            singly-valued-primitive? equality-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -206,9 +206,13 @@
     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
 
+(define *equality-primitives*
+  '(eq? eqv? equal?))
+
 (define *effect-free-primitive-table* (make-hash-table))
 (define *effect+exceptions-free-primitive-table* (make-hash-table))
 (define *singly-valued-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
             (hashq-set! *effect-free-primitive-table* x #t))
@@ -219,6 +223,9 @@
 (for-each (lambda (x) 
             (hashq-set! *singly-valued-primitive-table* x #t))
           *singly-valued-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *equality-primitive-table* x #t))
+          *equality-primitives*)
 
 (define (constructor-primitive? prim)
   (memq prim *primitive-constructors*))
@@ -230,6 +237,8 @@
   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 (define (singly-valued-primitive? prim)
   (hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+  (hashq-ref *equality-primitive-table* prim))
 
 (define (resolve-primitives! x mod)
   (define local-definitions
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 1f3d4e9..78068ff 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1498,6 +1498,16 @@
    ;; Constant folding: cdr+list, impure
    (cdr (list (bar) 0))
    (seq (call (toplevel bar)) (primcall list (const 0))))
+
+  (pass-if-peval
+   ;; Equality primitive: same lexical
+   (let ((x (random))) (eq? x x))
+   (seq (call (toplevel random)) (const #t)))
+
+  (pass-if-peval
+   ;; Equality primitive: merge lexical identities
+   (let* ((x (random)) (y x)) (eq? x y))
+   (seq (call (toplevel random)) (const #t)))
   
   (pass-if-peval
    ;; Non-constant guards get lexical bindings.


hooks/post-receive
-- 
GNU Guile