Fixes and small improvements for type recovery.
Removed counter field from prelex, using the operand field instead to provide the index into the fxmap. This follows other uses within the compiler where we use the operand field as a little place for state that is used within a single pass. This has a few advantages. First, it keeps the record a little smaller. Second, it means that the prelex numbering can start from 0 for each compilation unit, which should help keep the numbers for the fxmap a bit smaller in longer running sessions with multiple calls to the compiler. Finally, it avoids adding to the burden of the tc-mutex, since within the pass it is safe for us to set the prelexes, since only the instance of the pass holding this block of code has a handle on it. As part of this change prelex-counter is now defined in cptypes and the operand is cleared after the variables go out of scope. base-lang.ss Fixed the highest-set-bit function in fxmap so that it will work in the 32-bit versions of Chez Scheme. The fxsrl by 32 raises an exception, and was leading to tests to fail in 32-bit mode. fxmap.ss Restructured predicate-implies? so that it uses committed choice instead of uncommitted choice in comparing x and y. Basically, this means, instead of doing: (or (and (predicate-1? x) (predicate-1? y) ---) (and (predicate-2? x) (predicate-2? y) ---) ...) we now do: (cond [(predicate-1? x) (and (predicate-1? y) ---)] [(predicate-2? x) (and (predicate-2? y) ---)] ...) This avoids running predicates on x that we know will fail because an earlier predicate matches, generally getting out of the predicate faster. This did require a little restructuring, because in some cases x was dominant and in other cases y was dominant. This is now restructured with y dominate, after the eq? and x 'bottom check. Replaced let-values calls with cata-morphism syntax, including removal of maps that built up a list of values that then needed to be separated out with (map car ...) (map cadr ...) etc. calls. This avoid building up structures we don't need, since the nanopass framework will generate a mutltivalued let for these situations. The if clause in cptypes/raw now uses types1 (the result of the recursive call on e1) in place of the incoming types clause when processing the e2 or e3 expressions in the cases where e1 is known statically to produce either a false or non-false value. Fixed a bug with directly-applied variable arity lambda. The original code marked all directly-applied variable arity lambda's as producing bottom, because it was chacking for the interface to be equal to the number of arguments. However, variable arity functions are represented with a negative number. For instance, the original code would transform the expression: (begin ((lambda (a . b) (set! t (cons* b a t))) 'a 'b 'c) t) to ((lambda (a . b) (set! t (cons* b a t))) 'a 'b 'c) anticipating that the call would raise an error, however, it is a perfectly valid (if some what unusual) expression. I tried to come up with a test for this, however, without building something fairly complicated, it is difficult to get past cp0 without cp0 turning it into something like: (let ([b (list 'b 'c)]) (set! t (cons* b 'a t)) t) Fixed make-time, time-second-set!, and time-second to indicate that second can be an exact-integer, since it is not really restricted to the fixnum range (and if fact we even test this fact in the mats on 32-bit machines). primdata.ss Changed check of prelex-was-assigned (which is not reliably on the input to any give pass) with prelex-assigned, which should always have an accurate, if conservative, value in it. Added enable-type-recovery parameter to allow the type recover to be turned on and off, and added cptype to the cp0 not run path that runs cpletrec, so that cptypes can be run independent of cp0. This is helpful for testing and allows us to benefit from type recovery, even in cases where we do not want cp0 to perform any inlining. compile.ss, front.ss, primdata.ss Stylistic changes, mostly for consistency with other parts of the compiler, though I'm not married to these changes if you'd really prefer to keep things the way the are. 1. clauses of define-record type now use parenthesis instead of square brackets. 2. indented by 2 spaces where things were only indented by one space 3. define, let, define-pass, nanopass pass productions clauses, now use parenthesis for outer markers instead of square brackets. fxmap.ss, original commit: 5c6c5a534ff708d4bff23f6fd48fe6726a5c4e05
This commit is contained in:
Andy Keep
Gustavo Massaccesi
parent
05c81335a4
commit
18b12f21fd
|
|
@ -314,6 +314,89 @@
|
|||
(if (if y #f z) (f t 1) (f t 2))))))
|
||||
)
|
||||
|
||||
(mat cptype-directly-applied-case-lambda
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t ((lambda (x y) (cons y x)) 'a 'b)])
|
||||
(list t t))))
|
||||
'((b . a) (b . a)))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)])
|
||||
(list t t))))
|
||||
'(((b c d) . a) ((b c d) . a)))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t ((case-lambda
|
||||
[(x) (cons 'first x)]
|
||||
[(x y) (cons* 'second y x)]
|
||||
[(x . y) (cons* 'third y x)]) 'a 'b)])
|
||||
(list t t))))
|
||||
'((second b . a) (second b . a)))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t ((case-lambda
|
||||
[(x) (cons 'first x)]
|
||||
[(x y) (cons* 'second y x)]
|
||||
[(x . y) (cons* 'third y x)]) 'a 'b 'c)])
|
||||
(list t t))))
|
||||
'((third (b c) . a) (third (b c) . a)))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t 'z])
|
||||
((lambda args (set! t (cons args t))) 'a 'b 'c)
|
||||
t)))
|
||||
'((a b c) . z))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t 'z])
|
||||
((lambda args (set! t (cons args t))) 'a 'b 'c)
|
||||
t)))
|
||||
'((a b c) . z))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t 'z])
|
||||
((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c)
|
||||
t)))
|
||||
'((b c) a . z))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t 'z])
|
||||
((case-lambda
|
||||
[(x) (set! t (cons* 'first x t))]
|
||||
[(x y) (set! t (cons* 'second y x t))]
|
||||
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b)
|
||||
t)))
|
||||
'(second b a . z))
|
||||
(equal?
|
||||
(parameterize ([enable-type-recovery #t]
|
||||
[run-cp0 (lambda (cp0 x) x)])
|
||||
(eval
|
||||
'(let ([t 'z])
|
||||
((case-lambda
|
||||
[(x) (set! t (cons* 'first x t))]
|
||||
[(x y) (set! t (cons* 'second y x t))]
|
||||
[(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd)
|
||||
t)))
|
||||
'(third (b c d) a . z))
|
||||
)
|
||||
|
||||
(define (test-chain/preamble/self preamble check-self? l)
|
||||
(let loop ([l l])
|
||||
(if (null? l)
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
|
||||
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec
|
||||
prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
|
||||
prelex-source prelex-operand prelex-operand-set! prelex-uname prelex-counter make-prelex*
|
||||
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
|
||||
target-fixnum? target-bignum?)
|
||||
|
||||
(module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level)
|
||||
|
|
@ -78,16 +78,15 @@
|
|||
prelex-flags prelex-flags-set!
|
||||
prelex-source
|
||||
prelex-operand prelex-operand-set!
|
||||
prelex-uname
|
||||
prelex-counter)
|
||||
prelex-uname)
|
||||
(define-record-type prelex
|
||||
(nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-1})
|
||||
(nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-2})
|
||||
(sealed #t)
|
||||
(fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname) (mutable $counter))
|
||||
(fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (name flags source operand)
|
||||
(new name flags source operand #f #f)))))
|
||||
(new name flags source operand #f)))))
|
||||
(define prelex-uname
|
||||
(lambda (id)
|
||||
(or (prelex-$uname id)
|
||||
|
|
@ -95,16 +94,6 @@
|
|||
(with-tc-mutex
|
||||
(or (prelex-$uname id)
|
||||
(begin (prelex-$uname-set! id uname) uname)))))))
|
||||
(define counter 0)
|
||||
(define prelex-counter
|
||||
(lambda (id)
|
||||
(or (prelex-$counter id)
|
||||
(with-tc-mutex
|
||||
(or (prelex-$counter id)
|
||||
(let ([c counter])
|
||||
(set! counter (fx1+ counter))
|
||||
(prelex-$counter-set! id c)
|
||||
c))))))
|
||||
(record-writer (record-type-descriptor prelex)
|
||||
(lambda (x p wr)
|
||||
(fprintf p "~s" (prelex-name x)))))
|
||||
|
|
|
|||
23
s/compile.ss
23
s/compile.ss
|
|
@ -550,6 +550,12 @@
|
|||
(when ($enable-check-prelex-flags)
|
||||
($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep))))))
|
||||
|
||||
(define cptypes
|
||||
(lambda (x)
|
||||
(if (enable-type-recovery)
|
||||
($pass-time 'cptypes (lambda () ($cptypes x)))
|
||||
x)))
|
||||
|
||||
(define compile-file-help
|
||||
(lambda (op hostop wpoop machine sfd do-read outfn)
|
||||
(include "types.ss")
|
||||
|
|
@ -567,7 +573,8 @@
|
|||
[$compile-profile ($compile-profile)]
|
||||
[generate-interrupt-trap (generate-interrupt-trap)]
|
||||
[$optimize-closures ($optimize-closures)]
|
||||
[enable-cross-library-optimization (enable-cross-library-optimization)])
|
||||
[enable-cross-library-optimization (enable-cross-library-optimization)]
|
||||
[enable-type-recovery (enable-type-recovery)])
|
||||
(emit-header op (constant machine-type))
|
||||
(when hostop (emit-header hostop (host-machine-type)))
|
||||
(when wpoop (emit-header wpoop (host-machine-type)))
|
||||
|
|
@ -647,7 +654,7 @@
|
|||
(set! cpletrec-ran? #t)
|
||||
(let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
|
||||
[waste (check-prelex-flags x 'cp0)]
|
||||
[x ($pass-time 'cptypes (lambda () (do-trace $cptypes x)))]
|
||||
[x (cptypes x)]
|
||||
[waste (check-prelex-flags x 'cptypes)]
|
||||
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
|
||||
[waste (check-prelex-flags x 'cpletrec)])
|
||||
|
|
@ -655,8 +662,10 @@
|
|||
x2)])
|
||||
(if cpletrec-ran?
|
||||
x
|
||||
(let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))])
|
||||
(check-prelex-flags x 'cpletrec)
|
||||
(let* ([x (cptypes x)]
|
||||
[waste (check-prelex-flags x 'cptypes)]
|
||||
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
|
||||
[waste (check-prelex-flags x 'cpletrec)])
|
||||
x))))]
|
||||
[x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
|
||||
[waste (check-prelex-flags x2b 'cpcheck)]
|
||||
|
|
@ -1472,10 +1481,12 @@
|
|||
(lambda (x)
|
||||
(set! cpletrec-ran? #t)
|
||||
(let* ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]
|
||||
[x ($pass-time 'cptypes (lambda () ($cptypes x)))])
|
||||
[x (cptypes x)])
|
||||
($pass-time 'cpletrec (lambda () ($cpletrec x)))))
|
||||
x2)])
|
||||
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
|
||||
(if cpletrec-ran? x
|
||||
(let ([x (cptypes x)])
|
||||
($pass-time 'cpletrec (lambda () ($cpletrec x)))))))]
|
||||
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
|
||||
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
|
||||
(when (and (expand/optimize-output) (not ($noexpand? x0)))
|
||||
|
|
|
|||
|
|
@ -4361,6 +4361,7 @@
|
|||
[(e1 e2) (dofxlogbit1 e2 e1)])
|
||||
(define-inline 3 fxcopy-bit
|
||||
[(e1 e2 e3)
|
||||
;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here.
|
||||
(and (fixnum-constant? e3)
|
||||
(case (constant-value e3)
|
||||
[(0) (dofxlogbit0 e1 e2)]
|
||||
|
|
|
|||
572
s/cptypes.ss
572
s/cptypes.ss
|
|
@ -61,12 +61,22 @@ Notes:
|
|||
|#
|
||||
|
||||
|
||||
[define $cptypes
|
||||
[let ()
|
||||
(define $cptypes
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
(include "fxmap.ss")
|
||||
|
||||
(define prelex-counter
|
||||
(let ()
|
||||
(define count 0)
|
||||
(lambda (x)
|
||||
(or (prelex-operand x)
|
||||
(let ([c count])
|
||||
(set! count (fx+ count 1))
|
||||
(prelex-operand-set! x c)
|
||||
c)))))
|
||||
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define void-rec `(quote ,(void)))
|
||||
(define true-rec `(quote #t))
|
||||
|
|
@ -141,7 +151,7 @@ Notes:
|
|||
|
||||
(define (pred-env-add types x pred)
|
||||
(cond
|
||||
[(and x (not (prelex-was-assigned x)))
|
||||
[(and x (not (prelex-assigned x)))
|
||||
(pred-env-add/key types (prelex-counter x) pred)]
|
||||
[else types]))
|
||||
|
||||
|
|
@ -149,7 +159,7 @@ Notes:
|
|||
(fxmap-remove/base types (prelex-counter x) base))
|
||||
|
||||
(define (pred-env-lookup types x)
|
||||
(and (not (prelex-was-assigned x))
|
||||
(and (not (prelex-assigned x))
|
||||
(fxmap-ref types (prelex-counter x) #f)))
|
||||
|
||||
; This is conceptually the intersection of the types in `types` and `from`
|
||||
|
|
@ -166,13 +176,13 @@ Notes:
|
|||
[else
|
||||
(let ([ret types])
|
||||
(fxmap-for-each/diff (lambda (key x y)
|
||||
(let ([z (fxmap-ref types key #f)])
|
||||
;x-> from
|
||||
;y-> base
|
||||
;z-> types
|
||||
(set! ret (pred-env-add/key ret key (pred-intersect x z)))))
|
||||
(let ([z (fxmap-ref types key #f)])
|
||||
;x-> from
|
||||
;y-> base
|
||||
;z-> types
|
||||
(set! ret (pred-env-add/key ret key (pred-intersect x z)))))
|
||||
(lambda (key x)
|
||||
(set! ret (pred-env-add/key ret key x)))
|
||||
(set! ret (pred-env-add/key ret key x)))
|
||||
(lambda (key x) (error 'pred-env-intersect/base "") (void))
|
||||
from
|
||||
base)
|
||||
|
|
@ -252,20 +262,20 @@ Notes:
|
|||
(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)))))
|
||||
(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)))))
|
||||
(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) (error 'pred-env-rebase "") (void))
|
||||
new-base
|
||||
base)
|
||||
|
|
@ -329,7 +339,7 @@ Notes:
|
|||
(guard (record-type-descriptor? d))
|
||||
(list '$record/rtd d)]
|
||||
[(ref ,maybe-src ,x)
|
||||
(guard (not (prelex-was-assigned x)))
|
||||
(guard (not (prelex-assigned x)))
|
||||
(list '$record/ref x)]
|
||||
[(record-type ,rtd ,e)
|
||||
(rtd->record-predicate e)]
|
||||
|
|
@ -432,63 +442,69 @@ Notes:
|
|||
(and x
|
||||
y
|
||||
(or (eq? x y)
|
||||
(and (Lsrc? x)
|
||||
(Lsrc? y)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(quote ,d1)
|
||||
(nanopass-case (Lsrc Expr) y
|
||||
[(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal?
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
(and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/rtd)
|
||||
(pair? y) (pair? (cdr y)) (eq? (car y) '$record/rtd)
|
||||
(cond
|
||||
[(record-type-sealed? (cadr y))
|
||||
(eqv? (cadr x) (cadr y))]
|
||||
[else
|
||||
(let loop ([x (cadr x)] [y (cadr y)])
|
||||
(or (eqv? x y)
|
||||
(let ([xp (record-type-parent x)])
|
||||
(and xp (loop xp y)))))]))
|
||||
(and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/ref)
|
||||
(pair? y) (pair? (cdr y)) (eq? (car y) '$record/ref)
|
||||
(eq? (cadr x) (cadr y)))
|
||||
(eq? x 'bottom)
|
||||
(case y
|
||||
[(null-or-pair) (or (check-constant-is? x null?)
|
||||
(eq? x 'pair))]
|
||||
[(fixnum) (check-constant-is? x target-fixnum?)]
|
||||
[(exact-integer)
|
||||
(or (eq? x 'fixnum)
|
||||
(check-constant-is? x (lambda (x) (and (integer? x)
|
||||
(exact? x)))))]
|
||||
[(flonum) (check-constant-is? x flonum?)]
|
||||
[(real) (or (eq? x 'fixnum)
|
||||
(eq? x 'exact-integer)
|
||||
(eq? x 'flonum)
|
||||
(check-constant-is? x real?))]
|
||||
[(number) (or (eq? x 'fixnum)
|
||||
(eq? x 'exact-integer)
|
||||
(eq? x 'flonum)
|
||||
(eq? x 'real)
|
||||
(check-constant-is? x number?))]
|
||||
[(gensym) (check-constant-is? x gensym?)]
|
||||
[(symbol) (or (eq? x 'gensym)
|
||||
(check-constant-is? x symbol?))]
|
||||
[(char) (check-constant-is? x char?)]
|
||||
[(boolean) (or (check-constant-is? x not)
|
||||
(check-constant-is? x (lambda (x) (eq? x #t))))]
|
||||
[(true) (and (not (check-constant-is? x not))
|
||||
(not (eq? x 'boolean))
|
||||
(not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f
|
||||
[($record) (or (check-constant-is? x #3%$record?)
|
||||
(and (pair? x) (eq? (car x) '$record/rtd))
|
||||
(and (pair? x) (eq? (car x) '$record/ref)))]
|
||||
[(vector) (check-constant-is? x vector?)] ; i.e. '#()
|
||||
[(string) (check-constant-is? x string?)] ; i.e. ""
|
||||
[(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8()
|
||||
[(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx()
|
||||
[(ptr) #t]
|
||||
(cond
|
||||
[(Lsrc? y)
|
||||
(and (Lsrc? x)
|
||||
(nanopass-case (Lsrc Expr) y
|
||||
[(quote ,d1)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal?
|
||||
[else #f])]
|
||||
[else #f]))]
|
||||
[(and (pair? y) (pair? (cdr y)))
|
||||
(and (pair? x) (pair? (cdr x))
|
||||
(cond
|
||||
[(eq? (car y) '$record/rtd)
|
||||
(and (eq? (car x) '$record/rtd)
|
||||
(let ([y-rtd (cadr y)])
|
||||
(cond
|
||||
[(record-type-sealed? y-rtd)
|
||||
(eqv? (cadr x) y-rtd)]
|
||||
[else
|
||||
(let loop ([x-rtd (cadr x)])
|
||||
(or (eqv? x-rtd y-rtd)
|
||||
(let ([xp (record-type-parent x-rtd)])
|
||||
(and xp (loop xp)))))])))]
|
||||
[(eq? (car y) '$record/ref)
|
||||
(and (eq? (car x) '$record/ref)
|
||||
(eq? (cadr x) (cadr y)))]
|
||||
[else #f]))]
|
||||
[(case y
|
||||
[(null-or-pair) (or (eq? x 'pair)
|
||||
(check-constant-is? x null?))]
|
||||
[(fixnum) (check-constant-is? x target-fixnum?)]
|
||||
[(exact-integer)
|
||||
(or (eq? x 'fixnum)
|
||||
(check-constant-is? x (lambda (x) (and (integer? x)
|
||||
(exact? x)))))]
|
||||
[(flonum) (check-constant-is? x flonum?)]
|
||||
[(real) (or (eq? x 'fixnum)
|
||||
(eq? x 'exact-integer)
|
||||
(eq? x 'flonum)
|
||||
(check-constant-is? x real?))]
|
||||
[(number) (or (eq? x 'fixnum)
|
||||
(eq? x 'exact-integer)
|
||||
(eq? x 'flonum)
|
||||
(eq? x 'real)
|
||||
(check-constant-is? x number?))]
|
||||
[(gensym) (check-constant-is? x gensym?)]
|
||||
[(symbol) (or (eq? x 'gensym)
|
||||
(check-constant-is? x symbol?))]
|
||||
[(char) (check-constant-is? x char?)]
|
||||
[(boolean) (check-constant-is? x boolean?)]
|
||||
[(true) (and (not (check-constant-is? x not))
|
||||
(not (eq? x 'boolean))
|
||||
(not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f
|
||||
[($record) (or (and (pair? x) (eq? (car x) '$record/rtd))
|
||||
(and (pair? x) (eq? (car x) '$record/ref))
|
||||
(check-constant-is? x #3%$record?))]
|
||||
[(vector) (check-constant-is? x vector?)] ; i.e. '#()
|
||||
[(string) (check-constant-is? x string?)] ; i.e. ""
|
||||
[(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8()
|
||||
[(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx()
|
||||
[(ptr) #t]
|
||||
[else #f])]
|
||||
[else #f]))))
|
||||
|
||||
(define (predicate-implies-not? x y)
|
||||
|
|
@ -600,8 +616,8 @@ Notes:
|
|||
(define (primref->unsafe-primref pr)
|
||||
(lookup-primref 3 (primref-name pr)))
|
||||
|
||||
[define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types)
|
||||
[Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types)
|
||||
(define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types)
|
||||
(Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types)
|
||||
[(quote ,d)
|
||||
(values ir (datum->predicate d ir) #f #f #f)]
|
||||
[(ref ,maybe-src ,x)
|
||||
|
|
@ -629,101 +645,89 @@ Notes:
|
|||
(values ir t #f #f #f)])]
|
||||
[else
|
||||
(values ir t #f #f #f)]))])]
|
||||
[(seq ,e1 ,e2)
|
||||
(let-values ([(e1 ret1 types t-types f-types)
|
||||
(cptypes e1 'effect types)])
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom)
|
||||
(values e1 ret1 types #f #f)]
|
||||
[else
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(cptypes e2 ctxt types)])
|
||||
(values (make-seq ctxt e1 e2) ret types t-types f-types))]))]
|
||||
[(if ,e1 ,e2 ,e3)
|
||||
(let-values ([(e1 ret1 types1 t-types1 f-types1)
|
||||
(cptypes e1 'test types)])
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom) ;check bottom first
|
||||
(values e1 ret1 types #f #f)]
|
||||
[(predicate-implies-not? ret1 false-rec)
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(cptypes e2 ctxt types)])
|
||||
(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)
|
||||
(cptypes e3 ctxt types)])
|
||||
(values (make-seq ctxt e1 e3) ret types t-types f-types))]
|
||||
[else
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
||||
(cptypes e2 ctxt t-types1)]
|
||||
[(e3 ret3 types3 t-types3 f-types3)
|
||||
(cptypes e3 ctxt f-types1)])
|
||||
(let ([ir `(if ,e1 ,e2 ,e3)])
|
||||
(cond
|
||||
[(predicate-implies? ret2 'bottom) ;check bottom first
|
||||
(values ir ret3 types3 t-types3 f-types3)]
|
||||
[(predicate-implies? ret3 'bottom) ;check bottom first
|
||||
(values ir ret2 types2 t-types2 f-types2)]
|
||||
[else
|
||||
(let ([new-types (pred-env-union/super-base types2 t-types1
|
||||
types3 f-types1
|
||||
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)])
|
||||
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
|
||||
[else
|
||||
(pred-env-union/super-base t-types2 t-types1
|
||||
t-types3 f-types1
|
||||
types1
|
||||
new-types)])
|
||||
(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
|
||||
[else
|
||||
(pred-env-union/super-base f-types2 t-types1
|
||||
f-types3 f-types1
|
||||
types1
|
||||
new-types)])))])))]))]
|
||||
[(set! ,maybe-src ,x ,e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(set! ,maybe-src ,x ,e)
|
||||
void-rec types #f #f))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(let* ([e/r/t* (map (lambda (e)
|
||||
(let-values ([(e r t t-t f-t)
|
||||
(cptypes e 'value types)])
|
||||
(list e r t)))
|
||||
e*)]
|
||||
[e* (map car e/r/t*)]
|
||||
[r* (map cadr e/r/t*)]
|
||||
[t* (map caddr e/r/t*)]
|
||||
[t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
|
||||
[(seq ,[cptypes : e1 'effect types -> e1 ret1 types t-types f-types] ,e2)
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom)
|
||||
(values e1 ret1 types #f #f)]
|
||||
[else
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(cptypes e2 ctxt 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)
|
||||
(cond
|
||||
[(predicate-implies? ret1 'bottom) ;check bottom first
|
||||
(values e1 ret1 types #f #f)]
|
||||
[(predicate-implies-not? ret1 false-rec)
|
||||
(let-values ([(e2 ret types t-types f-types)
|
||||
(cptypes e2 ctxt types1)])
|
||||
(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)
|
||||
(cptypes e3 ctxt types1)])
|
||||
(values (make-seq ctxt e1 e3) ret types t-types f-types))]
|
||||
[else
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
||||
(cptypes e2 ctxt t-types1)]
|
||||
[(e3 ret3 types3 t-types3 f-types3)
|
||||
(cptypes e3 ctxt f-types1)])
|
||||
(let ([ir `(if ,e1 ,e2 ,e3)])
|
||||
(cond
|
||||
[(predicate-implies? ret2 'bottom) ;check bottom first
|
||||
(values ir ret3 types3 t-types3 f-types3)]
|
||||
[(predicate-implies? ret3 'bottom) ;check bottom first
|
||||
(values ir ret2 types2 t-types2 f-types2)]
|
||||
[else
|
||||
(let ([new-types (pred-env-union/super-base types2 t-types1
|
||||
types3 f-types1
|
||||
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)])
|
||||
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
|
||||
[else
|
||||
(pred-env-union/super-base t-types2 t-types1
|
||||
t-types3 f-types1
|
||||
types1
|
||||
new-types)])
|
||||
(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
|
||||
[else
|
||||
(pred-env-union/super-base f-types2 t-types1
|
||||
f-types3 f-types1
|
||||
types1
|
||||
new-types)])))])))])]
|
||||
[(set! ,maybe-src ,x ,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(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*] ...)
|
||||
(let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
|
||||
[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 loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
|
||||
|
|
@ -873,77 +877,67 @@ Notes:
|
|||
[(clause (,x* ...) ,interface ,body)
|
||||
(let-values ([(body ret types t-types f-types)
|
||||
(cptypes body 'value types)])
|
||||
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
|
||||
(with-output-language (Lsrc CaseLambdaClause)
|
||||
`(clause (,x* ...) ,interface ,body)))]))
|
||||
cl*)])
|
||||
(values `(case-lambda ,preinfo ,cl* ...) 'procedure #f #f #f))]
|
||||
[(call ,preinfo ,e0 ,e* ...)
|
||||
(let* ([e/r/t* (map (lambda (e)
|
||||
(let-values ([(e r t t-t f-t)
|
||||
(cptypes e 'value types)])
|
||||
(list e r t)))
|
||||
e*)]
|
||||
[e* (map car e/r/t*)]
|
||||
[r* (map cadr e/r/t*)]
|
||||
[t* (map caddr e/r/t*)]
|
||||
[t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)])
|
||||
(nanopass-case (Lsrc Expr) e0
|
||||
[(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))
|
||||
; We are sure that body will run and that it will be run after the evaluation of the arguments,
|
||||
; so we can use the types discovered in the arguments and also use the ret and types from the body.
|
||||
(guard (fx= interface (length e*)))
|
||||
(let ([t (fold-left pred-env-add t x* r*)])
|
||||
(let-values ([(body ret n-types t-types f-types)
|
||||
(cptypes body ctxt t)])
|
||||
(let* ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))]
|
||||
[new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
|
||||
[t-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types t-types))
|
||||
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
|
||||
[f-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types f-types))
|
||||
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
ret new-types t-types f-types))))]
|
||||
[(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))
|
||||
; We are sure that body will run and that it will be run after the evaluation of the arguments,
|
||||
; but this will raise an error. TODO: change body to (void) because it will never run.
|
||||
(guard (not (fx= interface (length e*))))
|
||||
(let-values ([(body ret types t-types f-types)
|
||||
(cptypes body 'value t)])
|
||||
(let ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))])
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
'bottom #f #f #f)))]
|
||||
[(case-lambda ,preinfo2 ,cl* ...)
|
||||
; We are sure that it will run after the arguments are evaluated,
|
||||
; so we can effectively delay the evaluation of the lambda and use more types inside it.
|
||||
; TODO: (difficult) Try to use the ret vales and discovered types.
|
||||
(let-values ([(e0 ret types t-types f-types)
|
||||
(cptypes e0 'value t)])
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
#f t #f #f))]
|
||||
[else
|
||||
; It's difficult to be sure the order the code will run,
|
||||
; so assume that the expression may be evaluated before the arguments.
|
||||
(let-values ([(e0 ret0 types0 t-types0 f-types0)
|
||||
(cptypes e0 'value types)])
|
||||
(let* ([t (pred-env-intersect/base t types0 types)]
|
||||
[t (pred-env-add/ref t e0 'procedure)])
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
#f t #f #f)))]))]
|
||||
[(letrec ((,x* ,e*) ...) ,body)
|
||||
(let* ([e/r/t* (map (lambda (e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(list e ret types)))
|
||||
e*)]
|
||||
[e* (map car e/r/t*)]
|
||||
[r* (map cadr e/r/t*)]
|
||||
[t* (map caddr e/r/t*)]
|
||||
[t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
|
||||
[(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
|
||||
,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...)
|
||||
;; pulled from cpnanopass
|
||||
(define find-matching-clause
|
||||
(lambda (len x** interface* body* kfixed kvariable kfail)
|
||||
(let f ([x** x**] [interface* interface*] [body* body*])
|
||||
(if (null? interface*)
|
||||
(kfail)
|
||||
(let ([interface (car interface*)])
|
||||
(if (fx< interface 0)
|
||||
(let ([nfixed (fxlognot interface)])
|
||||
(if (fx>= len nfixed)
|
||||
(kvariable nfixed (car x**) (car body*))
|
||||
(f (cdr x**) (cdr interface*) (cdr body*))))
|
||||
(if (fx= interface len)
|
||||
(kfixed (car x**) (car body*))
|
||||
(f (cdr x**) (cdr interface*) (cdr body*)))))))))
|
||||
(define finish
|
||||
(lambda (x* interface body t)
|
||||
(let-values ([(body ret n-types t-types f-types)
|
||||
(cptypes body ctxt t)])
|
||||
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
|
||||
[t-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types t-types))
|
||||
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
|
||||
[f-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types f-types))
|
||||
(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*)
|
||||
(values
|
||||
`(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
||||
ret new-types t-types f-types)))))
|
||||
(let ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
|
||||
[len (length e*)])
|
||||
(find-matching-clause (length e*) x** interface* body*
|
||||
(lambda (x* body) (finish x* len body (fold-left pred-env-add t x* r*)))
|
||||
(lambda (nfixed x* body)
|
||||
(finish x* (fxlognot nfixed) body
|
||||
(fold-left pred-env-add t x*
|
||||
(let f ([i nfixed] [r* r*])
|
||||
(if (fx= i 0)
|
||||
(list (if (null? r*) 'null 'pair))
|
||||
(cons (car r*) (f (fx- i 1) (cdr r*))))))))
|
||||
(lambda () (values ir 'bottom #f #f #f))))]
|
||||
[(call ,preinfo ,[cptypes : e0 'value types -> e0 ret0 types0 t-types0 f-types0]
|
||||
,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...)
|
||||
(values `(call ,preinfo ,e0 ,e* ...)
|
||||
#f (pred-env-add/ref
|
||||
(pred-env-intersect/base
|
||||
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
|
||||
types0 types) e0 'procedure) #f #f)]
|
||||
[(letrec ((,x* ,[cptypes : 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*)]
|
||||
[t (fold-left pred-env-add t x* r*)])
|
||||
(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*)]
|
||||
[t-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types t-types))
|
||||
|
|
@ -951,6 +945,7 @@ Notes:
|
|||
[f-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types f-types))
|
||||
(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*)
|
||||
(values `(letrec ([,x* ,e*] ...) ,body)
|
||||
ret new-types t-types f-types))))]
|
||||
[(letrec* ((,x* ,e*) ...) ,body)
|
||||
|
|
@ -971,82 +966,57 @@ Notes:
|
|||
[f-types (and (eq? ctxt 'test)
|
||||
(not (eq? n-types f-types))
|
||||
(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*)
|
||||
(values `(letrec* ([,x* ,e*] ...) ,body)
|
||||
ret new-types t-types f-types))))]
|
||||
[,pr
|
||||
(values ir
|
||||
(and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure)
|
||||
#f #f #f)]
|
||||
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
|
||||
#f types #f #f))]
|
||||
[(fcallable ,conv ,e (,arg-type* ...) ,result-type)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type)
|
||||
#f types #f #f))]
|
||||
[(record ,rtd ,rtd-expr ,e* ...)
|
||||
(let-values ([(rtd-expr ret-re types-re t-types-re f-types-re)
|
||||
(cptypes rtd-expr 'value types)])
|
||||
(let* ([e/r/t* (map (lambda (e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(list e ret types)))
|
||||
e*)]
|
||||
[e* (map car e/r/t*)]
|
||||
#;[r* (map cadr e/r/t*)]
|
||||
[t* (map caddr e/r/t*)])
|
||||
(values `(record ,rtd ,rtd-expr ,e* ...)
|
||||
(rtd->record-predicate rtd-expr)
|
||||
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
|
||||
#f #f)))]
|
||||
[(record-ref ,rtd ,type ,index ,e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(record-ref ,rtd ,type ,index ,e)
|
||||
#f
|
||||
(pred-env-add/ref types e '$record)
|
||||
#f #f))]
|
||||
[(record-set! ,rtd ,type ,index ,e1 , e2) ;can they be reordered?
|
||||
(let-values ([(e1 ret1 types1 t-types1 f-types1)
|
||||
(cptypes e1 'value types)]
|
||||
[(e2 ret2 types2 t-types2 f-types2)
|
||||
(cptypes e2 'value types)])
|
||||
(values `(record-set! ,rtd ,type ,index ,e1 ,e2)
|
||||
void-rec
|
||||
(pred-env-add/ref (pred-env-intersect/base types1 types2 types)
|
||||
e1 '$record)
|
||||
#f #f))]
|
||||
[(foreign ,conv ,name ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
|
||||
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
|
||||
#f types #f #f)]
|
||||
[(fcallable ,conv ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
|
||||
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type)
|
||||
#f types #f #f)]
|
||||
[(record ,rtd ,[cptypes : 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*] ...)
|
||||
(values `(record ,rtd ,rtd-expr ,e* ...)
|
||||
(rtd->record-predicate rtd-expr)
|
||||
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
|
||||
#f #f)]
|
||||
[(record-ref ,rtd ,type ,index ,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(values `(record-ref ,rtd ,type ,index ,e)
|
||||
#f
|
||||
(pred-env-add/ref types e '$record)
|
||||
#f #f)]
|
||||
[(record-set! ,rtd ,type ,index ,[cptypes : 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?
|
||||
(values `(record-set! ,rtd ,type ,index ,e1 ,e2)
|
||||
void-rec
|
||||
(pred-env-add/ref (pred-env-intersect/base types1 types2 types)
|
||||
e1 '$record)
|
||||
#f #f)]
|
||||
[(record-type ,rtd ,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(values `(record-type ,rtd ,e)
|
||||
#f types #f #f)]
|
||||
[(record-cd ,rcd ,rtd-expr ,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(values `(record-cd ,rcd ,rtd-expr ,e)
|
||||
#f types #f #f)]
|
||||
[(immutable-list (,e* ...) ,e)
|
||||
(let ([e* (map (lambda (e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
e))
|
||||
e*)])
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(immutable-list (,e* ...) ,e)
|
||||
ret types #f #f)))] #;CHECK
|
||||
[(immutable-list (,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...)
|
||||
,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(values `(immutable-list (,e* ...) ,e)
|
||||
ret types #f #f)] #;CHECK
|
||||
[(moi) (values ir #f #f #f #f)]
|
||||
[(pariah) (values ir void-rec #f #f #f)]
|
||||
[(cte-optimization-loc ,box ,e)
|
||||
(let-values ([(e ret types t-types f-types)
|
||||
(cptypes e 'value types)])
|
||||
(values `(cte-optimization-loc ,box ,e)
|
||||
ret types #f #f))] #;CHECK
|
||||
[(cte-optimization-loc ,box ,[cptypes : e 'value types -> e ret types t-types f-types])
|
||||
(values `(cte-optimization-loc ,box ,e)
|
||||
ret types #f #f)] #;CHECK
|
||||
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
|
||||
[(profile ,src) (values ir #f #f #f #f)]
|
||||
#;[else (values ir #f #f #f #f)]
|
||||
[else ($oops who "unrecognized record ~s" ir)]]
|
||||
(Expr ir ctxt types)]
|
||||
[else ($oops who "unrecognized record ~s" ir)])
|
||||
(Expr ir ctxt types))
|
||||
|
||||
(define (cptypes ir ctxt types)
|
||||
(let-values ([(ir ret r-types t-types f-types)
|
||||
|
|
@ -1060,4 +1030,4 @@ Notes:
|
|||
(let-values ([(ir ret types t-types f-types)
|
||||
(cptypes ir 'value pred-env-empty)])
|
||||
ir))
|
||||
]]
|
||||
))
|
||||
|
|
|
|||
|
|
@ -104,6 +104,8 @@
|
|||
|
||||
(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define machine-type
|
||||
(lambda ()
|
||||
(constant machine-type-name)))
|
||||
|
|
|
|||
48
s/fxmap.ss
48
s/fxmap.ss
|
|
@ -39,18 +39,18 @@
|
|||
;; record types
|
||||
|
||||
(define-record-type $branch
|
||||
[fields prefix mask left right count changes]
|
||||
[nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1}]
|
||||
[sealed #t])
|
||||
(fields prefix mask left right count changes)
|
||||
(nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type $leaf
|
||||
[fields key val changes]
|
||||
[nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1}]
|
||||
[sealed #t])
|
||||
(fields key val changes)
|
||||
(nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type $empty
|
||||
[nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}]
|
||||
[sealed #t])
|
||||
(nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0})
|
||||
(sealed #t))
|
||||
|
||||
;; constants
|
||||
|
||||
|
|
@ -272,9 +272,9 @@
|
|||
|
||||
(define (join* p1 d1 p2 d2)
|
||||
(cond
|
||||
[($empty? d1) d2]
|
||||
[($empty? d2) d1]
|
||||
[else (join p1 d1 p2 d2)]))
|
||||
[($empty? d1) d2]
|
||||
[($empty? d2) d1]
|
||||
[else (join p1 d1 p2 d2)]))
|
||||
|
||||
(define (branching-bit p m)
|
||||
(highest-set-bit (fxxor p m)))
|
||||
|
|
@ -282,14 +282,24 @@
|
|||
(define-syntax-rule (mask h m)
|
||||
(fxand (fxior h (fx1- m)) (fxnot m)))
|
||||
|
||||
(define (highest-set-bit x1)
|
||||
(let* ([x2 (fxior x1 (fxsrl x1 1))]
|
||||
[x3 (fxior x2 (fxsrl x2 2))]
|
||||
[x4 (fxior x3 (fxsrl x3 4))]
|
||||
[x5 (fxior x4 (fxsrl x4 8))]
|
||||
[x6 (fxior x5 (fxsrl x5 16))]
|
||||
[x7 (fxior x6 (fxsrl x6 32))])
|
||||
(fxxor x7 (fxsrl x7 1))))
|
||||
(define highest-set-bit
|
||||
(if (fx= (fixnum-width) 61)
|
||||
(lambda (x1)
|
||||
(let* ([x2 (fxior x1 (fxsrl x1 1))]
|
||||
[x3 (fxior x2 (fxsrl x2 2))]
|
||||
[x4 (fxior x3 (fxsrl x3 4))]
|
||||
[x5 (fxior x4 (fxsrl x4 8))]
|
||||
[x6 (fxior x5 (fxsrl x5 16))]
|
||||
[x7 (fxior x6 (fxsrl x6 32))])
|
||||
(fxxor x7 (fxsrl x7 1))))
|
||||
(lambda (x1)
|
||||
(let* ([x2 (fxior x1 (fxsrl x1 1))]
|
||||
[x3 (fxior x2 (fxsrl x2 2))]
|
||||
[x4 (fxior x3 (fxsrl x3 4))]
|
||||
[x5 (fxior x4 (fxsrl x4 8))]
|
||||
[x6 (fxior x5 (fxsrl x5 16))])
|
||||
(fxxor x6 (fxsrl x6 1))))))
|
||||
|
||||
|
||||
(define-syntax-rule (nomatch? h p m)
|
||||
(not (fx= (mask h m) p)))
|
||||
|
|
|
|||
|
|
@ -871,9 +871,9 @@
|
|||
(make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]
|
||||
[(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]]
|
||||
[flags alloc])
|
||||
(make-time [sig [(sub-symbol sub-ufixnum sub-fixnum) -> (time)]] [flags alloc])
|
||||
(make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc])
|
||||
(set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true])
|
||||
(set-time-second! [sig [(time sub-fixnum) -> (void)]] [flags true])
|
||||
(set-time-second! [sig [(time exact-integer) -> (void)]] [flags true])
|
||||
(set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true])
|
||||
(subtract-duration (sig [(time time) -> (time)]) [flags alloc])
|
||||
(subtract-duration! (sig [(time time) -> (time)]) [flags alloc])
|
||||
|
|
@ -886,7 +886,7 @@
|
|||
(time-difference (sig [(time time) -> (time)]) [flags alloc])
|
||||
(time-difference! (sig [(time time) -> (time)]) [flags alloc])
|
||||
(time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true])
|
||||
(time-second [sig [(time) -> (fixnum)]] [flags mifoldable discard true])
|
||||
(time-second [sig [(time) -> (exact-integer)]] [flags mifoldable discard true])
|
||||
(time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true])
|
||||
(time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc])
|
||||
)
|
||||
|
|
@ -948,6 +948,7 @@
|
|||
(default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
|
||||
(enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
|
||||
(enable-type-recovery [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
|
||||
(expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
|
||||
(expand/optimize-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user