[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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

From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-48-g3c65e3f
Date: Mon, 20 Feb 2012 20:24:32 +0000

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".

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


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 
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 
          ((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 
index f192c4f..157aaa1 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,7 @@
             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))
+(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)))
    ;; Non-constant guards get lexical bindings.

GNU Guile

reply via email to

[Prev in Thread] Current Thread [Next in Thread]