From 61cca9308675ad84041771e5bdb02d48c1e1409c Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Mon, 22 Mar 2021 12:18:37 -0300
Subject: [PATCH] Chez Scheme: improve eq[v]? reductions in cptypes

Improve eq? and eq? handling to reduce expressions like
(eq? (newline) (void)) => (begin (newline) #t)
---
 .../tests/racket/optimize.rktl                |  6 ++--
 racket/src/ChezScheme/mats/cptypes.ms         | 10 +++++-
 racket/src/ChezScheme/s/cptypes.ss            | 34 +++++++++++++++++++
 3 files changed, 45 insertions(+), 5 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl
index 5aea1625ff..d6168e215f 100644
--- a/pkgs/racket-test-core/tests/racket/optimize.rktl
+++ b/pkgs/racket-test-core/tests/racket/optimize.rktl
@@ -922,8 +922,7 @@
 ;Test types inference for string?
 (test-arg-types '(string-length string?) 'fixnum? 'may-omit)
 (test-arg-types '(string-ref string? fixnum?) 'char?)
-(unless (eq? (system-type 'vm) 'chez-scheme) ;; cptypes doesn't know that void? => eq? to (void)
-  (test-arg-types '(string-set! string? fixnum? char?) 'void?))
+(test-arg-types '(string-set! string? fixnum? char?) 'void?)
 (test-arg-types '(string->immutable-string string?) 'string? 'may-omit)
 (test-arg-types '(string-append) 'string? 'may-omit)
 (test-arg-types '(string-append string?) 'string? 'may-omit)
@@ -934,8 +933,7 @@
 ;Test types inference for bytes?
 (test-arg-types '(bytes-length bytes?) 'fixnum? 'may-omit)
 (test-arg-types '(bytes-ref bytes? fixnum?) 'fixnum?)
-(unless (eq? (system-type 'vm) 'chez-scheme) ;; cptypes doesn't know that void? => eq? to (void)
-  (test-arg-types '(bytes-set! bytes? fixnum? fixnum?) 'void?))
+(test-arg-types '(bytes-set! bytes? fixnum? fixnum?) 'void?)
 (unless (eq? (system-type 'vm) 'chez-scheme) ;; ???
   (test-arg-types '(bytes->immutable-bytes bytes?) 'bytes? 'may-omit))
 (unless (eq? (system-type 'vm) 'chez-scheme) ;; bytes-append is not primitive
diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms
index d4cccf60d9..37d4b20863 100644
--- a/racket/src/ChezScheme/mats/cptypes.ms
+++ b/racket/src/ChezScheme/mats/cptypes.ms
@@ -84,6 +84,12 @@
   (cptypes-equivalent-expansion?
     '(pair? (list)) 
     #f)
+  (cptypes-equivalent-expansion?
+    '(eq? (newline) (void))
+    '(begin (newline) #t))
+  (cptypes-equivalent-expansion?
+    '(eq? (newline) 0)
+    '(begin (newline) #f))
   (cptypes-equivalent-expansion?
     '(lambda (x) (vector-set! x 0 0) (vector? x))
     '(lambda (x) (vector-set! x 0 0) #t))
@@ -574,11 +580,12 @@
   (test-chain* '(fixnum? integer? real?))
   (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
   (test-chain* '(bignum? exact? number?)) ; exact? may raise an error
-  (test-chain* '((lambda (x) (eq? x (expt 256 100))) bignum? real? number?))
+  (test-chain '((lambda (x) (eqv? x (expt 256 100))) bignum? real? number?))
   (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
   (test-chain* '((lambda (x) (or (eqv? x 0.0) (eqv? x 3.14))) flonum? real? number?))
   (test-chain* '((lambda (x) (or (eq? x 0) (eqv? x 3.14))) real? number?))
   (test-chain '(gensym? symbol?))
+  (test-chain '((lambda (x) (eq? x 'banana)) symbol?))
   (test-chain '(not boolean?))
   (test-chain '((lambda (x) (eq? x #t)) boolean?))
   (test-chain* '(record? #3%$record?))
@@ -594,6 +601,7 @@
   (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x))))
   (test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?))
   (test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?))
+  (test-disjoint '((lambda (x) (eq? x 'banana)) (lambda (x) (eq? x 'apple))))
   (test-disjoint* '(list? record? vector?))
   (not (test-disjoint* '(list? null?)))
   (not (test-disjoint* '(list? pair?)))
diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss
index ab0fd71770..8e09679e40 100644
--- a/racket/src/ChezScheme/s/cptypes.ss
+++ b/racket/src/ChezScheme/s/cptypes.ss
@@ -826,10 +826,44 @@ Notes:
             [(_ id) (or (lookup #'id #'get-type-key)
                         ($oops 'get-type "invalid identifier ~s" #'id))])))
 
+      (define (try-compare-constants e1 e2 prim-name)
+        ; yes     => true-rec
+        ; no      => false-rec
+        ; unknown => #f
+        (and (Lsrc? e1)
+             (Lsrc? e2)
+             (nanopass-case (Lsrc Expr) e1
+               [(quote ,d1)
+                (nanopass-case (Lsrc Expr) e2
+                  [(quote ,d2)
+                   (cond
+                     [(eqv? d1 d2)
+                      (cond
+                        [(eq? prim-name 'eq?)
+                         (cond
+                           [(or (not (number? d1))
+                                ; To avoid problems with cross compilation and eq?-ness
+                                ; ensure that it's a fixnum in both machines.
+                                (and (fixnum? d1)
+                                     (target-fixnum? d1)))
+                            true-rec]
+                           [else
+                            #f])]
+                        [else
+                         true-rec])]
+                     [else
+                      false-rec])]
+                  [else #f])]
+               [else #f])))
+
       (define-specialize 2 (eq? eqv?)
         [(e1 e2) (let ([r1 (get-type e1)]
                        [r2 (get-type e2)])
                     (cond
+                      [(try-compare-constants r1 r2 prim-name)
+                       => (lambda (ret)
+                            (values (make-seq ctxt e1 e2 ret)
+                                    ret ntypes #f #f))]
                       [(predicate-disjoint? r2 r1)
                        (values (make-seq ctxt e1 e2 false-rec)
                                false-rec ntypes #f #f)]