More robust reduction of equal? and eqv?

* module/language/tree-il/primitives.scm (expand-eq): Just expand out to
  binary comparisons.  Also expand eq?, which was missing.  Leave
  strength reduction to peval.
  (character-comparison-expander): Move down, as it depends on <, <=,
  and so on.
* module/language/tree-il/peval.scm (peval): Robustly reduce equal? and
  eqv?.
* test-suite/tests/peval.test ("partial evaluation"): Expect fixnum
  comparison to reduce to eq?.
  ("eqv?", "equal?"): A new battery of tests.
* test-suite/tests/tree-il.test ("primitives"): Remove reduction tests.

module/language/tree-il/peval.scm

@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011-2014, 2017, 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014, 2017, 2019, 2020 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -505,22 +505,14 @@ top-level bindings from ENV and return the resulting expression."
     (define (apply-primitive name args)
       ;; todo: further optimize commutative primitives
       (catch #t
-        (lambda ()
+             (lambda ()
-          (call-with-values
+               (call-with-values
-              (lambda ()
+                   (lambda ()
-                (case name
+                     (apply (module-ref the-scm-module name) args))
-                  ((eq? eqv?)
+                 (lambda results
-                   ;; Constants will be deduplicated later, but eq?
+                   (values #t results))))
-                   ;; folding can happen now.  Anticipate the
+             (lambda _
-                   ;; deduplication by using equal? instead of eq?.
+               (values #f '()))))
-                   ;; Same for eqv?.
-                   (apply equal? args))
-                  (else
-                   (apply (module-ref the-scm-module name) args))))
-            (lambda results
-              (values #t results))))
-        (lambda _
-          (values #f '()))))
     (define (make-values src values)
       (match values
         ((single) single)               ; 1 value
@@ -710,7 +702,7 @@ top-level bindings from ENV and return the resulting expression."
   (let loop ((exp   exp)
              (env   vlist-null)         ; vhash of gensym -> <operand>
              (counter #f)               ; inlined call stack
-             (ctx 'values))   ; effect, value, values, test, operator, or call
+             (ctx 'values)) ; effect, value, values, test, operator, or call
     (define (lookup var)
       (cond 
        ((vhash-assq var env) => cdr)
@@ -1348,9 +1340,39 @@ top-level bindings from ENV and return the resulting expression."
                (for-tail (make-seq src k (make-const #f #f))))
               (else
                (make-primcall src name (list k (make-const #f elts))))))))
-         (((? equality-primitive?)
+
-           ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+         (((? equality-primitive?) a (and b ($ <const> _ v)))
-          (for-tail (make-const #f #t)))
+          (cond
+           ((const? a)
+            ;; Constants will be deduplicated later, but eq? folding can
+            ;; happen now.  Anticipate the deduplication by using equal?
+            ;; instead of eq? or eqv?.
+            (for-tail (make-const src (equal? (const-exp a) v))))
+           ((eq? name 'eq?)
+            ;; Already in a reduced state.
+            (make-primcall src 'eq? (list a b)))
+           ((or (memq v '(#f #t () #nil)) (symbol? v) (char? v)
+                (and (exact-integer? v)
+                     (<= most-negative-fixnum v most-positive-fixnum)))
+            ;; Reduce to eq?.  Note that in Guile, characters are
+            ;; comparable with eq?.
+            (make-primcall src 'eq? (list a b)))
+           ((number? v)
+            ;; equal? and eqv? on non-fixnum numbers is the same as
+            ;; eqv?, and can't be reduced beyond that.
+            (make-primcall src 'eqv? (list a b)))
+           ((eq? name 'eqv?)
+            ;; eqv? on anything else is the same as eq?.
+            (make-primcall src 'eq? (list a b)))
+           (else
+            ;; FIXME: inline a specialized implementation of equal? for
+            ;; V here.
+            (make-primcall src name (list a b)))))
+         (((? equality-primitive?) (and a ($ <const>)) b)
+          (for-tail (make-primcall src name (list b a))))
+         (((? equality-primitive?) ($ <lexical-ref> _ _ sym)
+                                   ($ <lexical-ref> _ _ sym))
+          (for-tail (make-const src #t)))
 
          (('logbit? ($ <const> src2
                        (? (lambda (bit)

module/language/tree-il/primitives.scm

@@ -560,42 +560,11 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
-(define (character-comparison-expander char< <)
+(define (expand-eq prim)
-  (lambda (src . args)
-    (expand-primcall
-     (make-primcall src <
-                    (map (lambda (arg)
-                           (make-primcall src 'char->integer (list arg)))
-                         args)))))
-
-(for-each (match-lambda
-            ((char< . <)
-             (define-primitive-expander! char<
-               (character-comparison-expander char< <))))
-          '((char<? . <)
-            (char>? . >)
-            (char<=? . <=)
-            (char>=? . >=)
-            (char=? . =)))
-
-;; Appropriate for use with either 'eqv?' or 'equal?'.
-(define (maybe-simplify-to-eq prim)
   (case-lambda
     ((src) (make-const src #t))
     ((src a) (make-const src #t))
-    ((src a b)
+    ((src a b) #f)
-     ;; 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-primcall src 'eq? (list a b))))))
-     (or (maybe-simplify a b) (maybe-simplify b a)))
     ((src a b . rest)
      (with-lexicals src (b)
        (make-conditional src (make-primcall src prim (list a b))
@@ -603,8 +572,9 @@
                          (make-const src #f))))
     (else #f)))
 
-(define-primitive-expander! 'eqv?   (maybe-simplify-to-eq 'eqv?))
+(define-primitive-expander! 'eq?    (expand-eq 'eq?))
-(define-primitive-expander! 'equal? (maybe-simplify-to-eq 'equal?))
+(define-primitive-expander! 'eqv?   (expand-eq 'eqv?))
+(define-primitive-expander! 'equal? (expand-eq 'equal?))
 
 (define (expand-chained-comparisons prim)
   (case-lambda
@@ -628,6 +598,24 @@
               (expand-chained-comparisons prim)))
  '(< <= = >= > eq?))
 
+(define (character-comparison-expander char< <)
+  (lambda (src . args)
+    (expand-primcall
+     (make-primcall src <
+                    (map (lambda (arg)
+                           (make-primcall src 'char->integer (list arg)))
+                         args)))))
+
+(for-each (match-lambda
+            ((char< . <)
+             (define-primitive-expander! char<
+               (character-comparison-expander char< <))))
+          '((char<? . <)
+            (char>? . >)
+            (char<=? . <=)
+            (char>=? . >=)
+            (char=? . =)))
+
 (define-primitive-expander! 'call-with-prompt
   (case-lambda
    ((src tag thunk handler)

test-suite/tests/peval.test

@@ -642,11 +642,11 @@
       ((3 2 1) 'a)
       (else 'b))
     (let (key) (_) ((toplevel foo))
-         (if (if (primcall eqv? (lexical key _) (const 3))
+         (if (if (primcall eq? (lexical key _) (const 3))
                  (const #t)
-                 (if (primcall eqv? (lexical key _) (const 2))
+                 (if (primcall eq? (lexical key _) (const 2))
                      (const #t)
-                     (primcall eqv? (lexical key _) (const 1))))
+                     (primcall eq? (lexical key _) (const 1))))
              (const a)
              (const b))))
 
@@ -1441,3 +1441,59 @@
              (call (lexical add1 _)
                    (const 1)
                    (const 2))))))))
+
+(with-test-prefix "eqv?"
+  (pass-if-peval (eqv? x #f)
+    (primcall eq? (toplevel x) (const #f)))
+
+  (pass-if-peval (eqv? x '())
+    (primcall eq? (toplevel x) (const ())))
+
+  (pass-if-peval (eqv? x #t)
+    (primcall eq? (toplevel x) (const #t)))
+
+  (pass-if-peval (eqv? x 'sym)
+    (primcall eq? (toplevel x) (const sym)))
+
+  (pass-if-peval (eqv? x 42)
+    (primcall eq? (toplevel x) (const 42)))
+
+  (pass-if-peval (eqv? x #\a)
+    (primcall eq? (toplevel x) (const #\a)))
+
+  (pass-if-peval (eqv? x 42.0)
+    (primcall eqv? (toplevel x) (const '42.0)))
+
+  (pass-if-peval (eqv? x #nil)
+    (primcall eq? (toplevel x) (const #nil)))
+
+  (pass-if-peval (eqv? x '(a . b))
+    (primcall eq? (toplevel x) (const (a . b)))))
+
+(with-test-prefix "equal?"
+  (pass-if-peval (equal? x #f)
+    (primcall eq? (toplevel x) (const #f)))
+
+  (pass-if-peval (equal? x '())
+    (primcall eq? (toplevel x) (const ())))
+
+  (pass-if-peval (equal? x #t)
+    (primcall eq? (toplevel x) (const #t)))
+
+  (pass-if-peval (equal? x 'sym)
+    (primcall eq? (toplevel x) (const sym)))
+
+  (pass-if-peval (equal? x 42)
+    (primcall eq? (toplevel x) (const 42)))
+
+  (pass-if-peval (equal? x #\a)
+    (primcall eq? (toplevel x) (const #\a)))
+
+  (pass-if-peval (equal? x 42.0)
+    (primcall eqv? (toplevel x) (const '42.0)))
+
+  (pass-if-peval (equal? x #nil)
+    (primcall eq? (toplevel x) (const #nil)))
+
+  (pass-if-peval (equal? x '(a . b))
+    (primcall equal? (toplevel x) (const (a . b)))))

test-suite/tests/tree-il.test

@@ -56,66 +56,6 @@
 
 (with-test-prefix "primitives"
 
-  (with-test-prefix "eqv?"
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (toplevel x) (const #f))
-      (primcall eq? (const #f) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (toplevel x) (const ()))
-      (primcall eq? (const ()) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (const #t) (lexical x y))
-      (primcall eq? (const #t) (lexical x y)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (const this-is-a-symbol) (toplevel x))
-      (primcall eq? (const this-is-a-symbol) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (const 42) (toplevel x))
-      (primcall eq? (const 42) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (const 42.0) (toplevel x))
-      (primcall eqv? (const 42.0) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall eqv? (const #nil) (toplevel x))
-      (primcall eq? (const #nil) (toplevel x))))
-
-  (with-test-prefix "equal?"
-
-    (pass-if-primitives-resolved
-        (primcall equal? (toplevel x) (const #f))
-      (primcall eq? (const #f) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (toplevel x) (const ()))
-      (primcall eq? (const ()) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (const #t) (lexical x y))
-      (primcall eq? (const #t) (lexical x y)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (const this-is-a-symbol) (toplevel x))
-      (primcall eq? (const this-is-a-symbol) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (const 42) (toplevel x))
-      (primcall eq? (const 42) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (const 42.0) (toplevel x))
-      (primcall equal? (const 42.0) (toplevel x)))
-
-    (pass-if-primitives-resolved
-        (primcall equal? (const #nil) (toplevel x))
-      (primcall eq? (const #nil) (toplevel x))))
-
   (with-test-prefix "error"
     (pass-if-primitives-resolved
         (primcall error (const "message"))