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

Chez Scheme: add maybe predicates to cptypes

Browse Source 
Actually, use a more general decomposition with a part for an
$immediate, a part for a $record and a third part for other types
like string?, vector?, ...

This is not as general as an arbitrary union, but it is enough for
the common cases, and also to handles the common objects in Racket
that are implemented in CS as the corresponding object and a record
for the impersonator.
This commit is contained in:
Gustavo Massaccesi 2021-02-27 17:49:07 -03:00
parent 37ee8a793c
commit 421dce228d
3 changed files with 799 additions and 568 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1178,4 +1178,20 @@
(loop (fx+ i 1)))))) (loop (fx+ i 1))))))
(cptypes-equivalent-expansion? (cptypes-equivalent-expansion?
'(lambda (x y) (set-box! x (if (vector? y) #t (error 't)))) '(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)))
)

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

File diff suppressed because it is too large Load Diff

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

@ -54,6 +54,9 @@ Notes:
* a record #[pred-$record/ref <ref>] to signal that it's a * a record #[pred-$record/ref <ref>] to signal that it's a
record of a type that is stored in the variable <ref> record of a type that is stored in the variable <ref>
(these may collide with other records) (these may collide with other records)
* a record #[pred-or <imm> <nor> <rec>] where <imm> a predicate for
an immediate, <rec> is a predicate for a record and <nor> is a
predicate for anything else.
* TODO?: add something to indicate that x is a procedure to * TODO?: add something to indicate that x is a procedure to
create/setter/getter/predicate of a record of that type create/setter/getter/predicate of a record of that type
@ -85,12 +88,6 @@ Notes:
c))) c)))
(with-output-language (Lsrc Expr) (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. (module (simple?) ; Simplified version copied from cp0. TODO: copy the rest.
(define default-fuel 5) (define default-fuel 5)
@ -316,7 +313,7 @@ Notes:
(define (pred-env-add/key types key pred) (define (pred-env-add/key types key pred)
(cond (cond
[(and pred [(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))) (not (eq? types bottom-fxmap)))
(let ([old (fxmap-ref types key #f)]) (let ([old (fxmap-ref types key #f)])
(cond (cond
@ -537,14 +534,10 @@ Notes:
[else (if (not extend?) 'bottom '$record)])] [else (if (not extend?) 'bottom '$record)])]
[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 ; Recognize predicates and get the corresponding
; than the one in name. This is useful for reductions like ; type using the notation in primdata.ss
; (pred? x) ==> #t and (something x) ==> (#3%something x) ; TODO: Move this info to primdata.ss
; when extend is #t the result is a predicate that recognizes more values (define (primref-name->predicate name)
; than the one in name. This is useful for reductions like
; (pred? x) ==> #f and (something x) ==> <error>
; in case the non extended version is not #f, the extended version must be not #f
(define (primref-name->predicate name extend?)
(case name (case name
[pair? 'pair] [pair? 'pair]
[box? 'box] [box? 'box]
@ -561,95 +554,26 @@ Notes:
[flvector? 'flvector] [flvector? 'flvector]
[gensym? 'gensym] [gensym? 'gensym]
[uninterned-symbol? 'uninterned-symbol] [uninterned-symbol? 'uninterned-symbol]
#;[interned-symbol? 'interned-symbol]
[symbol? 'symbol] [symbol? 'symbol]
[char? 'char] [char? 'char]
[boolean? 'boolean] [boolean? 'boolean]
[procedure? 'procedure] [procedure? 'procedure]
[not false-rec] [not 'false]
[null? null-rec] [null? 'null]
[eof-object? eof-rec] [eof-object? 'eof-object]
[bwp-object? bwp-rec] [bwp-object? 'bwp-object]
[(list? list-assuming-immutable?) (if (not extend?) null-rec 'null-or-pair)] [$immediate? '$immediate]
[else ((if extend? cdr car) [list? 'list]
(case name [list-assuming-immutable? 'list-assuming-immutable]
[(record? record-type-descriptor?) '(bottom . $record)] [record? 'record]
[(integer? rational?) '(exact-integer . real)] [record-type-descriptor? 'rtd]
[(cflonum?) '(flonum . number)] [integer? 'integer]
[else '(#f . #f)]))])) ; this is used only to detect predicates. [rational? 'rational]
[cflonum? 'cflonum]
(define (maybe-predicate? name) [else #f])) ; this function is used only to detect predicates.
(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
(define (primref->predicate pr extend?) (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?) (define (check-constant-is? x pred?)
(and (Lsrc? x) (and (Lsrc? x)
@ -698,16 +622,9 @@ Notes:
(define (primref->unsafe-primref pr) (define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name 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) (define (non-literal-fixmediate? e x)
(and (not (check-constant-is? e (lambda (e) #t))) (and (not (check-constant-is? e (lambda (e) #t)))
(predicate-implies-fixmediate? x))) (predicate-implies? x $fixmediate-pred)))
(module () (module ()
@ -1056,27 +973,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 ntypes #f #f)] ; should be maybe-symbol (values ir ptr-pred ntypes #f #f)] ; should be maybe-symbol
[(predicate-implies? r '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) [(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 ; should be maybe-(union 'char 'symbol) (values ir ptr-pred ; should be maybe-(union 'char 'symbol)
(pred-env-add/ref ntypes n 'true plxc) #f #f)]))] ; should be (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)] [(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)) ; should be maybe-char (predicate-disjoint? rc ptr-pred)) ; should be maybe-char
(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 plxc) ; should be maybe-char c ptr-pred plxc) ; should be maybe-char
#f #f)]))]) #f #f)]))])
(define-specialize/unrestricted 2 call-with-values (define-specialize/unrestricted 2 call-with-values
@ -1092,7 +1009,7 @@ Notes:
(define-specialize/unrestricted 2 apply (define-specialize/unrestricted 2 apply
[(proc . e*) (let-values ([(e* r* t* t-t* f-t*) [(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 ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
(let-values ([(proc retproc typesproc t-typesproc f-typesproc) (let-values ([(proc retproc typesproc t-typesproc f-typesproc)
(Expr/call proc ctxt mtypes oldtypes plxc)]) (Expr/call proc ctxt mtypes oldtypes plxc)])
@ -1101,9 +1018,9 @@ Notes:
(define-specialize/unrestricted 2 $apply (define-specialize/unrestricted 2 $apply
[(proc n args) (let*-values ([(n rn tn t-tn f-tn) [(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) [(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)] (let* ([predn (primref->argument-predicate pr 1 3 #t)]
[tn (if (predicate-disjoint? rn predn) [tn (if (predicate-disjoint? rn predn)
'bottom 'bottom
@ -1124,7 +1041,7 @@ Notes:
(define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc) (define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc)
(let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?) (let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?)
(if critical? (if critical?
(Expr/main critical? 'value oldtypes plxc) (Expr critical? 'value oldtypes plxc)
(values #f #f oldtypes #f #f))] (values #f #f oldtypes #f #f))]
[(ìn rin tin t-tin f-tin) [(ìn rin tin t-tin f-tin)
(Expr/call in 'value tcritical? oldtypes plxc)] (Expr/call in 'value tcritical? oldtypes plxc)]
@ -1262,14 +1179,14 @@ Notes:
(define (finish preinfo preinfo2 x* interface body e* r* ntypes) (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 ([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) (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) [(n-types t-types f-types)
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (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* ...) (values `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)
ret n-types t-types f-types)))) ret n-types t-types f-types))))
(define (bad-arity preinfo e0 e* ctxt ntypes) (define (bad-arity preinfo e0 e* ctxt ntypes)
(let*-values ([(e0 ret0 n-types0 t-types0 f-types0) (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* ...) (values `(call ,preinfo ,e0 ,e* ...)
'bottom pred-env-bottom #f #f))) 'bottom pred-env-bottom #f #f)))
(define (cut-r* r* n) (define (cut-r* r* n)
@ -1329,7 +1246,7 @@ Notes:
[else [else
(cons 'ready (cons 'ready
(call-with-values (call-with-values
(lambda () (Expr/main e 'value oldtypes plxc)) (lambda () (Expr e 'value oldtypes plxc))
list))])) list))]))
e*)) e*))
(define fp-types (fold-left (lambda (t x) (define fp-types (fold-left (lambda (t x)
@ -1342,7 +1259,7 @@ Notes:
(cond (cond
[(eq? (car e) 'delayed) [(eq? (car e) 'delayed)
(call-with-values (call-with-values
(lambda () (Expr/main (cdr e) 'value fp-types plxc)) (lambda () (Expr (cdr e) 'value fp-types plxc))
list)] list)]
[else [else
(cdr e)])) (cdr e)]))
@ -1368,13 +1285,13 @@ Notes:
(define (Expr/fix-tf-types ir ctxt types plxc) (define (Expr/fix-tf-types ir ctxt types plxc)
(let-values ([(ir ret types t-types f-types) (let-values ([(ir ret types t-types f-types)
(Expr/main ir ctxt types plxc)]) (Expr ir ctxt types plxc)])
(values ir ret (values ir ret
types types
(if (predicate-implies? ret false-rec) (if (predicate-implies? ret false-rec)
pred-env-bottom pred-env-bottom
(or t-types types)) (or t-types types))
(if (predicate-implies? ret 'true) (if (predicate-implies? ret true-pred)
pred-env-bottom pred-env-bottom
(or f-types types))))) (or f-types types)))))
@ -1397,7 +1314,7 @@ Notes:
(nanopass-case (Lsrc CaseLambdaClause) (car cl*) (nanopass-case (Lsrc CaseLambdaClause) (car cl*)
[(clause (,x* ...) ,interface ,body) [(clause (,x* ...) ,interface ,body)
(let-values ([(body ret2 types2 t-types2 f-types2) (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) (let* ([cl2 (with-output-language (Lsrc CaseLambdaClause)
`(clause (,x* ...) ,interface ,body))] `(clause (,x* ...) ,interface ,body))]
[t-types2 (or t-types2 types2)] [t-types2 (or t-types2 types2)]
@ -1443,7 +1360,7 @@ Notes:
ntypes)])))])))])]))] ntypes)])))])))])]))]
[else [else
(let-values ([(ir ret n-types t-types f-types) (let-values ([(ir ret n-types t-types f-types)
(Expr/main ir 'value outtypes plxc)]) (Expr ir 'value outtypes plxc)])
(values ir (values ir
(if (predicate-disjoint? ret 'procedure) (if (predicate-disjoint? ret 'procedure)
'bottom 'bottom
@ -1462,14 +1379,14 @@ Notes:
[(test) [(test)
(let ([t (pred-env-lookup types x plxc)]) (let ([t (pred-env-lookup types x plxc)])
(cond (cond
[(predicate-implies? t 'true) [(predicate-implies? t true-pred)
(values true-rec true-rec types #f #f)] (values true-rec true-rec types #f #f)]
[(predicate-implies? t false-rec) [(predicate-implies? t false-rec)
(values false-rec false-rec types #f #f)] (values false-rec false-rec types #f #f)]
[else [else
(values ir t (values ir t
types 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))]))] (pred-env-add/ref types ir false-rec plxc))]))]
[else [else
(let ([t (pred-env-lookup types x plxc)]) (let ([t (pred-env-lookup types x plxc)])
@ -1481,26 +1398,26 @@ Notes:
[else [else
(values ir t types #f #f)])] (values ir t types #f #f)])]
[else [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) [(seq ,[e1 'effect types plxc -> e1 ret1 types t-types f-types] ,e2)
(cond (cond
[(predicate-implies? ret1 'bottom) [(predicate-implies? ret1 'bottom)
(values e1 'bottom pred-env-bottom #f #f)] (values e1 'bottom pred-env-bottom #f #f)]
[else [else
(let-values ([(e2 ret types t-types f-types) (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))])] (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) [(if ,[Expr/fix-tf-types : e1 'test types plxc -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3)
(cond (cond
[(predicate-implies? ret1 'bottom) ;check bottom first [(predicate-implies? ret1 'bottom) ;check bottom first
(values e1 'bottom pred-env-bottom #f #f)] (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) (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))] (values (make-seq ctxt e1 e2) ret types t-types f-types))]
[(predicate-implies? ret1 false-rec) [(predicate-implies? ret1 false-rec)
(let-values ([(e3 ret types t-types f-types) (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))] (values (make-seq ctxt e1 e3) ret types t-types f-types))]
[else [else
(let-values ([(e2 ret2 types2 t-types2 f-types2) (let-values ([(e2 ret2 types2 t-types2 f-types2)
@ -1560,7 +1477,7 @@ Notes:
(nanopass-case (Lsrc CaseLambdaClause) cl (nanopass-case (Lsrc CaseLambdaClause) cl
[(clause (,x* ...) ,interface ,body) [(clause (,x* ...) ,interface ,body)
(let-values ([(body ret types t-types f-types) (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*) (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
(with-output-language (Lsrc CaseLambdaClause) (with-output-language (Lsrc CaseLambdaClause)
`(clause (,x* ...) ,interface ,body)))])) `(clause (,x* ...) ,interface ,body)))]))
@ -1575,7 +1492,7 @@ Notes:
(map-Expr/delayed e* types plxc)]) (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 ([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) (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) [(n-types t-types f-types)
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)])
(values `(letrec ([,x* ,e*] ...) ,body) (values `(letrec ([,x* ,e*] ...) ,body)
@ -1586,11 +1503,11 @@ Notes:
(if (null? x*) (if (null? x*)
(values (reverse rev-e*) types) (values (reverse rev-e*) types)
(let-values ([(e ret types t-types f-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)]) (let ([types (pred-env-add types (car x*) ret plxc)])
(loop (cdr x*) (cdr e*) types (cons e rev-e*))))))] (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))]
[(body ret n-types/x t-types/x f-types/x) [(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) [(n-types t-types f-types)
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt types plxc)]) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt types plxc)])
(values `(letrec* ([,x* ,e*] ...) ,body) (values `(letrec* ([,x* ,e*] ...) ,body)
@ -1656,12 +1573,12 @@ Notes:
; friendly name to use in other internal functions ; friendly name to use in other internal functions
; so it is similar to Expr/call and Expr/fix-tf-types ; 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 ; external version of cptypes: Lsrc -> Lsrc
(define (Scptypes ir) (define (Scptypes ir)
(let-values ([(ir ret types t-types f-types) (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)) ir))
(set! $cptypes Scptypes) (set! $cptypes Scptypes)