diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms index 594a02cf8a..f8bd28d06c 100644 --- a/racket/src/ChezScheme/mats/cptypes.ms +++ b/racket/src/ChezScheme/mats/cptypes.ms @@ -1178,4 +1178,20 @@ (loop (fx+ i 1)))))) (cptypes-equivalent-expansion? '(lambda (x y) (set-box! x (if (vector? y) #t (error 't)))) - '(lambda (x y) (set-box! x (#3%$fixmediate (if (vector? y) #t (error 't))))))) + '(lambda (x y) (set-box! x (#3%$fixmediate (if (vector? y) #t (error 't)))))) +) + +(mat cptypes-maybe + (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (vector? x)) (box? x))) + '(lambda (x) (when (or (not x) (vector? x)) #f))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (vector? x)) (vector? x))) + '(lambda (x) (when (or (not x) (vector? x)) #t)))) + (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 #t)))) + (cptypes-equivalent-expansion? + '(lambda (s) (define x (string->number s)) (when x (number? x))) + '(lambda (s) (define x (string->number s)) (when x #t))) +) diff --git a/racket/src/ChezScheme/s/cptypes-lattice.ss b/racket/src/ChezScheme/s/cptypes-lattice.ss index c05038764e..c7b82e37ab 100644 --- a/racket/src/ChezScheme/s/cptypes-lattice.ss +++ b/racket/src/ChezScheme/s/cptypes-lattice.ss @@ -28,21 +28,28 @@ ; remember to check (implies? x bottom) before (implies? x something) (module cptypes-lattice - (predicate-implies? + (primref-name/nqm->predicate + ptr-pred + $fixmediate-pred + true-pred ; anything that is not #f + true-rec ; only the #t object + false-rec + void-rec + null-rec + eof-rec + bwp-rec + predicate-is-ptr? + predicate-implies? predicate-disjoint? predicate-intersect predicate-union make-pred-$record/rtd make-pred-$record/ref) - (include "base-lang.ss") - (with-output-language (Lsrc Expr) - (define true-rec `(quote #t))) - - ; don't use rtd-* as defined in record.ss in case we're building a patch - ; file for cross compilation, because the offsets may be incorrect - (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) - (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) + (define-record-type pred-or + (fields imm nor rec) + (nongenerative #{pred-or nlomo7xtc1nguv2umpzwho0dt-0}) + (sealed #t)) (define-record-type pred-$record/rtd (fields rtd) @@ -54,6 +61,35 @@ (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-1}) (sealed #t)) + (include "base-lang.ss") + (with-output-language (Lsrc Expr) + (define void-rec `(quote ,(void))) + (define true-rec `(quote #t)) + (define false-rec `(quote #f)) + (define null-rec `(quote ())) + (define eof-rec `(quote #!eof)) + (define bwp-rec `(quote #!bwp))) + + (define true-pred (make-pred-or '$immediate/true 'normalptr '$record)) + (define ptr-pred (make-pred-or '$immediate 'normalptr '$record)) + (define null-or-pair-pred (make-pred-or null-rec 'pair 'bottom)) + (define $fixmediate-pred (make-pred-or '$immediate 'fixnum 'bottom)) + (define maybe-number-pred (make-pred-or false-rec 'number 'bottom)) + (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom)) + + ; This can be implemented with implies? + ; but let's use the straightforward test. + (define (predicate-is-ptr? x) + (and (pred-or? x) + (eq? (pred-or-imm x) '$immediate) + (eq? (pred-or-nor x) 'normalptr) + (eq? (pred-or-rec x) '$record))) + + ; don't use rtd-* as defined in record.ss in case we're building a patch + ; file for cross compilation, because the offsets may be incorrect + (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) + ;could be a ctrtd (define (pred-$record-maybe-rtd x) (cond @@ -67,152 +103,8 @@ (or (and (fixnum? x-flds) (not (fixnum? y-flds))) (and (not (fixnum? x-flds)) (fixnum? y-flds))))) - (define (check-constant-is? x pred?) - (and (Lsrc? x) - (nanopass-case (Lsrc Expr) x - [(quote ,d) (pred? d)] - [else #f]))) - - (define (check-constant-eqv? x v) - (and (Lsrc? x) - (nanopass-case (Lsrc Expr) x - [(quote ,d) (eqv? d v)] - [else #f]))) - - ;only false-rec, boolean and ptr may be '#f - ;use when the other argument is truthy bur not exactly '#t - (define (union/true x) - (cond - [(or (eq? x 'boolean) - (check-constant-eqv? x #f)) - 'ptr] - [else - 'true])) - - (define (union/simple x pred? y) - (cond - [(or (check-constant-is? x pred?) - (eq? x y)) - y] - [else - (union/true x)])) - - (define (union/symbol x pred? y) - (cond - [(or (check-constant-is? x pred?) - (eq? x y)) - y] - [(or (eq? x 'gensym) - (eq? x 'interned-symbol) - (eq? x 'uninterned-symbol) - (eq? x 'symbol) - (check-constant-is? x symbol?)) - 'symbol] - [else - (union/true x)])) - - (define (union/record x) - (cond - [(or (pred-$record/rtd? x) - (pred-$record/ref? x) - (eq? x '$record)) - '$record] - [else - (union/true x)])) - - (define (union/fixnum x) - (cond - [(check-constant-is? x target-fixnum?) - 'fixnum] - [(or (eq? x 'bignum) - (eq? x 'exact-integer) - (check-constant-is? x exact-integer?)) - 'exact-integer] - [(or (eq? x 'flonum) - (eq? x 'real) - (check-constant-is? x real?)) - 'real] - [(or (eq? x 'number) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - - (define (union/bignum x) - (cond - [(check-constant-is? x target-bignum?) - 'bignum] - [(or (eq? x 'fixnum) - (eq? x 'exact-integer) - (check-constant-is? x exact-integer?)) - 'exact-integer] - [(or (eq? x 'flonum) - (eq? x 'real) - (check-constant-is? x real?)) - 'real] - [(or (eq? x 'number) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - - (define (union/exact-integer x) - (cond - [(or (eq? x 'fixnum) - (eq? x 'bignum) - (check-constant-is? x exact-integer?)) - 'exact-integer] - [(or (eq? x 'flonum) - (eq? x 'real) - (check-constant-is? x real?)) - 'real] - [(or (eq? x 'number) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - - (define (union/flonum x) - (cond - [(or (check-constant-is? x flonum?)) - 'flonum] - [(or (eq? x 'real) - (check-constant-is? x real?)) - 'real] - [(or (eq? x 'number) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - - (define (union/real x) - (cond - [(or (eq? x 'fixnum) - (eq? x 'bignum) - (eq? x 'exact-integer) - (eq? x 'flonum) - (check-constant-is? x real?)) - 'real] - [(or (eq? x 'number) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - - (define (union/number x) - (cond - [(or (eq? x 'fixnum) - (eq? x 'bignum) - (eq? x 'exact-integer) - (eq? x 'flonum) - (eq? x 'real) - (check-constant-is? x number?)) - 'number] - [else - (union/true x)])) - ;true when x is an ancestor of y - ;includes the case when the are the same + ;includes the case when they are the same (define (rtd-ancestor*? x y) (or (eq? x y) (let () @@ -223,7 +115,7 @@ (and (fx<= lx ly) (eq? x (vector-ref ay (fx- lx 1))))))) - ;includes the case when the are the same + ;includes the case when they are the same ;or when one is the ancester of the other (define (rdt-last-common-ancestor* x y) (cond @@ -256,6 +148,99 @@ [else (loop lo i)]))]))]))])) + (define (maybe-predicate? name) + (let ([name (symbol->string name)]) + (and (>= (string-length name) 6) + (let loop ([n 0]) + (or (fx= n 6) + (and (eq? (string-ref name n) + (string-ref "maybe-" n)) + (loop (fx+ n 1)))))))) + + ; nqm: no question mark + ; Transform the types used in primdata.ss + ; to the internal representation used here + ; When extend is #f the result is a predicate that recognizes less values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #t and (something x) ==> (#3%something x) + ; When extend is #t the result is a predicate that recognizes more values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #f and (something x) ==> + ; In case the non extended version is not #f, the extended version must be not #f + (define (primref-name/nqm->predicate name extend?) + (case name + [pair 'pair] + [box 'box] + [$record '$record] + [fixnum 'fixnum] + [bignum 'bignum] + [flonum 'flonum] + [real 'real] + [number 'number] + [vector 'vector] + [string 'string] + [bytevector 'bytevector] + [fxvector 'fxvector] + [flvector 'flvector] + [gensym 'gensym] + [uninterned-symbol 'uninterned-symbol] + [interned-symbol 'interned-symbol] + [symbol 'symbol] + [char 'char] + [bottom 'bottom] + [ptr ptr-pred] + [boolean 'boolean] + [true true-pred] + [false false-rec] + [procedure 'procedure] + [exact-integer 'exact-integer] + [void void-rec] + [null null-rec] + [eof-object eof-rec] + [bwp-object bwp-rec] + [$immediate '$immediate] + [(list list-assume-immutable) (if (not extend?) null-rec null-or-pair-pred)] + [sub-ptr (if (not extend?) 'bottom ptr-pred)] + [maybe-number maybe-number-pred] + [maybe-fixnum maybe-fixnum-pred] + [maybe-ufixnum (if (not extend?) false-rec maybe-fixnum-pred)] + [else ((if extend? cdr car) + (case name + [(record rtd) '(bottom . $record)] + [(bit length ufixnum pfixnum) '(bottom . fixnum)] + [(uint sub-uint) '(bottom . exact-integer)] + [(index sub-index u8 s8) '(bottom . fixnum)] + [(sint) '(fixnum . exact-integer)] + [(uinteger) '(bottom . real)] + [(integer rational) '(exact-integer . real)] + [(cflonum) '(flonum . number)] + [else + (cond + [(not name) ; TODO: Move this case to the top? + '(#f . #f)] + [(pair? name) ; TODO: Move this case to the top? + (cond + [(equal? name '(ptr . ptr)) + '(pair . pair)] + [else + '(bottom . pair)])] + [(maybe-predicate? name) + (cons false-rec ptr-pred)] ; for types like maybe-* + [else + (cons 'bottom true-pred)])]))])) ; for all other types that exclude #f + + (define (check-constant-is? x pred?) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (pred? d)] + [else #f]))) + + (define (check-constant-eqv? x v) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (eqv? d v)] + [else #f]))) + (define (exact-integer? x) (and (integer? x) (exact? x))) @@ -264,18 +249,23 @@ (not (gensym? x)) (not (uninterned-symbol? x)))) - ;If x and y are equivalent, they result must be eq? to y - ;so it's easy to test in predicate-implies?. - ;The result may be bigger than the actual union. - (define (predicate-union x y) + ;only false-rec, boolean and $immediate may be '#f + ;use when the other argument is truthy bur not exactly '#t + (define (union/true x) + (cond + [(or (eq? x 'boolean) + (check-constant-eqv? x #f)) + '$immediate] + [else + '$immediate/true])) + + (define (predicate-union/immediate x y) (cond [(eq? x y) y] - [(not x) #f] ;possible a multivalued expression - [(not y) #f] ;possible a multivalued expression [(eq? x 'bottom) y] [(eq? y 'bottom) x] - [(eq? y 'ptr) y] - [(eq? x 'ptr) x] + [(eq? y '$immediate) y] + [(eq? x '$immediate) x] [(Lsrc? y) (nanopass-case (Lsrc Expr) y [(quote ,d1) @@ -289,21 +279,167 @@ (check-constant-eqv? x #t)) 'boolean] [else - 'ptr])] + '$immediate])] [(eq? dy #t) (cond [(or (eq? x 'boolean) (check-constant-eqv? x #f)) 'boolean] [else - 'true])] - [(null? dy) - (cond - [(or (eq? x 'null-or-pair) - (eq? x 'pair)) - 'null-or-pair] + '$immediate/true])] + [(char? dy) + (cond + [(or (eq? x 'char) + (check-constant-is? x char?)) + 'char] [else (union/true x)])] + [else + (union/true x)])])] + [else + (case y + [(boolean) + (cond + [(check-constant-is? x boolean?) + y] + [else + '$immediate])] + [(char) + (cond + [(check-constant-is? x char?) + y] + [else + (union/true x)])] + [else + (union/true x)])])) + + (define (union/simple x pred? y) + (cond + [(or (check-constant-is? x pred?) + (eq? x y)) + y] + [else + 'normalptr])) + + (define (union/symbol x pred? y) + (cond + [(or (check-constant-is? x pred?) + (eq? x y)) + y] + [(or (eq? x 'gensym) + (eq? x 'interned-symbol) + (eq? x 'uninterned-symbol) + (eq? x 'symbol) + (check-constant-is? x symbol?)) + 'symbol] + [else + 'normalptr])) + + (define (union/fixnum x) + (cond + [(check-constant-is? x target-fixnum?) + 'fixnum] + [(or (eq? x 'bignum) + (eq? x 'exact-integer) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/bignum x) + (cond + [(check-constant-is? x target-bignum?) + 'bignum] + [(or (eq? x 'fixnum) + (eq? x 'exact-integer) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/exact-integer x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/flonum x) + (cond + [(or (check-constant-is? x flonum?)) + 'flonum] + [(or (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/real x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/number x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (predicate-union/normal x y) + (cond + [(eq? x y) y] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(eq? y 'normalptr) y] + [(eq? x 'normalptr) x] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + y] [(fixnum? dy) (union/fixnum x)] [(bignum? dy) @@ -319,59 +455,15 @@ [(gensym? dy) (union/symbol x gensym? 'gensym)] [(uninterned-symbol? dy) (union/symbol x uninterned-symbol? 'uninterned-symbol)] [(interned-symbol? dy) (union/symbol x interned-symbol? 'interned-symbol)] - [(char? dy) (union/simple x char? 'char)] [(vector? dy) (union/simple x vector? 'vector)]; i.e. #() [(string? dy) (union/simple x string? 'string)]; i.e. "" [(bytevector? dy) (union/simple x bytevector? 'bytevector)] ; i.e. '#vu8() [(fxvector? dy) (union/simple x fxvector? 'fxvector)] ; i.e. '#vfx() [(flvector? dy) (union/simple x flvector? 'flvector)] ; i.e. '#vfl() [else - (union/true x)])])] - [(pred-$record/rtd? y) - (cond - [(pred-$record/rtd? x) - (let ([x-rtd (pred-$record/rtd-rtd x)] - [y-rtd (pred-$record/rtd-rtd y)]) - (cond - [(eqv? x-rtd y-rtd) - y] - [(record-type-sealed? x-rtd) - (if (rtd-ancestor*? y-rtd x-rtd) y '$record)] - [(record-type-sealed? y-rtd) - (if (rtd-ancestor*? x-rtd y-rtd) x '$record)] - [else - (let ([lca-rtd (rdt-last-common-ancestor* x-rtd y-rtd)]) - (cond - [(not lca-rtd) '$record] - [(eqv? lca-rtd y-rtd) y] - [(eqv? lca-rtd x-rtd) x] - [else (make-pred-$record/rtd lca-rtd)]))]))] - [else (union/record x)])] - [(pred-$record/ref? y) - (cond - [(pred-$record/ref? x) - (if (eq? (pred-$record/ref-ref x) - (pred-$record/ref-ref y)) - y - '$record)] - [else (union/record x)])] + 'normalptr])])] [else (case y - [($record) - (union/record x)] ; y must be the symbol '$record - [(null-or-pair) - (cond - [(or (eq? x 'pair) - (check-constant-eqv? x '())) - y] - [else (union/true x)])] - [(pair) - (cond - [(or (eq? x 'null-or-pair) - (check-constant-eqv? x '())) - 'null-or-pair] - [else - (union/true x)])] [(fixnum) (union/fixnum x)] [(bignum) @@ -392,149 +484,68 @@ (union/symbol x interned-symbol? 'interned-symbol)] [(symbol) (union/symbol x symbol? 'symbol)] - [(boolean) - (cond - [(check-constant-is? x boolean?) - y] - [else - 'ptr])] - [(char) (union/simple x char? y)] [(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() [(fxvector) (union/simple x fxvector? y)] ; i.e. '#vfx() [(flvector) (union/simple x flvector? y)] ; i.e. '#vfl() - [else (union/true x)])])) + [else + 'normalptr])])) - (define (intersect/simple x pred? qpred y) - (cond - [(and pred? (check-constant-is? x pred?)) - x] - [(or (eq? x qpred) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/record x y) + (define (predicate-union/record x y) (cond - [(or (pred-$record/ref? x) - (pred-$record/rtd? x)) - x] - [(or (eq? x '$record) - (eq? x 'true)) + [(eq? x y) y] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(eq? y '$record) y] + [(eq? x '$record) x] + [(pred-$record/rtd? y) + (cond + [(pred-$record/rtd? x) + (let ([x-rtd (pred-$record/rtd-rtd x)] + [y-rtd (pred-$record/rtd-rtd y)]) + (cond + [(eqv? x-rtd y-rtd) + y] + [(record-type-sealed? x-rtd) + (if (rtd-ancestor*? y-rtd x-rtd) y '$record)] + [(record-type-sealed? y-rtd) + (if (rtd-ancestor*? x-rtd y-rtd) x '$record)] + [else + (let ([lca-rtd (rdt-last-common-ancestor* x-rtd y-rtd)]) + (cond + [(not lca-rtd) '$record] + [(eqv? lca-rtd y-rtd) y] + [(eqv? lca-rtd x-rtd) x] + [else (make-pred-$record/rtd lca-rtd)]))]))] + [else + '$record])] + [(pred-$record/ref? y) + (cond + [(pred-$record/ref? x) + (if (eq? (pred-$record/ref-ref x) + (pred-$record/ref-ref y)) + y + '$record)] + [else + '$record])] + [else + '$record])) + + (define (intersect/true x y) + (cond + [(eq? x '$immediate/true) y] [else 'bottom])) - (define (intersect/symbol x pred? qpred y) - (cond - [(and pred? (check-constant-is? x pred?)) - x] - [(or (eq? x qpred) - (eq? x 'symbol) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/fixnum x check? y) - (cond - [(and check? (check-constant-is? x fixnum?)) - x] - [(or (eq? x 'fixnum) - (eq? x 'exact-integer) - (eq? x 'real) - (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/bignum x check? y) - (cond - [(and check? (check-constant-is? x bignum?)) - x] - [(or (eq? x 'bignum) - (eq? x 'exact-integer) - (eq? x 'real) - (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/exact-integer x check? y) - (cond - [(and check? (or (check-constant-is? x exact-integer?) - (eq? x 'fixnum) - (eq? x 'bignum))) - x] - [(or (eq? x 'exact-integer) - (eq? x 'real) - (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/flonum x check? y) - (cond - [(and check? (check-constant-is? x flonum?)) - x] - [(or (eq? x 'flonum) - (eq? x 'real) - (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/real x check? y) - (cond - [(and check? (or (check-constant-is? x real?) - (eq? x 'fixnum) - (eq? x 'bignum) - (eq? x 'exact-integer) - (eq? x 'flonum))) - x] - [(or (eq? x 'real) - (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - (define (intersect/number x check? y) - (cond - [(and check? (eq? x 'fixnum)) - x] - [(and check? (or (check-constant-is? x number?) - (eq? x 'fixnum) - (eq? x 'bignum) - (eq? x 'exact-integer) - (eq? x 'flonum) - (eq? x 'real))) - x] - [(or (eq? x 'number) - (eq? x 'true)) - y] - [else - 'bottom])) - - ;The result may be bigger than the actual intersection - ;if there is no exact result, it must be at least included in x - ;so it's possible to make decreasing sequences. - ;Anyway, for now the result is exact. - (define (predicate-intersect x y) + (define (predicate-intersect/immediate x y) (cond [(eq? x y) x] - [(not y) x] - [(not x) y] [(eq? y 'bottom) 'bottom] [(eq? x 'bottom) 'bottom] - [(eq? y 'ptr) x] - [(eq? x 'ptr) y] + [(eq? y '$immediate) x] + [(eq? x '$immediate) y] [(Lsrc? y) (nanopass-case (Lsrc Expr) y [(quote ,d1) @@ -550,18 +561,156 @@ 'bottom])] [(eq? dy #t) (cond - [(or (eq? x 'boolean) - (eq? x 'true)) + [(eq? x 'boolean) y] [else - 'bottom])] - [(null? dy) - (cond - [(or (eq? x 'null-or-pair) - (eq? x 'true)) + (intersect/true x y)])] + [(char? dy) + (cond + [(eq? x 'char) y] [else - 'bottom])] + (intersect/true x y)])] + [else + (intersect/true x y)])])] + [else + (case y + [(boolean) + (cond + [(eq? x '$immediate/true) + true-rec] + [(check-constant-is? x boolean?) + x] + [else + 'bottom])] + [($immediate/true) + (cond + [(eq? x 'boolean) + true-rec] + [(check-constant-eqv? x #f) + 'bottom] + [else + x])] + [(char) + (cond + [(check-constant-is? x char?) + x] + [else + (intersect/true x y)])] + [else + (intersect/true x y)])])) + + (define (intersect/simple x pred? qpred y) + (cond + [(and pred? (check-constant-is? x pred?)) + x] + [(eq? x qpred) + y] + [else + 'bottom])) + + (define (intersect/symbol x pred? qpred y) + (cond + [(and pred? (check-constant-is? x pred?)) + x] + [(or (eq? x qpred) + (eq? x 'symbol)) + y] + [else + 'bottom])) + + (define (intersect/fixnum x check? y) + (cond + [(and check? (check-constant-is? x fixnum?)) + x] + [(or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/bignum x check? y) + (cond + [(and check? (check-constant-is? x bignum?)) + x] + [(or (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/exact-integer x check? y) + (cond + [(and check? (or (check-constant-is? x exact-integer?) + (eq? x 'fixnum) + (eq? x 'bignum))) + x] + [(or (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/flonum x check? y) + (cond + [(and check? (check-constant-is? x flonum?)) + x] + [(or (eq? x 'flonum) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/real x check? y) + (cond + [(and check? (or (check-constant-is? x real?) + (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum))) + x] + [(or (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/number x check? y) + (cond + [(and check? (eq? x 'fixnum)) + x] + [(and check? (or (check-constant-is? x number?) + (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real))) + x] + [(eq? x 'number) + y] + [else + 'bottom])) + + (define (predicate-intersect/normal x y) + (cond + [(eq? x y) x] + [(eq? y 'bottom) 'bottom] + [(eq? x 'bottom) 'bottom] + [(eq? y 'normalptr) x] + [(eq? x 'normalptr) y] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + x] [(fixnum? dy) (intersect/fixnum x #f y)] [(bignum? dy) @@ -577,18 +726,70 @@ [(gensym? dy) (intersect/symbol x #f 'gensym y)] [(uninterned-symbol? dy) (intersect/symbol x #f 'uninterned-symbol y)] [(interned-symbol? dy) (intersect/symbol x #f 'interned-symbol y)] - [(char? dy) (intersect/simple x #f 'char y)] [(vector? dy) (intersect/simple x #f 'vector y)]; i.e. #() [(string? dy) (intersect/simple x #f 'string y)]; i.e. "" [(bytevector? dy) (intersect/simple x bytevector? 'bytevector y)] ; i.e. '#vu8() [(fxvector? dy) (intersect/simple x #f 'fxvector y)] ; i.e. '#vfx() [(flvector? dy) (intersect/simple x #f 'flvector y)] ; i.e. '#vfl() [else - (cond - [(eq? x 'true) - y] - [else - 'bottom])])])] + 'bottom])])] + [else + (case y + [(fixnum) + (intersect/fixnum x #t y)] + [(bignum) + (intersect/bignum x #t y)] + [(exact-integer) + (intersect/exact-integer x #t y)] + [(flonum) + (intersect/flonum x #t y)] + [(real) + (intersect/real x #t y)] + [(number) + (intersect/number x #t y)] + [(gensym) + (intersect/symbol x gensym? 'gensym y)] + [(uninterned-symbol) + (intersect/symbol x uninterned-symbol? 'uninterned-symbol y)] + [(interned-symbol) + (intersect/symbol x interned-symbol? 'interned-symbol y)] + [(symbol) + (cond + [(or (eq? x 'gensym) + (eq? x 'uninterned-symbol) + (eq? x 'interned-symbol) + (eq? x 'symbol) + (check-constant-is? x symbol?)) + x] + [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() + [(fxvector) (intersect/simple x fxvector? 'fxvector y)] ; i.e. '#vfx() + [(flvector) (intersect/simple x flvector? 'flvector y)] ; i.e. '#vfl() + [else + 'bottom])])) + + (define (intersect/record x y) + (cond + [(or (pred-$record/ref? x) + (pred-$record/rtd? x)) + x] + [(eq? x '$record) + y] + [else + 'bottom])) + + (define (predicate-intersect/record x y) + (cond + [(eq? x y) x] + [(not y) x] + [(not x) y] + [(eq? y 'bottom) 'bottom] + [(eq? x 'bottom) 'bottom] + [(eq? y '$record) x] + [(eq? x '$record) y] [(pred-$record/rtd? y) (cond [(pred-$record/rtd? x) @@ -624,80 +825,8 @@ (case y [($record) (intersect/record x y)] - [(null-or-pair) - (cond - [(eq? x 'pair) - 'pair] - [(check-constant-eqv? x '()) - x] - [(eq? x 'true) - 'null-or-pair] - [else 'bottom])] - [(pair) - (cond - [(or (eq? x 'null-or-pair) - (eq? x 'true)) - 'pair] - [else - 'bottom])] - [(fixnum) - (intersect/fixnum x #t y)] - [(bignum) - (intersect/bignum x #t y)] - [(exact-integer) - (intersect/exact-integer x #t y)] - [(flonum) - (intersect/flonum x #t y)] - [(real) - (intersect/real x #t y)] - [(number) - (intersect/number x #t y)] - [(gensym) - (intersect/symbol x gensym? 'gensym y)] - [(uninterned-symbol) - (intersect/symbol x uninterned-symbol? 'uninterned-symbol y)] - [(interned-symbol) - (intersect/symbol x interned-symbol? 'interned-symbol y)] - [(symbol) - (cond - [(or (eq? x 'gensym) - (eq? x 'uninterned-symbol) - (eq? x 'interned-symbol) - (eq? x 'symbol) - (eq? x 'true) - (check-constant-is? x symbol?)) - x] - [else - 'bottom])] - [(boolean) - (cond - [(eq? x 'true) - true-rec] - [(check-constant-is? x boolean?) - x] - [else - 'bottom])] - [(true) - (cond - [(eq? x 'boolean) - true-rec] - [(check-constant-eqv? x #f) - 'bottom] - [else - x])] - [(char) (intersect/simple x char? 'char y)] - [(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() - [(fxvector) (intersect/simple x fxvector? 'fxvector y)] ; i.e. '#vfx() - [(flvector) (intersect/simple x flvector? 'flvector y)] ; i.e. '#vfl() [else - (cond - [(eq? x 'true) - y] - [else - 'bottom])])])) - + 'bottom])])) (define (predicate-implies? x y) @@ -705,4 +834,173 @@ (define (predicate-disjoint? x y) (eq? (predicate-intersect x y) 'bottom)) + + (define (predicate->class x) + (cond + #;[(eq? x 'bottom) 'bottom] + [(or (check-constant-is? x $immediate?) + (memq x '(boolean char $immediate/true $immediate))) + '$immediate] + [(or (eq? x '$record) + (pred-$record/rtd? x) + (pred-$record/ref? x)) + '$record] + [else + 'normalptr])) + + (define build-pred-or + (case-lambda + [(i n r) + (build-pred-or i n r #f #f)] + [(i n r x) + (build-pred-or i n r x #f)] + [(i n r x y) + (cond + [(and x + (eq? (pred-or-imm x) i) + (eq? (pred-or-nor x) n) + (eq? (pred-or-rec x) r)) + x] + [(and y + (eq? (pred-or-imm y) i) + (eq? (pred-or-nor y) n) + (eq? (pred-or-rec y) r)) + y] + [(eq? i 'bottom) + (cond + [(eq? n 'bottom) r] + [(eq? r 'bottom) n] + [else (make-pred-or i n r)])] + [else + (cond + [(and (eq? n 'bottom) (eq? r 'bottom)) i] + [else (make-pred-or i n r)])])])) + + ;If x and y are equivalent, they result must be eq? to y + ;so it's easy to test in predicate-implies?. + ;The result may be bigger than the actual union. + (define (predicate-union x y) + (cond + [(or (not x) (not y)) #f] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(and (pred-or? x) + (pred-or? y)) + (let () + (define i (predicate-union/immediate (pred-or-imm x) (pred-or-imm y))) + (define n (predicate-union/normal (pred-or-nor x) (pred-or-nor y))) + (define r (predicate-union/record (pred-or-rec x) (pred-or-rec y))) + (build-pred-or i n r y x))] + [(pred-or? x) + (case (predicate->class y) + [($immediate) + (build-pred-or (predicate-union/immediate (pred-or-imm x) y) + (pred-or-nor x) + (pred-or-rec x) + x)] + [(normalptr) + (build-pred-or (pred-or-imm x) + (predicate-union/normal (pred-or-nor x) y) + (pred-or-rec x) + x)] + [($record) + (build-pred-or (pred-or-imm x) + (pred-or-nor x) + (predicate-union/record (pred-or-rec x) y) + x)])] + [(pred-or? y) + (case (predicate->class x) + [($immediate) + (build-pred-or (predicate-union/immediate x (pred-or-imm y)) + (pred-or-nor y) + (pred-or-rec y) + y)] + [(normalptr) + (build-pred-or (pred-or-imm y) + (predicate-union/normal x (pred-or-nor y)) + (pred-or-rec y) + y)] + [($record) + (build-pred-or (pred-or-imm y) + (pred-or-nor y) + (predicate-union/record x (pred-or-rec y)) + y)])] + [else + (let () + (define cx (predicate->class x)) + (define cy (predicate->class y)) + (cond + [(eq? cx cy) + (case cx + [($immediate) + (predicate-union/immediate x y)] + [(normalptr) + (predicate-union/normal x y)] + [($record) + (predicate-union/record x y)])] + [else + (let () + (define i (cond + [(eq? cx '$immediate) x] + [(eq? cy '$immediate) y] + [else 'bottom])) + (define n (cond + [(eq? cx 'normalptr) x] + [(eq? cy 'normalptr) y] + [else 'bottom])) + (define r (cond + [(eq? cx '$record) x] + [(eq? cy '$record) y] + [else 'bottom])) + (build-pred-or i n r))]))])) + + ;The result may be bigger than the actual intersection + ;if there is no exact result, it must be at least included in x + ;so it's possible to make decreasing sequences. + ;Anyway, for now the result is exact. + (define (predicate-intersect x y) + (cond + [(not x) y] + [(not y) x] + [(or (eq? x 'bottom) + (eq? y 'bottom)) + 'bottom] + [(and (pred-or? x) + (pred-or? y)) + (let () + (define i (predicate-intersect/immediate (pred-or-imm x) (pred-or-imm y))) + (define n (predicate-intersect/normal (pred-or-nor x) (pred-or-nor y))) + (define r (predicate-intersect/record (pred-or-rec x) (pred-or-rec y))) + (build-pred-or i n r x y))] + [(pred-or? x) + (case (predicate->class y) + [($immediate) + (predicate-intersect/immediate (pred-or-imm x) y)] + [(normalptr) + (predicate-intersect/normal (pred-or-nor x) y)] + [($record) + (predicate-intersect/record (pred-or-rec x) y)])] + [(pred-or? y) + (case (predicate->class x) + [($immediate) + (predicate-intersect/immediate x (pred-or-imm y))] + [(normalptr) + (predicate-intersect/normal x (pred-or-nor y))] + [($record) + (predicate-intersect/record x (pred-or-rec y))])] + [else + (let () + (define cx (predicate->class x)) + (define cy (predicate->class y)) + (cond + [(not (eq? cx cy)) + 'bottom] + [else + (case cx + [($immediate) + (predicate-intersect/immediate x y)] + [(normalptr) + (predicate-intersect/normal x y)] + [($record) + (predicate-intersect/record x y)])]))])) ) diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss index 93112e9563..b68e93adef 100644 --- a/racket/src/ChezScheme/s/cptypes.ss +++ b/racket/src/ChezScheme/s/cptypes.ss @@ -54,6 +54,9 @@ Notes: * a record #[pred-$record/ref ] to signal that it's a record of a type that is stored in the variable (these may collide with other records) + * a record #[pred-or ] where a predicate for + an immediate, is a predicate for a record and is a + predicate for anything else. * TODO?: add something to indicate that x is a procedure to create/setter/getter/predicate of a record of that type @@ -85,12 +88,6 @@ Notes: c))) (with-output-language (Lsrc Expr) - (define void-rec `(quote ,(void))) - (define true-rec `(quote #t)) - (define false-rec `(quote #f)) - (define null-rec `(quote ())) - (define eof-rec `(quote #!eof)) - (define bwp-rec `(quote #!bwp)) (module (simple?) ; Simplified version copied from cp0. TODO: copy the rest. (define default-fuel 5) @@ -316,7 +313,7 @@ Notes: (define (pred-env-add/key types key pred) (cond [(and pred - (not (eq? pred 'ptr)) ; filter 'ptr to reduce the size + (not (predicate-is-ptr? pred)) ; filter 'ptr to reduce the size (not (eq? types bottom-fxmap))) (let ([old (fxmap-ref types key #f)]) (cond @@ -537,14 +534,10 @@ Notes: [else (if (not extend?) 'bottom '$record)])] [else (if (not extend?) 'bottom '$record)])) - ; when extend is #f the result is a predicate that recognizes less values - ; than the one in name. This is useful for reductions like - ; (pred? x) ==> #t and (something x) ==> (#3%something x) - ; when extend is #t the result is a predicate that recognizes more values - ; than the one in name. This is useful for reductions like - ; (pred? x) ==> #f and (something x) ==> - ; in case the non extended version is not #f, the extended version must be not #f - (define (primref-name->predicate name extend?) + ; Recognize predicates and get the corresponding + ; type using the notation in primdata.ss + ; TODO: Move this info to primdata.ss + (define (primref-name->predicate name) (case name [pair? 'pair] [box? 'box] @@ -561,95 +554,26 @@ Notes: [flvector? 'flvector] [gensym? 'gensym] [uninterned-symbol? 'uninterned-symbol] - #;[interned-symbol? 'interned-symbol] [symbol? 'symbol] [char? 'char] [boolean? 'boolean] [procedure? 'procedure] - [not false-rec] - [null? null-rec] - [eof-object? eof-rec] - [bwp-object? bwp-rec] - [(list? list-assuming-immutable?) (if (not extend?) null-rec 'null-or-pair)] - [else ((if extend? cdr car) - (case name - [(record? record-type-descriptor?) '(bottom . $record)] - [(integer? rational?) '(exact-integer . real)] - [(cflonum?) '(flonum . number)] - [else '(#f . #f)]))])) ; this is used only to detect predicates. - - (define (maybe-predicate? name) - (let ([name (symbol->string name)]) - (and (>= (string-length name) 6) - (let loop ([n 0]) - (or (fx= n 6) - (and (eq? (string-ref name n) - (string-ref "maybe-" n)) - (loop (fx+ n 1)))))))) - - ; nqm: no question mark - ; this is almost duplicated code, but with more cases - ; it's also useful to avoid the allocation - ; of the temporal strings to transform: vector -> vector? - (define (primref-name/nqm->predicate name extend?) - (case name - [pair 'pair] - [box 'box] - [$record '$record] - [fixnum 'fixnum] - [bignum 'bignum] - [flonum 'flonum] - [real 'real] - [number 'number] - [vector 'vector] - [string 'string] - [bytevector 'bytevector] - [fxvector 'fxvector] - [flvector 'flvector] - [gensym 'gensym] - [uninterned-symbol 'uninterned-symbol] - [interned-symbol 'interned-symbol] - [symbol 'symbol] - [char 'char] - [bottom 'bottom] ;pseudo-predicate - [ptr 'ptr] ;pseudo-predicate - [boolean 'boolean] - [true 'true] - [procedure 'procedure] - [exact-integer 'exact-integer] ;fake-predicate - [void void-rec] ;fake-predicate - [null null-rec] - [eof-object eof-rec] - [bwp-object bwp-rec] - [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate - [else ((if extend? cdr car) - (case name - [(record rtd) '(bottom . $record)] - [(bit length ufixnum pfixnum) '(bottom . fixnum)] - [(uint sub-uint) '(bottom . exact-integer)] - [(index sub-index u8 s8) '(bottom . fixnum)] - [(sint) '(fixnum . exact-integer)] - [(uinteger) '(bottom . real)] - [(integer rational) '(exact-integer . real)] - [(cflonum) '(flonum . number)] - [(sub-ptr) '(bottom . ptr)] - [else - (cond - [(not name) ; TODO: Move this case to the top? - '(#f . #f)] - [(pair? name) ; TODO: Move this case to the top? - (cond - [(equal? name '(ptr . ptr)) - '(pair . pair)] - [else - '(bottom . pair)])] - [(maybe-predicate? name) - '(bottom . ptr)] ; for types like maybe-* - [else - '(bottom . true)])]))])) ; for all other types that exclude #f + [not 'false] + [null? 'null] + [eof-object? 'eof-object] + [bwp-object? 'bwp-object] + [$immediate? '$immediate] + [list? 'list] + [list-assuming-immutable? 'list-assuming-immutable] + [record? 'record] + [record-type-descriptor? 'rtd] + [integer? 'integer] + [rational? 'rational] + [cflonum? 'cflonum] + [else #f])) ; this function is used only to detect predicates. (define (primref->predicate pr extend?) - (primref-name->predicate (primref-name pr) extend?)) + (primref-name/nqm->predicate (primref-name->predicate (primref-name pr)) extend?)) (define (check-constant-is? x pred?) (and (Lsrc? x) @@ -698,16 +622,9 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) - (define (predicate-implies-fixmediate? x) - (and (not (eq? x 'ptr)) ;fast path to avoid duplicated computation - (or (check-constant-is? x $immediate?) - (predicate-implies? x 'fixnum) - (predicate-implies? x 'boolean) - (predicate-implies? x 'char)))) - (define (non-literal-fixmediate? e x) (and (not (check-constant-is? e (lambda (e) #t))) - (predicate-implies-fixmediate? x))) + (predicate-implies? x $fixmediate-pred))) (module () @@ -1056,27 +973,27 @@ Notes: [ir `(call ,preinfo ,pr ,n)]) (cond [(predicate-implies? r 'char) - (values ir 'ptr ntypes #f #f)] ; should be maybe-symbol + (values ir ptr-pred ntypes #f #f)] ; should be maybe-symbol [(predicate-implies? r 'symbol) - (values ir 'ptr ntypes #f #f)] ; should be maybe-char + (values ir ptr-pred ntypes #f #f)] ; should be maybe-char [(and (predicate-disjoint? r 'char) (predicate-disjoint? r 'symbol)) (values ir 'bottom pred-env-bottom #f #f)] [else - (values ir 'ptr ; should be maybe-(union 'char 'symbol) - (pred-env-add/ref ntypes n 'true plxc) #f #f)]))] ; should be (union 'char 'symbol) + (values ir ptr-pred ; should be maybe-(union 'char 'symbol) + (pred-env-add/ref ntypes n true-pred plxc) #f #f)]))] ; should be (union 'char 'symbol) [(n c) (let ([rn (get-type n)] [rc (get-type c)] [ir `(call ,preinfo ,pr ,n ,c)]) (cond [(or (predicate-disjoint? rn 'symbol) - (predicate-disjoint? rc 'ptr)) ; should be maybe-char + (predicate-disjoint? rc ptr-pred)) ; should be maybe-char (values ir 'bottom pred-env-bottom #f #f)] [else (values ir void-rec (pred-env-add/ref (pred-env-add/ref ntypes n 'symbol plxc) - c 'ptr plxc) ; should be maybe-char + c ptr-pred plxc) ; should be maybe-char #f #f)]))]) (define-specialize/unrestricted 2 call-with-values @@ -1092,7 +1009,7 @@ Notes: (define-specialize/unrestricted 2 apply [(proc . e*) (let-values ([(e* r* t* t-t* f-t*) - (map-values 5 (lambda (e) (Expr/main e 'value oldtypes plxc)) e*)]) + (map-values 5 (lambda (e) (Expr e 'value oldtypes plxc)) e*)]) (let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)]) (let-values ([(proc retproc typesproc t-typesproc f-typesproc) (Expr/call proc ctxt mtypes oldtypes plxc)]) @@ -1101,9 +1018,9 @@ Notes: (define-specialize/unrestricted 2 $apply [(proc n args) (let*-values ([(n rn tn t-tn f-tn) - (Expr/main n 'value oldtypes plxc)] + (Expr n 'value oldtypes plxc)] [(args rargs targs t-targs f-targs) - (Expr/main args 'value oldtypes plxc)]) + (Expr args 'value oldtypes plxc)]) (let* ([predn (primref->argument-predicate pr 1 3 #t)] [tn (if (predicate-disjoint? rn predn) 'bottom @@ -1124,7 +1041,7 @@ Notes: (define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc) (let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?) (if critical? - (Expr/main critical? 'value oldtypes plxc) + (Expr critical? 'value oldtypes plxc) (values #f #f oldtypes #f #f))] [(ìn rin tin t-tin f-tin) (Expr/call in 'value tcritical? oldtypes plxc)] @@ -1262,14 +1179,14 @@ Notes: (define (finish preinfo preinfo2 x* interface body e* r* ntypes) (let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)]) (let*-values ([(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (values `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ret n-types t-types f-types)))) (define (bad-arity preinfo e0 e* ctxt ntypes) (let*-values ([(e0 ret0 n-types0 t-types0 f-types0) - (Expr/main e0 'value ntypes plxc)]) + (Expr e0 'value ntypes plxc)]) (values `(call ,preinfo ,e0 ,e* ...) 'bottom pred-env-bottom #f #f))) (define (cut-r* r* n) @@ -1329,7 +1246,7 @@ Notes: [else (cons 'ready (call-with-values - (lambda () (Expr/main e 'value oldtypes plxc)) + (lambda () (Expr e 'value oldtypes plxc)) list))])) e*)) (define fp-types (fold-left (lambda (t x) @@ -1342,7 +1259,7 @@ Notes: (cond [(eq? (car e) 'delayed) (call-with-values - (lambda () (Expr/main (cdr e) 'value fp-types plxc)) + (lambda () (Expr (cdr e) 'value fp-types plxc)) list)] [else (cdr e)])) @@ -1368,13 +1285,13 @@ Notes: (define (Expr/fix-tf-types ir ctxt types plxc) (let-values ([(ir ret types t-types f-types) - (Expr/main ir ctxt types plxc)]) + (Expr ir ctxt types plxc)]) (values ir ret types (if (predicate-implies? ret false-rec) pred-env-bottom (or t-types types)) - (if (predicate-implies? ret 'true) + (if (predicate-implies? ret true-pred) pred-env-bottom (or f-types types))))) @@ -1397,7 +1314,7 @@ Notes: (nanopass-case (Lsrc CaseLambdaClause) (car cl*) [(clause (,x* ...) ,interface ,body) (let-values ([(body ret2 types2 t-types2 f-types2) - (Expr/main body ctxt types plxc)]) + (Expr body ctxt types plxc)]) (let* ([cl2 (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body))] [t-types2 (or t-types2 types2)] @@ -1443,7 +1360,7 @@ Notes: ntypes)])))])))])]))] [else (let-values ([(ir ret n-types t-types f-types) - (Expr/main ir 'value outtypes plxc)]) + (Expr ir 'value outtypes plxc)]) (values ir (if (predicate-disjoint? ret 'procedure) 'bottom @@ -1462,14 +1379,14 @@ Notes: [(test) (let ([t (pred-env-lookup types x plxc)]) (cond - [(predicate-implies? t 'true) + [(predicate-implies? t true-pred) (values true-rec true-rec types #f #f)] [(predicate-implies? t false-rec) (values false-rec false-rec types #f #f)] [else (values ir t types - (pred-env-add/ref types ir 'true plxc) ; don't confuse it with true-rec + (pred-env-add/ref types ir true-pred plxc) ; don't confuse it with true-rec (pred-env-add/ref types ir false-rec plxc))]))] [else (let ([t (pred-env-lookup types x plxc)]) @@ -1481,26 +1398,26 @@ Notes: [else (values ir t types #f #f)])] [else - (values ir (or t 'ptr) types #f #f)]))])] ; In case there is no saved type, use 'ptr to mark it as single valued + (values ir (or t ptr-pred) types #f #f)]))])] ; In case there is no saved type, use ptr-pred to mark it as single valued [(seq ,[e1 'effect types plxc -> e1 ret1 types t-types f-types] ,e2) (cond [(predicate-implies? ret1 'bottom) (values e1 'bottom pred-env-bottom #f #f)] [else (let-values ([(e2 ret types t-types f-types) - (Expr/main e2 ctxt types plxc)]) + (Expr e2 ctxt types plxc)]) (values (make-seq/no-drop ctxt e1 e2) ret types t-types f-types))])] [(if ,[Expr/fix-tf-types : e1 'test types plxc -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) (cond [(predicate-implies? ret1 'bottom) ;check bottom first (values e1 'bottom pred-env-bottom #f #f)] - [(predicate-implies? ret1 'true) + [(predicate-implies? ret1 true-pred) (let-values ([(e2 ret types t-types f-types) - (Expr/main e2 ctxt types1 plxc)]) + (Expr e2 ctxt types1 plxc)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))] [(predicate-implies? ret1 false-rec) (let-values ([(e3 ret types t-types f-types) - (Expr/main e3 ctxt types1 plxc)]) + (Expr e3 ctxt types1 plxc)]) (values (make-seq ctxt e1 e3) ret types t-types f-types))] [else (let-values ([(e2 ret2 types2 t-types2 f-types2) @@ -1560,7 +1477,7 @@ Notes: (nanopass-case (Lsrc CaseLambdaClause) cl [(clause (,x* ...) ,interface ,body) (let-values ([(body ret types t-types f-types) - (Expr/main body 'value types plxc)]) + (Expr body 'value types plxc)]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body)))])) @@ -1575,7 +1492,7 @@ Notes: (map-Expr/delayed e* types plxc)]) (let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)]) (let*-values ([(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (values `(letrec ([,x* ,e*] ...) ,body) @@ -1586,11 +1503,11 @@ Notes: (if (null? x*) (values (reverse rev-e*) types) (let-values ([(e ret types t-types f-types) - (Expr/main (car e*) 'value types plxc)]) + (Expr (car e*) 'value types plxc)]) (let ([types (pred-env-add types (car x*) ret plxc)]) (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))] [(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt types plxc)]) (values `(letrec* ([,x* ,e*] ...) ,body) @@ -1656,12 +1573,12 @@ Notes: ; friendly name to use in other internal functions ; so it is similar to Expr/call and Expr/fix-tf-types - (define Expr/main cptypes) + (define Expr cptypes) ; external version of cptypes: Lsrc -> Lsrc (define (Scptypes ir) (let-values ([(ir ret types t-types f-types) - (Expr/main ir 'value pred-env-empty (box 0))]) + (Expr ir 'value pred-env-empty (box 0))]) ir)) (set! $cptypes Scptypes)