From 07e3c4d6f66be5368fe6d70a2dacea1136b52365 Mon Sep 17 00:00:00 2001
From: Noah Lavine <noah.b.lavine@gmail.com>
Date: Sat, 18 Feb 2012 10:55:49 -0500
Subject: [PATCH] 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
---
 module/language/tree-il/peval.scm      |   11 +++++++++++
 module/language/tree-il/primitives.scm |   11 ++++++++++-
 2 files changed, 21 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
-- 
1.7.6

