diff options
-rw-r--r-- | module/language/tree-il/peval.scm | 11 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 11 | ||||
-rw-r--r-- | 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 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. |