summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/peval.scm11
-rw-r--r--module/language/tree-il/primitives.scm11
-rw-r--r--test-suite/tests/tree-il.test10
3 files changed, 31 insertions, 1 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 9aac24cc1..a588b68b7 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 f192c4fc3..157aaa18d 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 1f3d4e91c..78068ffcd 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.