Simplify calls to 'eqv?' when one argument is an immediate constant.

* module/language/tree-il/primitives.scm (maybe-simplify-to-eq): New
  helper procedure shared by expanders for 'eqv?' and 'equal?'.
  (*primitive-expand-table*): Add expansion rule for 'eqv?'.

* test-suite/tests/tree-il.test ("primitives"): Add tests.

module/language/tree-il/primitives.scm

@@ -490,24 +490,26 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
-(hashq-set! *primitive-expand-table*
-            'equal?
-            (case-lambda
-              ((src a b)
-               ;; Simplify cases where either A or B is constant.
-               (define (maybe-simplify a b)
-                 (and (const? a)
-                      (let ((v (const-exp a)))
-                        (and (or (memq v '(#f #t () #nil))
-                                 (symbol? v)
-                                 (and (integer? v)
-                                      (exact? v)
-                                      (<= v most-positive-fixnum)
-                                      (>= v most-negative-fixnum)))
-                             (make-application src (make-primitive-ref #f 'eq?)
-                                               (list a b))))))
-               (or (maybe-simplify a b) (maybe-simplify b a)))
-              (else #f)))
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+  (case-lambda
+    ((src a b)
+     ;; Simplify cases where either A or B is constant.
+     (define (maybe-simplify a b)
+       (and (const? a)
+            (let ((v (const-exp a)))
+              (and (or (memq v '(#f #t () #nil))
+                       (symbol? v)
+                       (and (integer? v)
+                            (exact? v)
+                            (<= most-negative-fixnum v most-positive-fixnum)))
+                   (make-application src (make-primitive-ref #f 'eq?)
+                                     (list a b))))))
+     (or (maybe-simplify a b) (maybe-simplify b a)))
+    (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
 
 (hashq-set! *primitive-expand-table*
             'dynamic-wind

test-suite/tests/tree-il.test

@@ -86,33 +86,65 @@
 
 (with-test-prefix "primitives"
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #f) (toplevel x))
-   (apply (primitive eq?) (const #f) (toplevel x)))
+  (with-test-prefix "eqv?"
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const ()) (toplevel x))
-   (apply (primitive eq?) (const ()) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #f) (toplevel x))
+      (apply (primitive eq?) (const #f) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #t) (lexical x y))
-   (apply (primitive eq?) (const #t) (lexical x y)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const ()) (toplevel x))
+      (apply (primitive eq?) (const ()) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
-   (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #t) (lexical x y))
+      (apply (primitive eq?) (const #t) (lexical x y)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const 42) (toplevel x))
-   (apply (primitive eq?) (const 42) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
+      (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const 42.0) (toplevel x))
-   (apply (primitive equal?) (const 42.0) (toplevel x)))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const 42) (toplevel x))
+      (apply (primitive eq?) (const 42) (toplevel x)))
 
-  (pass-if-primitives-resolved
-   (apply (primitive equal?) (const #nil) (toplevel x))
-   (apply (primitive eq?) (const #nil) (toplevel x))))
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const 42.0) (toplevel x))
+      (apply (primitive eqv?) (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive eqv?) (const #nil) (toplevel x))
+      (apply (primitive eq?) (const #nil) (toplevel x))))
+
+  (with-test-prefix "equal?"
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #f) (toplevel x))
+      (apply (primitive eq?) (const #f) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const ()) (toplevel x))
+      (apply (primitive eq?) (const ()) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #t) (lexical x y))
+      (apply (primitive eq?) (const #t) (lexical x y)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
+      (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const 42) (toplevel x))
+      (apply (primitive eq?) (const 42) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const 42.0) (toplevel x))
+      (apply (primitive equal?) (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (apply (primitive equal?) (const #nil) (toplevel x))
+      (apply (primitive eq?) (const #nil) (toplevel x)))))
 
 
 (with-test-prefix "tree-il->scheme"