From eb29023ed9b58973d9bf103596a2709b3e6134cf Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sun, 12 May 2019 18:02:11 -0300 Subject: [PATCH] cptypes: add bottom-fxmap It is a fxmap that is is full of 'bottom. original commit: c171fca3345de3190e8d915b0cdf4c11d5ec055c --- mats/cptypes.ms | 20 ++++++ s/cptypes.ss | 187 ++++++++++++++++++++++++++++-------------------- 2 files changed, 129 insertions(+), 78 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 9b558cf639..4692bbebbe 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -334,6 +334,26 @@ '(lambda (x y z f) (let ([t (vector? x)]) (if (if y #f z) (f t 1) (f t 2)))))) + (cptypes-equivalent-expansion? + '(lambda (t b) + (if (if t (newline) (unbox b)) (vector? b) (box? b))) + '(lambda (t b) + (if (if t (newline) (unbox b)) (vector? b) #t))) + (cptypes-equivalent-expansion? + '(lambda (t b) + (if (if t (unbox b) (newline)) (vector? b) (box? b))) + '(lambda (t b) + (if (if t (unbox b) (newline)) (vector? b) #t))) + (cptypes-equivalent-expansion? + '(lambda (t b) + (if (if t #f (unbox b)) (vector? b) (box? b))) + '(lambda (t b) + (if (if t #f (unbox b)) #f (box? b)))) + (cptypes-equivalent-expansion? + '(lambda (t b) + (if (if t (unbox b) #f) (vector? b) (box? b))) + '(lambda (t b) + (if (if t (unbox b) #f) #f (box? b)))) ) (mat cptype-directly-applied-case-lambda diff --git a/s/cptypes.ss b/s/cptypes.ss index d34a72a93e..8e55b2e6ef 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -138,27 +138,38 @@ Notes: (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0}) (sealed #t)) - (module (pred-env-empty + (module (pred-env-empty pred-env-bottom pred-env-add pred-env-remove/base pred-env-lookup pred-env-intersect/base pred-env-union/super-base pred-env-rebase pred-intersect pred-union) (import fxmap) + + ; a fake fxmap that is full of 'bottom + (define-record-type $bottom + (nongenerative #{$bottom koj7zosgebxioicmj4lgopip0-0}) + (sealed #t)) + + (define bottom-fxmap (make-$bottom)) (define pred-env-empty empty-fxmap) + (define pred-env-bottom bottom-fxmap) + (define (pred-env-add/key types key pred) (cond [(and pred - (not (eq? pred 'ptr))) ; filter 'ptr to reduce the size + (not (eq? pred 'ptr)) ; filter 'ptr to reduce the size + (not (eq? types bottom-fxmap))) (let ([old (fxmap-ref types key #f)]) (cond [(not old) (fxmap-set types key pred)] [else (let ([new (pred-intersect old pred)]) - (if (eq? old new) - types - (fxmap-set types key new)))]))] + (cond + [(eq? new old) types] + [(eq? new 'bottom) bottom-fxmap] + [else (fxmap-set types key new)]))]))] [else types])) @@ -168,12 +179,21 @@ Notes: (pred-env-add/key types (prelex-counter x) pred)] [else types])) + ; When types is bottom-fxmap, the "association" is not removed (define (pred-env-remove/base types x base) - (fxmap-remove/base types (prelex-counter x) base)) + (cond + [(eq? types bottom-fxmap) + bottom-fxmap] + [else + (fxmap-remove/base types (prelex-counter x) base)])) (define (pred-env-lookup types x) - (and (not (prelex-assigned x)) - (fxmap-ref types (prelex-counter x) #f))) + (cond + [(eq? types bottom-fxmap) + 'bottom] + [else + (and (not (prelex-assigned x)) + (fxmap-ref types (prelex-counter x) #f))])) ; This is conceptually the intersection of the types in `types` and `from` ; but since 'ptr is not stored to save space and time, the implementation @@ -183,6 +203,9 @@ Notes: ; 'number _and_ 'exact-integer -> 'exact-integer (define (pred-env-intersect/base types from base) (cond + [(or (eq? types bottom-fxmap) + (eq? from bottom-fxmap)) + bottom-fxmap] [(fx> (fxmap-changes from) (fxmap-changes types)) (pred-env-intersect/base from types base)] [else @@ -219,7 +242,8 @@ Notes: ; [missing 'ptr] _or_ 'vector -> [missing 'ptr] ; 'box _or_ 'boolean -> [missing 'ptr] ; 'number _or_ 'exact-integer -> 'number - (define (pred-env-union/from from base types new-base) + ; *Internals auxilary function. Does not check bottom-fxmap.* + (define ($pred-env-union/from from base types new-base) ; Calculate the union of types and from, and intersect it with new-base ; Iterate over the difference of from and base. (let ([ret new-base]) @@ -245,20 +269,30 @@ Notes: base new-base) ; Calculate the union of types and from, and intersect it with new-base - ; Use the intermediate bases to minimize the amount of operations - ; required. In particular, base should be the base of types/b and from/b. - (let ([size-types (fx- (fxmap-changes types) (fxmap-changes base))] - [size-from (fx- (fxmap-changes from) (fxmap-changes base))] - [size-new (fx+ (fx- (fxmap-changes types) (fxmap-changes types/b)) - (fx- (fxmap-changes from) (fxmap-changes from/b)))]) - (cond - [(and (fx<= size-types size-from) (fx<= size-types size-new)) - (pred-env-union/from types base from new-base)] - [(fx<= size-from size-new) - (pred-env-union/from from base types new-base)] - [else - (let ([temp (pred-env-union/from from from/b types new-base)]) - (pred-env-union/from types types/b from temp))]))) + ; Use the intermediate bases types/b and from/b to minimize the amount + ; of operations required. + ; In particular, base should be the base of types/b, from/b and new-base. + (cond + [(eq? new-base bottom-fxmap) + bottom-fxmap] + [(eq? types bottom-fxmap) + (pred-env-rebase from base new-base)] + [(eq? from bottom-fxmap) + (pred-env-rebase types base new-base)] + [else + (let ([size-types (fx- (fxmap-changes types) (fxmap-changes base))] + [size-from (fx- (fxmap-changes from) (fxmap-changes base))] + [size-new (fx+ (fx- (fxmap-changes types) (fxmap-changes types/b)) + (fx- (fxmap-changes from) (fxmap-changes from/b)))]) + (cond + [(and (fx<= size-types size-from) (fx<= size-types size-new)) + ($pred-env-union/from types base from new-base)] + [(fx<= size-from size-new) + ($pred-env-union/from from base types new-base)] + [else + (let ([temp ($pred-env-union/from from from/b types new-base)]) + ; temp is never bottom-fxmap here + ($pred-env-union/from types types/b from temp))]))])) (define (pred-union x y) (cond @@ -274,27 +308,32 @@ Notes: [else #f])) (define (pred-env-rebase types base new-base) - (let ([ret types]) - (fxmap-for-each/diff (lambda (key x y) - (let ([z (fxmap-ref types key #f)]) - ;x-> new-base - ;y-> base - ;z-> types - (if (eq? x z) - (set! ret (fxmap-reset/base ret key new-base)) - (set! ret (fxmap-advance/base ret key new-base))))) - (lambda (key x) - (let ([z (fxmap-ref types key #f)]) - ;x-> new-base - ;z-> types - (if (eq? x z) - (set! ret (fxmap-reset/base ret key new-base)) - (set! ret (fxmap-advance/base ret key new-base))))) - (lambda (key x) - ($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base)) - new-base - base) - ret)) + (cond + [(or (eq? types bottom-fxmap) + (eq? new-base bottom-fxmap)) + bottom-fxmap] + [else + (let ([ret types]) + (fxmap-for-each/diff (lambda (key x y) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;y-> base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) + (lambda (key x) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) + (lambda (key x) + ($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base)) + new-base + base) + ret)])) ) (define (pred-env-add/ref types r pred) @@ -637,6 +676,18 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) + + (define (Expr/fix-tf-types ir ctxt types) + (let-values ([(ir ret types t-types f-types) + (Expr ir ctxt types)]) + (values ir ret + types + (if (predicate-implies? ret false-rec) + pred-env-bottom + (or t-types types)) + (if (predicate-implies? ret 'true) + pred-env-bottom + (or f-types types))))) ) (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) [(quote ,d) @@ -646,7 +697,7 @@ Notes: [(test) (let ([t (pred-env-lookup types x)]) (cond - [(predicate-implies-not? t false-rec) + [(predicate-implies? t 'true) (values true-rec true-rec types #f #f)] [(predicate-implies? t false-rec) (values false-rec false-rec types #f #f)] @@ -669,16 +720,16 @@ Notes: [(seq ,[e1 'effect types -> e1 ret1 types t-types f-types] ,e2) (cond [(predicate-implies? ret1 'bottom) - (values e1 ret1 types #f #f)] + (values e1 'bottom pred-env-bottom #f #f)] [else (let-values ([(e2 ret types t-types f-types) (Expr e2 ctxt types)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))])] - [(if ,[e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) + [(if ,[Expr/fix-tf-types : e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) (cond [(predicate-implies? ret1 'bottom) ;check bottom first - (values e1 ret1 types #f #f)] - [(predicate-implies-not? ret1 false-rec) + (values e1 'bottom pred-env-bottom #f #f)] + [(predicate-implies? ret1 'true) (let-values ([(e2 ret types t-types f-types) (Expr e2 ctxt types1)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))] @@ -687,21 +738,15 @@ Notes: (Expr e3 ctxt types1)]) (values (make-seq ctxt e1 e3) ret types t-types f-types))] [else - (let*-values ([(t-types1) (or t-types1 types1)] - [(f-types1) (or f-types1 types1)] - [(e2 ret2 types2 t-types2 f-types2) - (Expr e2 ctxt t-types1)] - [(t-types2) (or t-types2 types2)] - [(f-types2) (or f-types2 types2)] - [(e3 ret3 types3 t-types3 f-types3) - (Expr e3 ctxt f-types1)] - [(t-types3) (or t-types3 types3)] - [(f-types3) (or f-types3 types3)]) + (let-values ([(e2 ret2 types2 t-types2 f-types2) + (Expr/fix-tf-types e2 ctxt t-types1)] + [(e3 ret3 types3 t-types3 f-types3) + (Expr/fix-tf-types e3 ctxt f-types1)]) (let ([ir `(if ,e1 ,e2 ,e3)]) (cond [(and (predicate-implies? ret2 'bottom) ;check bottom first (predicate-implies? ret3 'bottom)) ;check bottom first - (values ir ret3 types3 t-types3 f-types3)] + (values ir 'bottom pred-env-bottom #f #f)] [(predicate-implies? ret2 'bottom) ;check bottom first (values (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3) ret3 types3 t-types3 f-types3)] @@ -714,21 +759,11 @@ Notes: types1 types1)]) (values ir - (cond - [(and (eq? ctxt 'test) - (predicate-implies-not? ret2 false-rec) - (predicate-implies-not? ret3 false-rec)) - true-rec] - [else - (pred-union ret2 ret3)]) + (pred-union ret2 ret3) new-types (cond [(not (eq? ctxt 'test)) #f] ; don't calculate t-types outside a test context - [(predicate-implies? ret2 false-rec) - (pred-env-rebase t-types3 types1 new-types)] - [(predicate-implies? ret3 false-rec) - (pred-env-rebase t-types2 types1 new-types)] [(and (eq? types2 t-types2) (eq? types3 t-types3)) #f] ; don't calculate t-types when it will be equal to new-types @@ -740,10 +775,6 @@ Notes: (cond [(not (eq? ctxt 'test)) #f] ; don't calculate f-types outside a test context - [(predicate-implies-not? ret2 false-rec) - (pred-env-rebase f-types3 types1 new-types)] - [(predicate-implies-not? ret3 false-rec) - (pred-env-rebase f-types2 types1 new-types)] [(and (eq? types2 f-types2) (eq? types3 f-types3)) #f] ; don't calculate t-types when it will be equal to new-types @@ -771,9 +802,9 @@ Notes: (pred-env-add/ref t (car e*) pred)))))]) (cond [(predicate-implies? ret 'bottom) - (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)] + (values `(call ,preinfo ,pr ,e* ...) 'bottom pred-env-bottom #f #f)] [(not (arity-okay? (primref-arity pr) (length e*))) - (values `(call ,preinfo ,pr ,e* ...) 'bottom t #f #f)] + (values `(call ,preinfo ,pr ,e* ...) 'bottom pred-env-bottom #f #f)] [(and (fx= (length e*) 2) (or (eq? (primref-name pr) 'eq?) (eq? (primref-name pr) 'eqv?))) @@ -968,7 +999,7 @@ Notes: (if (fx= i 0) (list (if (null? r*) null-rec 'pair)) (cons (car r*) (f (fx- i 1) (cdr r*)))))))) - (lambda () (values ir 'bottom types #f #f))))] + (lambda () (values ir 'bottom pred-env-bottom #f #f))))] [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0] ,[e* 'value types -> e* r* t* t-t* f-t*] ...) (values `(call ,preinfo ,e0 ,e* ...)