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

Additional improvements in cptypes

Browse Source 
original commit: e53bae2d4ac549ac466d5f9942a839d624fb58fe
This commit is contained in:
Gustavo Massaccesi 2018-04-06 18:22:10 -03:00
parent 18b12f21fd
commit 62ae3ff4e6
2 changed files with 229 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
s/cptypes.ss
View File

@ -29,14 +29,15 @@ Notes:
+ results + results
ir: the optimized expression ir: the optimized expression
ret: type of the result of the expression ret: type of the result of the expression
types: like the types in the argument, with addition of the type discover types: like the types in the argument, with the addition of the types
during the optimization of the expression discover during the optimization of the expression
t-types: types to be used in case the expression is not #f, to be used in t-types: types to be used in case the expression is not #f, to be used in
the "then" branch of an if. the "then" branch of an if.
If left as #f it will be automatically replaced with a copy of
types by the wrapper.
This is usually only filled in a text context. This is usually only filled in a text context.
f-types: idem for the "else" branch. (if x (something) (here x is #f)) It may be #f, and in this case the `if` clause will use the value
of types as a replacement.
(Also the clauses for `let[rec/*]` handle the #f case specialy.)
f-types: idem for the "else" branch. (if x (something) <here x is #f>)
- predicate: They may be: - predicate: They may be:
@ -46,9 +47,9 @@ Notes:
* a nanopass-quoted value that is okay-to-copy?, like * a nanopass-quoted value that is okay-to-copy?, like
`(quote 0) `(quote 5) `(quote #t) `(quote '()) `(quote 0) `(quote 5) `(quote #t) `(quote '())
(this doesn't includes `(quote <record-type-descriptor>)) (this doesn't includes `(quote <record-type-descriptor>))
* a [normal] list ($record/rtd <rtd>) to signal that it's a * a record #[pred-$record/rtd <rtd>] to signal that it's a
record of type <rtd> record of type <rtd>
* a [normal] list ($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)
* TODO?: add something to indicate that x is a procedure to * TODO?: add something to indicate that x is a procedure to
@ -125,6 +126,16 @@ Notes:
(make-seq ctxt (car e*) (make-seq* ctxt (cdr e*)))))) (make-seq ctxt (car e*) (make-seq* ctxt (cdr e*))))))
) )
(define-record-type pred-$record/rtd
(fields rtd)
(nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0})
(sealed #t))
(define-record-type pred-$record/ref
(fields ref)
(nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
(sealed #t))
(module (pred-env-empty (module (pred-env-empty
pred-env-add pred-env-remove/base pred-env-lookup pred-env-add pred-env-remove/base pred-env-lookup
pred-env-intersect/base pred-env-union/super-base pred-env-intersect/base pred-env-union/super-base
@ -169,7 +180,6 @@ Notes:
; 'box _and_ 'vector -> 'bottom ; 'box _and_ 'vector -> 'bottom
; 'number _and_ 'exact-integer -> 'exact-integer ; 'number _and_ 'exact-integer -> 'exact-integer
(define (pred-env-intersect/base types from base) (define (pred-env-intersect/base types from base)
#;(display (list (fxmap-changes from) (fxmap-changes types)))
(cond (cond
[(fx> (fxmap-changes from) (fxmap-changes types)) [(fx> (fxmap-changes from) (fxmap-changes types))
(pred-env-intersect/base from types base)] (pred-env-intersect/base from types base)]
@ -337,10 +347,10 @@ Notes:
(nanopass-case (Lsrc Expr) rtd (nanopass-case (Lsrc Expr) rtd
[(quote ,d) [(quote ,d)
(guard (record-type-descriptor? d)) (guard (record-type-descriptor? d))
(list '$record/rtd d)] (make-pred-$record/rtd d)]
[(ref ,maybe-src ,x) [(ref ,maybe-src ,x)
(guard (not (prelex-assigned x))) (guard (not (prelex-assigned x)))
(list '$record/ref x)] (make-pred-$record/ref x)]
[(record-type ,rtd ,e) [(record-type ,rtd ,e)
(rtd->record-predicate e)] (rtd->record-predicate e)]
[else '$record])] [else '$record])]
@ -376,7 +386,7 @@ Notes:
[eof-object? eof-rec] [eof-object? eof-rec]
[bwp-object? bwp-rec] [bwp-object? bwp-rec]
[list? (if (not extend?) null-rec 'null-or-pair)] [list? (if (not extend?) null-rec 'null-or-pair)]
[else ((if extend? cdr car);--------------------------------------------------- [else ((if extend? cdr car)
(case name (case name
[(record? record-type-descriptor?) '(bottom . $record)] [(record? record-type-descriptor?) '(bottom . $record)]
[(integer? rational?) '(exact-integer . real)] [(integer? rational?) '(exact-integer . real)]
@ -413,7 +423,7 @@ Notes:
[eof-object eof-rec] [eof-object eof-rec]
[bwp-object bwp-rec] [bwp-object bwp-rec]
[list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate
[else ((if extend? cdr car);--------------------------------------------------- [else ((if extend? cdr car)
(case name (case name
[(record rtd) '(bottom . $record)] [(record rtd) '(bottom . $record)]
[(bit length ufixnum pfixnum) '(bottom . fixnum)] [(bit length ufixnum pfixnum) '(bottom . fixnum)]
@ -449,27 +459,25 @@ Notes:
(nanopass-case (Lsrc Expr) y (nanopass-case (Lsrc Expr) y
[(quote ,d1) [(quote ,d1)
(nanopass-case (Lsrc Expr) x (nanopass-case (Lsrc Expr) x
[(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal? [(quote ,d2) (eqv? d1 d2)]
[else #f])] [else #f])]
[else #f]))] [else #f]))]
[(and (pair? y) (pair? (cdr y))) [(pred-$record/rtd? y)
(and (pair? x) (pair? (cdr x)) (and (pred-$record/rtd? x)
(cond (let ([x-rtd (pred-$record/rtd-rtd x)]
[(eq? (car y) '$record/rtd) [y-rtd (pred-$record/rtd-rtd y)])
(and (eq? (car x) '$record/rtd) (cond
(let ([y-rtd (cadr y)]) [(record-type-sealed? y-rtd)
(cond (eqv? x-rtd y-rtd)]
[(record-type-sealed? y-rtd) [else
(eqv? (cadr x) y-rtd)] (let loop ([x-rtd x-rtd])
[else (or (eqv? x-rtd y-rtd)
(let loop ([x-rtd (cadr x)]) (let ([xp-rtd (record-type-parent x-rtd)])
(or (eqv? x-rtd y-rtd) (and xp-rtd (loop xp-rtd)))))])))]
(let ([xp (record-type-parent x-rtd)]) [(pred-$record/ref? y)
(and xp (loop xp)))))])))] (and (pred-$record/ref? x)
[(eq? (car y) '$record/ref) (eq? (pred-$record/ref-ref x)
(and (eq? (car x) '$record/ref) (pred-$record/ref-ref y)))]
(eq? (cadr x) (cadr y)))]
[else #f]))]
[(case y [(case y
[(null-or-pair) (or (eq? x 'pair) [(null-or-pair) (or (eq? x 'pair)
(check-constant-is? x null?))] (check-constant-is? x null?))]
@ -496,8 +504,8 @@ Notes:
[(true) (and (not (check-constant-is? x not)) [(true) (and (not (check-constant-is? x not))
(not (eq? x 'boolean)) (not (eq? x 'boolean))
(not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f
[($record) (or (and (pair? x) (eq? (car x) '$record/rtd)) [($record) (or (pred-$record/rtd? x)
(and (pair? x) (eq? (car x) '$record/ref)) (pred-$record/ref? x)
(check-constant-is? x #3%$record?))] (check-constant-is? x #3%$record?))]
[(vector) (check-constant-is? x vector?)] ; i.e. '#() [(vector) (check-constant-is? x vector?)] ; i.e. '#()
[(string) (check-constant-is? x string?)] ; i.e. "" [(string) (check-constant-is? x string?)] ; i.e. ""
@ -510,14 +518,12 @@ Notes:
(define (predicate-implies-not? x y) (define (predicate-implies-not? x y)
(and x (and x
y y
; a $record/ref may be any other kind or record ; a pred-$record/ref may be any other kind or record
(not (and (pair? x) (not (and (pred-$record/ref? x)
(eq? (car x) '$record/ref)
(predicate-implies? y '$record))) (predicate-implies? y '$record)))
(not (and (pair? y) (not (and (pred-$record/ref? y)
(eq? (car y) '$record/ref)
(predicate-implies? x '$record))) (predicate-implies? x '$record)))
; boolean and true may be #f ; boolean and true may be a #t
(not (and (eq? x 'boolean) (not (and (eq? x 'boolean)
(eq? y 'true))) (eq? y 'true)))
(not (and (eq? y 'boolean) (not (and (eq? y 'boolean)
@ -616,19 +622,19 @@ Notes:
(define (primref->unsafe-primref pr) (define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name pr))) (lookup-primref 3 (primref-name pr)))
(define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) (define-pass cptypes : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types)
(Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types)
[(quote ,d) [(quote ,d)
(values ir (datum->predicate d ir) #f #f #f)] (values ir (datum->predicate d ir) types #f #f)]
[(ref ,maybe-src ,x) [(ref ,maybe-src ,x)
(case ctxt (case ctxt
[(test) [(test)
(let ([t (pred-env-lookup types x)]) (let ([t (pred-env-lookup types x)])
(cond (cond
[(predicate-implies-not? t false-rec) [(predicate-implies-not? t false-rec)
(values true-rec true-rec #f #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 #f #f #f)] (values false-rec false-rec types #f #f)]
[else [else
(values ir t (values ir t
types types
@ -640,12 +646,12 @@ Notes:
[(Lsrc? t) [(Lsrc? t)
(nanopass-case (Lsrc Expr) t (nanopass-case (Lsrc Expr) t
[(quote ,d) [(quote ,d)
(values t t #f #f #f)] (values t t types #f #f)]
[else [else
(values ir t #f #f #f)])] (values ir t types #f #f)])]
[else [else
(values ir t #f #f #f)]))])] (values ir t types #f #f)]))])]
[(seq ,[cptypes : e1 'effect types -> e1 ret1 types t-types f-types] ,e2) [(seq ,[e1 'effect types -> e1 ret1 types t-types f-types] ,e2)
(cond (cond
[(predicate-implies? ret1 'bottom) [(predicate-implies? ret1 'bottom)
(values e1 ret1 types #f #f)] (values e1 ret1 types #f #f)]
@ -653,7 +659,7 @@ Notes:
(let-values ([(e2 ret types t-types f-types) (let-values ([(e2 ret types t-types f-types)
(cptypes e2 ctxt types)]) (cptypes e2 ctxt types)])
(values (make-seq ctxt e1 e2) ret types t-types f-types))])] (values (make-seq ctxt e1 e2) ret types t-types f-types))])]
[(if ,[cptypes : e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) [(if ,[e1 'test types -> 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 ret1 types #f #f)] (values e1 ret1 types #f #f)]
@ -666,10 +672,16 @@ Notes:
(cptypes e3 ctxt types1)]) (cptypes e3 ctxt types1)])
(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 ([(t-types1) (or t-types1 types1)]
(cptypes e2 ctxt t-types1)] [(f-types1) (or f-types1 types1)]
[(e3 ret3 types3 t-types3 f-types3) [(e2 ret2 types2 t-types2 f-types2)
(cptypes e3 ctxt f-types1)]) (cptypes e2 ctxt t-types1)]
[(t-types2) (or t-types2 types2)]
[(f-types2) (or f-types2 types2)]
[(e3 ret3 types3 t-types3 f-types3)
(cptypes e3 ctxt f-types1)]
[(t-types3) (or t-types3 types3)]
[(f-types3) (or f-types3 types3)])
(let ([ir `(if ,e1 ,e2 ,e3)]) (let ([ir `(if ,e1 ,e2 ,e3)])
(cond (cond
[(predicate-implies? ret2 'bottom) ;check bottom first [(predicate-implies? ret2 'bottom) ;check bottom first
@ -720,15 +732,11 @@ Notes:
f-types3 f-types1 f-types3 f-types1
types1 types1
new-types)])))])))])] new-types)])))])))])]
[(set! ,maybe-src ,x ,[cptypes : e 'value types -> e ret types t-types f-types]) [(set! ,maybe-src ,x ,[e 'value types -> e ret types t-types f-types])
(values `(set! ,maybe-src ,x ,e) void-rec types #f #f)] (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)]
[(call ,preinfo ,pr ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) [(call ,preinfo ,pr ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
[ret (primref->result-predicate pr)] [ret (primref->result-predicate pr)])
;; AWK: this seems a bit premature, in some cases ir is not used,
;; AWK: meaning we are constructing this for no reason, and in
;; AWK: some cases we are reconstructing exactly this call
[ir `(call ,preinfo ,pr ,e* ...)])
(let-values ([(ret t) (let-values ([(ret t)
(let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
(if (null? e*) (if (null? e*)
@ -743,9 +751,9 @@ Notes:
(pred-env-add/ref t (car e*) pred)))))]) (pred-env-add/ref t (car e*) pred)))))])
(cond (cond
[(predicate-implies? ret 'bottom) [(predicate-implies? ret 'bottom)
(values ir ret t #f #f)] (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)]
[(not (arity-okay? (primref-arity pr) (length e*))) [(not (arity-okay? (primref-arity pr) (length e*)))
(values ir 'bottom t #f #f)] (values `(call ,preinfo ,pr ,e* ...) 'bottom t #f #f)]
[(and (fx= (length e*) 2) [(and (fx= (length e*) 2)
(or (eq? (primref-name pr) 'eq?) (or (eq? (primref-name pr) 'eq?)
(eq? (primref-name pr) 'eqv?))) (eq? (primref-name pr) 'eqv?)))
@ -759,7 +767,9 @@ Notes:
(values (make-seq ctxt (make-seq 'effect e1 e2) false-rec) (values (make-seq ctxt (make-seq 'effect e1 e2) false-rec)
false-rec t #f #f)] false-rec t #f #f)]
[else [else
(values ir ret types (values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test) (and (eq? ctxt 'test)
(pred-env-add/ref (pred-env-add/ref
(pred-env-add/ref t e1 r2) (pred-env-add/ref t e1 r2)
@ -780,13 +790,15 @@ Notes:
(values (make-seq ctxt (car e*) false-rec) (values (make-seq ctxt (car e*) false-rec)
false-rec t #f #f)] false-rec t #f #f)]
[else [else
(values ir ret types (values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test) (and (eq? ctxt 'test)
(pred-env-add/ref t (car e*) pred)) (pred-env-add/ref t (car e*) pred))
#f)]))]))] #f)]))]))]
[(and (fx>= (length e*) 1) [(and (fx>= (length e*) 1)
(eq? (primref-name pr) '$record)) (eq? (primref-name pr) '$record))
(values ir (rtd->record-predicate (car e*)) t #f #f)] (values `(call ,preinfo ,pr ,e* ...) (rtd->record-predicate (car e*)) t #f #f)]
[(and (fx= (length e*) 2) [(and (fx= (length e*) 2)
(or (eq? (primref-name pr) 'record?) (or (eq? (primref-name pr) 'record?)
(eq? (primref-name pr) '$sealed-record?))) (eq? (primref-name pr) '$sealed-record?)))
@ -823,7 +835,9 @@ Notes:
(pred-env-add/ref types (car e*) pred)) (pred-env-add/ref types (car e*) pred))
#f))] #f))]
[else [else
(values ir ret types (values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test) (and (eq? ctxt 'test)
(pred-env-add/ref types (car e*) pred)) (pred-env-add/ref types (car e*) pred))
#f)]))] #f)]))]
@ -843,7 +857,7 @@ Notes:
(values `(call ,preinfo ,pr ,e* ...) (values `(call ,preinfo ,pr ,e* ...)
ret t #f #f))] ret t #f #f))]
[else [else
(values ir ret t #f #f)])] (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
[(and (fx= (length e*) 1) [(and (fx= (length e*) 1)
(eq? (primref-name pr) 'inexact?)) (eq? (primref-name pr) 'inexact?))
(cond (cond
@ -859,7 +873,7 @@ Notes:
(values `(call ,preinfo ,pr ,e* ...) (values `(call ,preinfo ,pr ,e* ...)
ret t #f #f))] ret t #f #f))]
[else [else
(values ir ret t #f #f)])] (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
[(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) [(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
(all-set? (prim-mask safeongoodargs) (primref-flags pr)) (all-set? (prim-mask safeongoodargs) (primref-flags pr))
(andmap (lambda (r n) (andmap (lambda (r n)
@ -870,7 +884,7 @@ Notes:
(values `(call ,preinfo ,pr ,e* ...) (values `(call ,preinfo ,pr ,e* ...)
ret types #f #f))] ret types #f #f))]
[else [else
(values ir ret t #f #f)])))] (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])))]
[(case-lambda ,preinfo ,cl* ...) [(case-lambda ,preinfo ,cl* ...)
(let ([cl* (map (lambda (cl) (let ([cl* (map (lambda (cl)
(nanopass-case (Lsrc CaseLambdaClause) cl (nanopass-case (Lsrc CaseLambdaClause) cl
@ -881,9 +895,9 @@ Notes:
(with-output-language (Lsrc CaseLambdaClause) (with-output-language (Lsrc CaseLambdaClause)
`(clause (,x* ...) ,interface ,body)))])) `(clause (,x* ...) ,interface ,body)))]))
cl*)]) cl*)])
(values `(case-lambda ,preinfo ,cl* ...) 'procedure #f #f #f))] (values `(case-lambda ,preinfo ,cl* ...) 'procedure types #f #f))]
[(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...) [(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
;; pulled from cpnanopass ;; pulled from cpnanopass
(define find-matching-clause (define find-matching-clause
(lambda (len x** interface* body* kfixed kvariable kfail) (lambda (len x** interface* body* kfixed kvariable kfail)
@ -905,9 +919,11 @@ Notes:
(cptypes body ctxt t)]) (cptypes body ctxt t)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test) [t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types)) (not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test) [f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types)) (not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*) (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
@ -925,24 +941,29 @@ Notes:
(if (fx= i 0) (if (fx= i 0)
(list (if (null? r*) 'null 'pair)) (list (if (null? r*) 'null 'pair))
(cons (car r*) (f (fx- i 1) (cdr r*)))))))) (cons (car r*) (f (fx- i 1) (cdr r*))))))))
(lambda () (values ir 'bottom #f #f #f))))] (lambda () (values ir 'bottom types #f #f))))]
[(call ,preinfo ,[cptypes : e0 'value types -> e0 ret0 types0 t-types0 f-types0] [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0]
,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(values `(call ,preinfo ,e0 ,e* ...) (values `(call ,preinfo ,e0 ,e* ...)
#f (pred-env-add/ref #f
(pred-env-intersect/base (pred-env-add/ref
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) (pred-env-intersect/base
types0 types) e0 'procedure) #f #f)] (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
[(letrec ((,x* ,[cptypes : e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body) types0 types)
e0 'procedure)
#f #f)]
[(letrec ((,x* ,[e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body)
(let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
[t (fold-left pred-env-add t x* r*)]) [t (fold-left pred-env-add t x* r*)])
(let-values ([(body ret n-types t-types f-types) (let-values ([(body ret n-types t-types f-types)
(cptypes body ctxt t)]) (cptypes body ctxt t)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test) [t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types)) (not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test) [f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types)) (not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*) (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
@ -961,9 +982,11 @@ Notes:
(cptypes body ctxt types)]) (cptypes body ctxt types)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test) [t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types)) (not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test) [f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types)) (not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*) (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
@ -972,60 +995,51 @@ Notes:
[,pr [,pr
(values ir (values ir
(and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure) (and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure)
#f #f #f)] types #f #f)]
[(foreign ,conv ,name ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) [(foreign ,conv ,name ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
#f types #f #f)] #f types #f #f)]
[(fcallable ,conv ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) [(fcallable ,conv ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type)
#f types #f #f)] #f types #f #f)]
[(record ,rtd ,[cptypes : rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re] [(record ,rtd ,[rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re]
,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(values `(record ,rtd ,rtd-expr ,e* ...) (values `(record ,rtd ,rtd-expr ,e* ...)
(rtd->record-predicate rtd-expr) (rtd->record-predicate rtd-expr)
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
#f #f)] #f #f)]
[(record-ref ,rtd ,type ,index ,[cptypes : e 'value types -> e ret types t-types f-types]) [(record-ref ,rtd ,type ,index ,[e 'value types -> e ret types t-types f-types])
(values `(record-ref ,rtd ,type ,index ,e) (values `(record-ref ,rtd ,type ,index ,e)
#f #f
(pred-env-add/ref types e '$record) (pred-env-add/ref types e '$record)
#f #f)] #f #f)]
[(record-set! ,rtd ,type ,index ,[cptypes : e1 'value types -> e1 ret1 types1 t-types1 f-types1] [(record-set! ,rtd ,type ,index ,[e1 'value types -> e1 ret1 types1 t-types1 f-types1]
,[cptypes : e2 'value types -> e2 ret2 types2 t-types2 f-types2]) ;can they be reordered? ,[e2 'value types -> e2 ret2 types2 t-types2 f-types2])
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) (values `(record-set! ,rtd ,type ,index ,e1 ,e2)
void-rec void-rec
(pred-env-add/ref (pred-env-intersect/base types1 types2 types) (pred-env-add/ref (pred-env-intersect/base types1 types2 types)
e1 '$record) e1 '$record)
#f #f)] #f #f)]
[(record-type ,rtd ,[cptypes : e 'value types -> e ret types t-types f-types]) [(record-type ,rtd ,[e 'value types -> e ret types t-types f-types])
(values `(record-type ,rtd ,e) (values `(record-type ,rtd ,e)
#f types #f #f)] #f types #f #f)]
[(record-cd ,rcd ,rtd-expr ,[cptypes : e 'value types -> e ret types t-types f-types]) [(record-cd ,rcd ,rtd-expr ,[e 'value types -> e ret types t-types f-types])
(values `(record-cd ,rcd ,rtd-expr ,e) (values `(record-cd ,rcd ,rtd-expr ,e)
#f types #f #f)] #f types #f #f)]
[(immutable-list (,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) [(immutable-list (,[e* 'value types -> e* r* t* t-t* f-t*] ...)
,[cptypes : e 'value types -> e ret types t-types f-types]) ,[e 'value types -> e ret types t-types f-types])
(values `(immutable-list (,e* ...) ,e) (values `(immutable-list (,e* ...) ,e)
ret types #f #f)] #;CHECK ret types #f #f)]
[(moi) (values ir #f #f #f #f)] [(moi) (values ir #f types #f #f)]
[(pariah) (values ir void-rec #f #f #f)] [(pariah) (values ir void-rec types #f #f)]
[(cte-optimization-loc ,box ,[cptypes : e 'value types -> e ret types t-types f-types]) [(cte-optimization-loc ,box ,[e 'value types -> e ret types t-types f-types])
(values `(cte-optimization-loc ,box ,e) (values `(cte-optimization-loc ,box ,e)
ret types #f #f)] #;CHECK ret types #f #f)]
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
[(profile ,src) (values ir #f #f #f #f)] [(profile ,src) (values ir #f types #f #f)]
#;[else (values ir #f #f #f #f)]
[else ($oops who "unrecognized record ~s" ir)]) [else ($oops who "unrecognized record ~s" ir)])
(Expr ir ctxt types)) (Expr ir ctxt types))
(define (cptypes ir ctxt types)
(let-values ([(ir ret r-types t-types f-types)
(cptypes/raw ir ctxt types)])
(values ir
ret
(or r-types types)
(or t-types r-types types)
(or f-types r-types types))))
(lambda (ir) (lambda (ir)
(let-values ([(ir ret types t-types f-types) (let-values ([(ir ret types t-types f-types)
(cptypes ir 'value pred-env-empty)]) (cptypes ir 'value pred-env-empty)])

141
s/fxmap.ss
View File

@ -33,6 +33,8 @@
;; internals ;; internals
; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right ; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right
; $leaf? make-$leaf $leaf-key $leaf-val ; $leaf? make-$leaf $leaf-key $leaf-val
;; We treat $empty as a singleton, so don't use these functions.
; $empty? make-$empty ; $empty? make-$empty
) )
@ -52,18 +54,29 @@
(nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}) (nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0})
(sealed #t)) (sealed #t))
;; constants (define-syntax let-branch
(syntax-rules ()
[(_ ([(p m l r) d] ...) exp ...)
(let ([p ($branch-prefix d)] ...
[m ($branch-mask d)] ...
[l ($branch-left d)] ...
[r ($branch-right d)] ...)
exp ...)]))
;; constants & empty
(define empty-fxmap (make-$empty)) (define empty-fxmap (make-$empty))
(define (fxmap-empty? x) (eq? empty-fxmap x))
;; predicate ;; predicate
(define (fxmap? x) (define (fxmap? x)
(or ($branch? x) (or ($branch? x)
($leaf? x) ($leaf? x)
($empty? x))) (eq? empty-fxmap x)))
;; count, changes & empty ;; count & changes
(define (fxmap-count d) (define (fxmap-count d)
(cond (cond
@ -80,8 +93,6 @@
($leaf-changes d)] ($leaf-changes d)]
[else 0])) [else 0]))
(define fxmap-empty? $empty?)
;; ref ;; ref
(define (fxmap-ref/leaf d key) (define (fxmap-ref/leaf d key)
@ -251,13 +262,13 @@
(fx+ (fxmap-changes l) (fxmap-changes r)))) (fx+ (fxmap-changes l) (fxmap-changes r))))
(define (br* p m l r) (define (br* p m l r)
(cond [($empty? r) l] (cond [(eq? empty-fxmap r) l]
[($empty? l) r] [(eq? empty-fxmap l) r]
[else (br p m l r)])) [else (br p m l r)]))
(define (br*/base p m l r base) (define (br*/base p m l r base)
(cond [($empty? r) l] (cond [(eq? empty-fxmap r) l]
[($empty? l) r] [(eq? empty-fxmap l) r]
[(and ($branch? base) [(and ($branch? base)
(eq? l ($branch-left base)) (eq? l ($branch-left base))
(eq? r ($branch-right base))) (eq? r ($branch-right base)))
@ -272,8 +283,8 @@
(define (join* p1 d1 p2 d2) (define (join* p1 d1 p2 d2)
(cond (cond
[($empty? d1) d2] [(eq? empty-fxmap d1) d2]
[($empty? d2) d1] [(eq? empty-fxmap d2) d1]
[else (join p1 d1 p2 d2)])) [else (join p1 d1 p2 d2)]))
(define (branching-bit p m) (define (branching-bit p m)
@ -349,10 +360,10 @@
(cond [(fx= k1 k2) (f d1 d2)] (cond [(fx= k1 k2) (f d1 d2)]
[else (join* k1 (g1 d1) k2 (g2 d2))]))] [else (join* k1 (g1 d1) k2 (g2 d2))]))]
[else ; ($empty? d1) [else ; (eq? empty-fxmap d1)
(g2 d2)])))] (g2 d2)])))]
[else ;; ($empty? d2) [else ; (eq? empty-fxmap d2)
(g1 d1)])] (g1 d1)])]
[($leaf? d1) [($leaf? d1)
@ -373,20 +384,89 @@
(cond [(fx= k1 k2) (f d1 d2)] (cond [(fx= k1 k2) (f d1 d2)]
[else (join* k1 (g1 d1) k2 (g2 d2))]))] [else (join* k1 (g1 d1) k2 (g2 d2))]))]
[else ; ($empty? d2) [else ; (eq? empty-fxmap d2)
(g1 d1)])))] (g1 d1)])))]
[else ; ($empty? d1) [else ; (eq? empty-fxmap d1)
(g2 d2)])) (g2 d2)]))
(define-syntax let-branch ;; merge*
(syntax-rules () ; like merge, but the result is (void)
[(_ ([(p m l r) d] ...) exp ...)
(let ([p ($branch-prefix d)] ... (define (fxmap-merge* f id g1 g2 d1 d2)
[m ($branch-mask d)] ... (define (merge* f id g1 g2 d1 d2)
[l ($branch-left d)] ... (define-syntax go
[r ($branch-right d)] ...) (syntax-rules ()
exp ...)])) [(_ d1 d2) (merge* f id g1 g2 d1 d2)]))
(cond
[(eq? d1 d2) (id d1)]
[($branch? d1)
(cond
[($branch? d2)
(let-branch ([(p1 m1 l1 r1) d1]
[(p2 m2 l2 r2) d2])
(cond
[(fx> m1 m2) (cond
[(nomatch? p2 p1 m1) (g1 d1) (g2 d2)]
[(fx<= p2 p1) (go l1 d2) (g1 r1)]
[else (g1 l1) (go r1 d2)])]
[(fx> m2 m1) (cond
[(nomatch? p1 p2 m2) (g1 d1) (g2 d2)]
[(fx<= p1 p2) (go d1 l2) (g2 r2)]
[else (g2 l2) (go d1 r2)])]
[(fx= p1 p2) (go l1 l2) (go r1 r2)]
[else (g1 d1) (g2 d2)]))]
[else ; ($leaf? d2)
(let ([k2 ($leaf-key d2)])
(let merge*0 ([d1 d1])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d1)
(let-branch ([(p1 m1 l1 r1) d1])
(cond [(nomatch? k2 p1 m1) (g1 d1) (g2 d2)]
[(fx<= k2 p1) (merge*0 l1) (g1 r1)]
[else (g1 l1) (merge*0 r1)]))]
[else ; ($leaf? d1)
(let ([k1 ($leaf-key d1)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (g1 d1) (g2 d2)]))])))])]
[($leaf? d1)
(let ([k1 ($leaf-key d1)])
(let merge*0 ([d2 d2])
(cond
[(eq? d1 d2)
(id d1)]
[($branch? d2)
(let-branch ([(p2 m2 l2 r2) d2])
(cond [(nomatch? k1 p2 m2) (g1 d1) (g2 d2)]
[(fx<= k1 p2) (merge*0 l2) (g2 r2)]
[else (g2 l2) (merge*0 r2)]))]
[else ; ($leaf? d2)
(let ([k2 ($leaf-key d2)])
(cond [(fx= k1 k2) (f d1 d2)]
[else (g1 d1) (g2 d2)]))])))]))
(cond
[(eq? d1 d2)
(id d1)]
[(eq? empty-fxmap d1)
(g2 d2)]
[(eq? empty-fxmap d2)
(g1 d1)]
[else
(merge* f id g1 g2 d1 d2)])
(void))
;; for-each
(define (fxmap-for-each g1 d1) (define (fxmap-for-each g1 d1)
(cond (cond
@ -395,17 +475,16 @@
(fxmap-for-each g1 ($branch-right d1))] (fxmap-for-each g1 ($branch-right d1))]
[($leaf? d1) [($leaf? d1)
(g1 ($leaf-key d1) ($leaf-val d1))] (g1 ($leaf-key d1) ($leaf-val d1))]
[else ; ($empty? d1) [else ; (eq? empty-fxmap d1)
(void)]) (void)])
(void)) (void))
(define (fxmap-for-each/diff f g1 g2 d1 d2) (define (fxmap-for-each/diff f g1 g2 d1 d2)
(fxmap-merge (lambda (prefix mask left right) (make-$empty)) (fxmap-merge* (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)))
(lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)) (make-$empty)) (lambda (x) (void))
(lambda (x) (make-$empty)) (lambda (x) (fxmap-for-each g1 x))
(lambda (x) (fxmap-for-each g1 x) (make-$empty)) (lambda (x) (fxmap-for-each g2 x))
(lambda (x) (fxmap-for-each g2 x) (make-$empty)) d1
d1 d2)
d2)
(void)) (void))
) )