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

Chez Scheme: add suport for lists in cptypes

Browse Source 
With list-assuming-immutable? and the internal construct
immutable-list the compiler can assume that some lists will
not be mutated.

Also, change the definition of interned-char?, because in CS all chars
are interned.
This commit is contained in:
Gustavo Massaccesi 2021-03-15 14:21:33 -03:00
parent 993b86ffa3
commit 3952355d30
7 changed files with 87 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -540,7 +540,7 @@
(test #t k:interned-char? #\()
(test #t k:interned-char? #\ )
(test #t k:interned-char? '#\newline)
(test #f k:interned-char? #\u100)
(test (not (eq? 'chez-scheme (system-type 'vm))) k:interned-char? #\u100)
(test #f k:interned-char? 7)
(test #f k:interned-char? #t)
(test #f k:interned-char? #t)

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

@ -2680,6 +2680,10 @@
(let ([test-implies
(lambda (pred1 pred2 [val '=>])
(test-comp `(lambda (z) (when (,pred1 z) (,pred1 z)))
`(lambda (z) (when (,pred1 z) #t)))
(test-comp `(lambda (z) (when (,pred2 z) (,pred2 z)))
`(lambda (z) (when (,pred2 z) #t)))
(cond
[(eq? val '=>)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
@ -2690,6 +2694,11 @@
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #f))
#f)]
[(eq? val '=)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #t)))
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #t)))]
[(eq? val '!=)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #f)))
@ -2714,17 +2723,15 @@
(test-implies 'null? 'k:list-pair? '!=)
(test-implies 'null? 'pair? '!=)
(test-implies 'null? 'list?)
(unless (eq? 'chez-scheme (system-type 'vm))
(test-implies 'k:list-pair? 'pair?)
(test-implies 'k:list-pair? 'list?))
(test-implies 'k:list-pair? 'pair?)
(test-implies 'k:list-pair? 'list?)
(test-implies 'list? 'pair? '?)
(test-implies 'k:interned-char? 'char?)
(test-implies 'k:interned-char? 'char? (if (eq? 'chez-scheme (system-type 'vm)) '= '=>))
(test-implies 'not 'boolean?)
(test-implies 'k:true-object? 'boolean?)
)
(test-comp #:except 'chez-scheme ; list-pair? is not primitive enough for cptypes
'(lambda (z)
(test-comp '(lambda (z)
(when (and (list? z)
(pair? z))
(k:list-pair? z)))
@ -2787,20 +2794,20 @@
`(let ([e ,expr])
(list ',pred-name e e ,val))))])
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?`
(test-reduce 'list? 0 #f)
(test-reduce 'list? ''())
(test-reduce 'list? ''(1))
(test-reduce 'list? ''(1 2))
#;(test-reduce 'list? ''(1 . 2) #f)
(test-reduce 'list? 0 #f)
(test-reduce 'list? ''())
(test-reduce 'list? ''(1))
(test-reduce 'list? ''(1 2))
#;(test-reduce 'list? ''(1 . 2) #f)
(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet consider (list ...) as immutable
(test-reduce 'list? '(list))
(test-reduce 'list? '(list 1))
(test-reduce 'list? '(list 1 2))
#;(test-reduce 'list? '(cons 1 2) #f)
(test-reduce 'list? '(cons 1 null))
(test-reduce 'list? '(cons 1 (list 2 3)))
(test-reduce 'list? '(cdr (list 1 2)))
(test-reduce 'list? '(cdr (list 1))))
(test-reduce 'list? '(cdr (list 1 2))))
(test-reduce 'list? '(cdr (list 1)))
(test-reduce 'null? 0 #f)
(test-reduce 'null? ''())

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

@ -210,6 +210,18 @@
(cptypes-equivalent-expansion?
'(lambda (x) (when (and (fixnum? x) (zero? x)) x))
'(lambda (x) (when (and (fixnum? x) (zero? x)) 0)))
(cptypes-equivalent-expansion?
'(lambda (x f) (when (list-assuming-immutable? x) (f x) (list-assuming-immutable? x)))
'(lambda (x f) (when (list-assuming-immutable? x) (f x) #t)))
(not (cptypes-equivalent-expansion?
'(lambda (x f) (when (list? x) (f x) (unless (list? x) 1)))
'(lambda (x f) (when (list? x) (f x) (unless (list? x) 2)))))
(cptypes-equivalent-expansion?
'(lambda (f) (define x '(1 2 3)) (f x) (list-assuming-immutable? x))
'(lambda (f) (define x '(1 2 3)) (f x) #t))
(cptypes-equivalent-expansion?
'(lambda () (define x '(1 2 3)) (pair? x))
'(lambda () (define x '(1 2 3)) #t))
)
(mat cptypes-type-if
@ -572,6 +584,7 @@
(test-chain* '(record? #3%$record?))
(test-chain* '((lambda (x) (eq? x car)) procedure?))
(test-chain* '(record-type-descriptor? #3%$record?))
(test-chain* '(null? list-assuming-immutable? list? #;(lambda (x) (or (null? x) (pair? x)))))
(test-disjoint '(pair? box? #3%$record? number?
vector? string? bytevector? fxvector? symbol?
char? boolean? null? (lambda (x) (eq? x (void)))
@ -584,6 +597,9 @@
(test-disjoint* '(list? record? vector?))
(not (test-disjoint* '(list? null?)))
(not (test-disjoint* '(list? pair?)))
(not (test-disjoint* '(list-assuming-immutable? null?)))
(not (test-disjoint* '(list-assuming-immutable? pair?)))
(not (test-disjoint* '(list-assuming-immutable? list?)))
)
; use a gensym to make expansions equivalent
@ -710,6 +726,21 @@
(lambda (x) #f))))
)
(mat cptypes-lists
(cptypes-equivalent-expansion?
'(lambda (x) (when (list-assuming-immutable? x) (list? (cdr x))))
'(lambda (x) (when (list-assuming-immutable? x) (cdr x) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) (list? (cdr x))))
'(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) #t)))
(cptypes-equivalent-expansion?
'(lambda (x) (when (list-assuming-immutable? x) (list? (cdr (error 'e "")))))
'(lambda (x) (when (list-assuming-immutable? x) (error 'e ""))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (vector? x) (list? (#2%cdr x)) 1))
'(lambda (x) (when (vector? x) (#2%cdr x))))
)
(mat cptypes-unsafe
(cptypes-equivalent-expansion?
'(lambda (x) (when (pair? x) (car x)))

19
racket/src/ChezScheme/s/cptypes-lattice.ss
View File

@ -34,6 +34,7 @@
maybe-char-pred
maybe-symbol-pred
$fixmediate-pred
$list-pred ; immutable lists
true-pred ; anything that is not #f
true-rec ; only the #t object
false-rec
@ -76,6 +77,7 @@
(define true-pred (make-pred-or 'true-immediate 'normalptr '$record))
(define ptr-pred (make-pred-or 'immediate 'normalptr '$record))
(define null-or-pair-pred (make-pred-or null-rec 'pair 'bottom))
(define $list-pred (make-pred-or null-rec '$list-pair 'bottom))
(define $fixmediate-pred (make-pred-or 'immediate 'fixnum 'bottom))
(define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom))
(define eof/fixnum-pred (make-pred-or eof-rec 'fixnum 'bottom))
@ -214,7 +216,8 @@
[pair 'pair]
[maybe-pair maybe-pair-pred]
[(list list-assume-immutable) (cons null-rec null-or-pair-pred)]
[list (cons $list-pred null-or-pair-pred)]
[list-assuming-immutable $list-pred]
[box 'box]
[vector 'vector]
[string 'string]
@ -568,6 +571,13 @@
(union/symbol x interned-symbol? 'interned-symbol)]
[(symbol)
(union/symbol x symbol? 'symbol)]
[(pair $list-pair)
(cond
[(or (eq? x 'pair)
(eq? x '$list-pair))
'pair]
[else
'normalptr])]
[(vector) (union/simple x vector? y)]; i.e. #()
[(string) (union/simple x string? y)]; i.e. ""
[(bytevector) (union/simple x bytevector? y)] ; i.e. '#vu8()
@ -886,6 +896,13 @@
x]
[else
'bottom])]
[(pair $list-pair)
(cond
[(or (eq? x 'pair)
(eq? x '$list-pair))
'$list-pair]
[else
'bottom])]
[(vector) (intersect/simple x vector? 'vector y)]; i.e. #()
[(string) (intersect/simple x string? 'string y)]; i.e. ""
[(bytevector) (intersect/simple x bytevector? 'bytevector y)] ; i.e. '#vu8()

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

@ -530,6 +530,7 @@ Notes:
[(#3%$record? d) '$record] ;check first to avoid double representation of rtd
[(okay-to-copy? d) ir]
[(and (integer? d) (exact? d)) 'exact-integer]
[(list? d) '$list-pair] ; quoted list should not be modified.
[(pair? d) 'pair]
[(box? d) 'box]
[(vector? d) 'vector]
@ -846,6 +847,17 @@ Notes:
[() (values null-rec null-rec ntypes #f #f)] ; should have been reduced by cp0
[e* (values `(call ,preinfo ,pr ,e* ...) 'pair ntypes #f #f)])
(define-specialize 2 cdr
[(v) (values `(call ,preinfo ,pr ,v)
(cond
[(predicate-implies? ret 'bottom)
ret]
[(predicate-implies? (predicate-intersect (get-type v) 'pair) '$list-pair)
$list-pred]
[else
ptr-pred])
ntypes #f #f)])
(define-specialize 2 $record
[(rtd . e*) (values `(call ,preinfo ,pr ,rtd ,e* ...) (rtd->record-predicate rtd #t) ntypes #f #f)])
@ -1634,7 +1646,7 @@ Notes:
[(immutable-list (,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...)
,[e 'value types plxc -> e ret types t-types f-types])
(values `(immutable-list (,e* ...) ,e)
ret types #f #f)]
(if (null? e*) null-rec '$list-pair) types #f #f)]
[(moi) (values ir #f types #f #f)]
[(pariah) (values ir void-rec types #f #f)]
[(cte-optimization-loc ,box ,[e 'value types plxc -> e ret types t-types f-types] ,exts)

2
racket/src/ChezScheme/s/primdata.ss
View File

@ -257,7 +257,7 @@
(cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs])
; c..r non-alphabetic so marks come before references
(car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
(cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
(cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 cptypes2 safeongoodargs ieee r5rs])
(caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs])
(cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs])
(cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs])

2
racket/src/cs/rumble/char.ss
View File

@ -29,7 +29,7 @@
(and (#%memq (#%char-general-category x) '(Sm Sc Sk So)) #t))
(define (interned-char? v)
(and (char? v) (< (char->integer v) 256)))
(char? v))
(define (char-general-category ch)
(or (with-global-lock* (getprop (#%char-general-category ch) 'downcase #f))