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

Chez Scheme: add maybe-char to cptypes

Browse Source 
chars are immediates, so the previous change doesn't add automatically
the combinations like maybe-char. Add also eof/char that is commonly
used and has the same problem.

And rename in ctypes the internal symbol $immediate/true to
true-immediate because in all the other instances / is used for unions.
This commit is contained in:
Gustavo Massaccesi 2021-03-06 21:57:45 -03:00
parent 8ba89cbd2a
commit 3d04b71ced
3 changed files with 138 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1191,9 +1191,18 @@
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(lambda (x) (when (or (not x) (vector? x)) (when x (vector? x)))) '(lambda (x) (when (or (not x) (vector? x)) (when x (vector? x))))
'(lambda (x) (when (or (not x) (vector? x)) (when x #t)))) '(lambda (x) (when (or (not x) (vector? x)) (when x #t))))
(cptypes-equivalent-expansion?
'(lambda (x) (when (or (not x) (char? x)) (when x (char? x))))
'(lambda (x) (when (or (not x) (char? x)) (when x #t))))
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(lambda (s) (define x (string->number s)) (when x (number? x))) '(lambda (s) (define x (string->number s)) (when x (number? x)))
'(lambda (s) (define x (string->number s)) (when x #t))) '(lambda (s) (define x (string->number s)) (when x #t)))
(cptypes-equivalent-expansion?
'(lambda (p) (define x (get-char p)) (not x))
'(lambda (p) (define x (get-char p)) #f))
(cptypes-equivalent-expansion?
'(lambda (p) (define x (get-char p)) (box? x))
'(lambda (p) (define x (get-char p)) #f))
) )
(mat cptypes-unreachable (mat cptypes-unreachable

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

@ -30,6 +30,9 @@
(module cptypes-lattice (module cptypes-lattice
(primref-name/nqm->predicate (primref-name/nqm->predicate
ptr-pred ptr-pred
eof/char-pred
maybe-char-pred
maybe-symbol-pred
$fixmediate-pred $fixmediate-pred
true-pred ; anything that is not #f true-pred ; anything that is not #f
true-rec ; only the #t object true-rec ; only the #t object
@ -70,18 +73,22 @@
(define eof-rec `(quote #!eof)) (define eof-rec `(quote #!eof))
(define bwp-rec `(quote #!bwp))) (define bwp-rec `(quote #!bwp)))
(define true-pred (make-pred-or '$immediate/true 'normalptr '$record)) (define true-pred (make-pred-or 'true-immediate 'normalptr '$record))
(define ptr-pred (make-pred-or '$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 null-or-pair-pred (make-pred-or null-rec 'pair 'bottom))
(define $fixmediate-pred (make-pred-or '$immediate 'fixnum 'bottom)) (define $fixmediate-pred (make-pred-or 'immediate 'fixnum 'bottom))
(define maybe-number-pred (make-pred-or false-rec 'number 'bottom)) (define maybe-number-pred (make-pred-or false-rec 'number 'bottom))
(define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom)) (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom))
(define maybe-symbol-pred (make-pred-or false-rec 'symbol 'bottom))
; These are just symbols, but we assign a name for uniformity.
(define maybe-char-pred 'maybe-char)
(define eof/char-pred 'eof/char)
; This can be implemented with implies? ; This can be implemented with implies?
; but let's use the straightforward test. ; but let's use the straightforward test.
(define (predicate-is-ptr? x) (define (predicate-is-ptr? x)
(and (pred-or? x) (and (pred-or? x)
(eq? (pred-or-imm x) '$immediate) (eq? (pred-or-imm x) 'immediate)
(eq? (pred-or-nor x) 'normalptr) (eq? (pred-or-nor x) 'normalptr)
(eq? (pred-or-rec x) '$record))) (eq? (pred-or-rec x) '$record)))
@ -116,7 +123,7 @@
(eq? x (vector-ref ay (fx- lx 1))))))) (eq? x (vector-ref ay (fx- lx 1)))))))
;includes the case when they are the same ;includes the case when they are the same
;or when one is the ancester of the other ;or when one is the ancestor of the other
(define (rdt-last-common-ancestor* x y) (define (rdt-last-common-ancestor* x y)
(cond (cond
[(eq? x y) x] [(eq? x y) x]
@ -198,12 +205,15 @@
[null null-rec] [null null-rec]
[eof-object eof-rec] [eof-object eof-rec]
[bwp-object bwp-rec] [bwp-object bwp-rec]
[$immediate '$immediate] [$immediate 'immediate]
[(list list-assume-immutable) (if (not extend?) null-rec null-or-pair-pred)] [(list list-assume-immutable) (if (not extend?) null-rec null-or-pair-pred)]
[sub-ptr (if (not extend?) 'bottom ptr-pred)] [sub-ptr (if (not extend?) 'bottom ptr-pred)]
[maybe-number maybe-number-pred] [maybe-number maybe-number-pred]
[maybe-fixnum maybe-fixnum-pred] [maybe-fixnum maybe-fixnum-pred]
[maybe-ufixnum (if (not extend?) false-rec maybe-fixnum-pred)] [maybe-ufixnum (if (not extend?) false-rec maybe-fixnum-pred)]
[maybe-symbol maybe-symbol-pred]
[maybe-char 'maybe-char]
[eof/char 'eof/char]
[else ((if extend? cdr car) [else ((if extend? cdr car)
(case name (case name
[(record rtd) '(bottom . $record)] [(record rtd) '(bottom . $record)]
@ -249,23 +259,24 @@
(not (gensym? x)) (not (gensym? x))
(not (uninterned-symbol? x)))) (not (uninterned-symbol? x))))
;only false-rec, boolean and $immediate may be '#f ;only false-rec, boolean, maybe-char and immediate may be '#f
;use when the other argument is truthy bur not exactly '#t ;use when the other argument is truthy bur not exactly '#t
(define (union/true x) (define (union/true x)
(cond (cond
[(or (eq? x 'boolean) [(or (eq? x 'boolean)
(eq? x 'maybe-char)
(check-constant-eqv? x #f)) (check-constant-eqv? x #f))
'$immediate] 'immediate]
[else [else
'$immediate/true])) 'true-immediate]))
(define (predicate-union/immediate x y) (define (predicate-union/immediate x y)
(cond (cond
[(eq? x y) y] [(eq? x y) y]
[(eq? x 'bottom) y] [(eq? x 'bottom) y]
[(eq? y 'bottom) x] [(eq? y 'bottom) x]
[(eq? y '$immediate) y] [(eq? y 'immediate) y]
[(eq? x '$immediate) x] [(eq? x 'immediate) x]
[(Lsrc? y) [(Lsrc? y)
(nanopass-case (Lsrc Expr) y (nanopass-case (Lsrc Expr) y
[(quote ,d1) [(quote ,d1)
@ -278,20 +289,40 @@
[(or (eq? x 'boolean) [(or (eq? x 'boolean)
(check-constant-eqv? x #t)) (check-constant-eqv? x #t))
'boolean] 'boolean]
[(or (eq? x 'char)
(eq? x 'maybe-char)
(check-constant-is? x char?))
'maybe-char]
[else [else
'$immediate])] 'immediate])]
[(eq? dy #t) [(eq? dy #t)
(cond (cond
[(or (eq? x 'boolean) [(or (eq? x 'boolean)
(check-constant-eqv? x #f)) (check-constant-eqv? x #f))
'boolean] 'boolean]
[(eq? x 'maybe-char)
'immediate]
[else [else
'$immediate/true])] 'true-immediate])]
[(char? dy) [(char? dy)
(cond (cond
[(or (eq? x 'char) [(or (eq? x 'char)
(check-constant-is? x char?)) (check-constant-is? x char?))
'char] 'char]
[(or (eq? x 'maybe-char)
(check-constant-eqv? x #f))
'maybe-char]
[(or (eq? x 'eof/char)
(check-constant-is? x eof-object?))
'eof/char]
[else
(union/true x)])]
[(eof-object? dy)
(cond
[(or (eq? x 'eof/char)
(eq? x 'char)
(check-constant-is? x char?))
'eof/char]
[else [else
(union/true x)])] (union/true x)])]
[else [else
@ -303,13 +334,35 @@
[(check-constant-is? x boolean?) [(check-constant-is? x boolean?)
y] y]
[else [else
'$immediate])] 'immediate])]
[(char) [(char)
(cond (cond
[(or (eq? x 'maybe-char)
(check-constant-eqv? x #f))
'maybe-char]
[(or (eq? x 'eof/char)
(check-constant-is? x eof-object?))
'eof/char]
[(check-constant-is? x char?) [(check-constant-is? x char?)
y] y]
[else [else
(union/true x)])] (union/true x)])]
[(eof/char)
(cond
[(or (eq? x 'char)
(check-constant-is? x char?)
(check-constant-is? x eof-object?))
y]
[else
(union/true x)])]
[(maybe-char)
(cond
[(or (eq? x 'char)
(check-constant-is? x char?)
(check-constant-eqv? x #f))
y]
[else
'immediate])]
[else [else
(union/true x)])])) (union/true x)])]))
@ -534,7 +587,7 @@
(define (intersect/true x y) (define (intersect/true x y)
(cond (cond
[(eq? x '$immediate/true) [(eq? x 'true-immediate)
y] y]
[else [else
'bottom])) 'bottom]))
@ -544,8 +597,8 @@
[(eq? x y) x] [(eq? x y) x]
[(eq? y 'bottom) 'bottom] [(eq? y 'bottom) 'bottom]
[(eq? x 'bottom) 'bottom] [(eq? x 'bottom) 'bottom]
[(eq? y '$immediate) x] [(eq? y 'immediate) x]
[(eq? x '$immediate) y] [(eq? x 'immediate) y]
[(Lsrc? y) [(Lsrc? y)
(nanopass-case (Lsrc Expr) y (nanopass-case (Lsrc Expr) y
[(quote ,d1) [(quote ,d1)
@ -555,7 +608,8 @@
x] x]
[(not dy) [(not dy)
(cond (cond
[(eq? x 'boolean) [(or (eq? x 'boolean)
(eq? x 'maybe-char))
y] y]
[else [else
'bottom])] 'bottom])]
@ -567,7 +621,15 @@
(intersect/true x y)])] (intersect/true x y)])]
[(char? dy) [(char? dy)
(cond (cond
[(eq? x 'char) [(or (eq? x 'char)
(eq? x 'maybe-char)
(eq? x 'eof/char))
y]
[else
(intersect/true x y)])]
[(eof-object? dy)
(cond
[(eq? x 'eof/char)
y] y]
[else [else
(intersect/true x y)])] (intersect/true x y)])]
@ -577,26 +639,56 @@
(case y (case y
[(boolean) [(boolean)
(cond (cond
[(eq? x '$immediate/true) [(eq? x 'true-immediate)
true-rec] true-rec]
[(eq? x 'maybe-char)
false-rec]
[(check-constant-is? x boolean?) [(check-constant-is? x boolean?)
x] x]
[else [else
'bottom])] 'bottom])]
[($immediate/true) [(true-immediate)
(cond (cond
[(eq? x 'boolean) [(eq? x 'boolean)
true-rec] true-rec]
[(eq? x 'maybe-char)
'char]
[(check-constant-eqv? x #f) [(check-constant-eqv? x #f)
'bottom] 'bottom]
[else [else
x])] x])]
[(char) [(char)
(cond (cond
[(or (eq? x 'maybe-char)
(eq? x 'eof/char))
y]
[(check-constant-is? x char?) [(check-constant-is? x char?)
x] x]
[else [else
(intersect/true x y)])] (intersect/true x y)])]
[(eof/char)
(cond
[(eq? x 'maybe-char)
'char]
[(or (eq? x 'char)
(check-constant-is? x char?)
(check-constant-is? x eof-object?))
x]
[else
(intersect/true x y)])]
[(maybe-char)
(cond
[(or (eq? x 'eof/char)
(eq? x 'true-immediate))
'char]
[(or (eq? x 'char)
(check-constant-is? x char?)
(check-constant-eqv? x #f))
x]
[(eq? x 'boolean)
false-rec]
[else
'bottom])]
[else [else
(intersect/true x y)])])) (intersect/true x y)])]))
@ -839,8 +931,8 @@
(cond (cond
#;[(eq? x 'bottom) 'bottom] #;[(eq? x 'bottom) 'bottom]
[(or (check-constant-is? x $immediate?) [(or (check-constant-is? x $immediate?)
(memq x '(boolean char $immediate/true $immediate))) (memq x '(boolean char maybe-char eof/char true-immediate immediate)))
'$immediate] 'immediate]
[(or (eq? x '$record) [(or (eq? x '$record)
(pred-$record/rtd? x) (pred-$record/rtd? x)
(pred-$record/ref? x)) (pred-$record/ref? x))
@ -893,7 +985,7 @@
(build-pred-or i n r y x))] (build-pred-or i n r y x))]
[(pred-or? x) [(pred-or? x)
(case (predicate->class y) (case (predicate->class y)
[($immediate) [(immediate)
(build-pred-or (predicate-union/immediate (pred-or-imm x) y) (build-pred-or (predicate-union/immediate (pred-or-imm x) y)
(pred-or-nor x) (pred-or-nor x)
(pred-or-rec x) (pred-or-rec x)
@ -910,7 +1002,7 @@
x)])] x)])]
[(pred-or? y) [(pred-or? y)
(case (predicate->class x) (case (predicate->class x)
[($immediate) [(immediate)
(build-pred-or (predicate-union/immediate x (pred-or-imm y)) (build-pred-or (predicate-union/immediate x (pred-or-imm y))
(pred-or-nor y) (pred-or-nor y)
(pred-or-rec y) (pred-or-rec y)
@ -932,7 +1024,7 @@
(cond (cond
[(eq? cx cy) [(eq? cx cy)
(case cx (case cx
[($immediate) [(immediate)
(predicate-union/immediate x y)] (predicate-union/immediate x y)]
[(normalptr) [(normalptr)
(predicate-union/normal x y)] (predicate-union/normal x y)]
@ -941,8 +1033,8 @@
[else [else
(let () (let ()
(define i (cond (define i (cond
[(eq? cx '$immediate) x] [(eq? cx 'immediate) x]
[(eq? cy '$immediate) y] [(eq? cy 'immediate) y]
[else 'bottom])) [else 'bottom]))
(define n (cond (define n (cond
[(eq? cx 'normalptr) x] [(eq? cx 'normalptr) x]
@ -974,7 +1066,7 @@
(build-pred-or i n r x y))] (build-pred-or i n r x y))]
[(pred-or? x) [(pred-or? x)
(case (predicate->class y) (case (predicate->class y)
[($immediate) [(immediate)
(predicate-intersect/immediate (pred-or-imm x) y)] (predicate-intersect/immediate (pred-or-imm x) y)]
[(normalptr) [(normalptr)
(predicate-intersect/normal (pred-or-nor x) y)] (predicate-intersect/normal (pred-or-nor x) y)]
@ -982,7 +1074,7 @@
(predicate-intersect/record (pred-or-rec x) y)])] (predicate-intersect/record (pred-or-rec x) y)])]
[(pred-or? y) [(pred-or? y)
(case (predicate->class x) (case (predicate->class x)
[($immediate) [(immediate)
(predicate-intersect/immediate x (pred-or-imm y))] (predicate-intersect/immediate x (pred-or-imm y))]
[(normalptr) [(normalptr)
(predicate-intersect/normal x (pred-or-nor y))] (predicate-intersect/normal x (pred-or-nor y))]
@ -997,7 +1089,7 @@
'bottom] 'bottom]
[else [else
(case cx (case cx
[($immediate) [(immediate)
(predicate-intersect/immediate x y)] (predicate-intersect/immediate x y)]
[(normalptr) [(normalptr)
(predicate-intersect/normal x y)] (predicate-intersect/normal x y)]

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

@ -998,27 +998,27 @@ Notes:
[ir `(call ,preinfo ,pr ,n)]) [ir `(call ,preinfo ,pr ,n)])
(cond (cond
[(predicate-implies? r 'char) [(predicate-implies? r 'char)
(values ir ptr-pred ntypes #f #f)] ; should be maybe-symbol (values ir maybe-symbol-pred ntypes #f #f)]
[(predicate-implies? r 'symbol) [(predicate-implies? r 'symbol)
(values ir ptr-pred ntypes #f #f)] ; should be maybe-char (values ir maybe-char-pred ntypes #f #f)]
[(and (predicate-disjoint? r 'char) [(and (predicate-disjoint? r 'char)
(predicate-disjoint? r 'symbol)) (predicate-disjoint? r 'symbol))
(values ir 'bottom pred-env-bottom #f #f)] (values ir 'bottom pred-env-bottom #f #f)]
[else [else
(values ir ptr-pred ; should be maybe-(union 'char 'symbol) (values ir (predicate-union maybe-char-pred 'symbol)
(pred-env-add/ref ntypes n true-pred plxc) #f #f)]))] ; should be (union 'char 'symbol) (pred-env-add/ref ntypes n (predicate-union 'char 'symbol) plxc) #f #f)]))]
[(n c) (let ([rn (get-type n)] [(n c) (let ([rn (get-type n)]
[rc (get-type c)] [rc (get-type c)]
[ir `(call ,preinfo ,pr ,n ,c)]) [ir `(call ,preinfo ,pr ,n ,c)])
(cond (cond
[(or (predicate-disjoint? rn 'symbol) [(or (predicate-disjoint? rn 'symbol)
(predicate-disjoint? rc ptr-pred)) ; should be maybe-char (predicate-disjoint? rc maybe-char-pred))
(values ir 'bottom pred-env-bottom #f #f)] (values ir 'bottom pred-env-bottom #f #f)]
[else [else
(values ir void-rec (values ir void-rec
(pred-env-add/ref (pred-env-add/ref ntypes (pred-env-add/ref (pred-env-add/ref ntypes
n 'symbol plxc) n 'symbol plxc)
c ptr-pred plxc) ; should be maybe-char c maybe-char-pred plxc)
#f #f)]))]) #f #f)]))])
(define-specialize/unrestricted 2 call-with-values (define-specialize/unrestricted 2 call-with-values