suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Chez Scheme: improve eq[v]? reductions in cptypes

Browse Source 
Improve eq? and eq? handling to reduce expressions like
(eq? (newline) (void)) => (begin (newline) #t)
This commit is contained in:
Gustavo Massaccesi 2021-03-22 12:18:37 -03:00
parent 355b9f51be
commit 61cca93086
3 changed files with 45 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -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

10
racket/src/ChezScheme/mats/cptypes.ms
View File

@ -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?)))

34
racket/src/ChezScheme/s/cptypes.ss
View File

@ -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)]