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

Speed up and improve tc-literal. Now uses expected types more, and more sensibly.

Browse Source 
Closes PR 12586.
This commit is contained in:
Sam Tobin-Hochstadt 2012-02-20 13:19:53 -05:00
parent 74c9265d66
commit a8bdb9d6ce
5 changed files with 117 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -1398,6 +1398,8 @@
[tc-e (vector-append #(1) #(2)) [tc-e (vector-append #(1) #(2))
(-vec -Integer)] (-vec -Integer)]
[tc-e/t (ann #() (Vectorof Integer))
(-vec -Integer)]
) )
(test-suite (test-suite
"check-type tests" "check-type tests"

39
collects/typed-racket/infer/restrict.rkt
View File

@ -9,29 +9,30 @@
(import infer^) (import infer^)
(export restrict^) (export restrict^)
;; we don't use union map directly, since that might produce too many elements
;; NEW IMPL
;; restrict t1 to be a subtype of t2
;; if `f' is 'new, use t2 when giving up, otherwise use t1
(define (restrict* t1 t2 [f 'new])
;; we don't use union map directly, since that might produce too many elements
(define (union-map f l) (define (union-map f l)
(match l (match l
[(Union: es) [(Union: es)
(let ([l (map f es)]) (let ([l (map f es)])
(apply Un l))])) (apply Un l))]))
(match* (t1 t2)
[(_ (? (lambda _ (subtype t1 t2)))) t1] ;; already a subtype ;; NEW IMPL
[(_ (Poly: vars t)) ;; restrict t1 to be a subtype of t2
(let ([subst (infer vars null (list t1) (list t) t1)]) ;; if `f' is 'new, use t2 when giving up, otherwise use t1
(and subst (restrict* t1 (subst-all subst t1) f)))] (define (restrict* t1 t2 [f 'new])
[((Union: _) _) (union-map (lambda (e) (restrict* e t2 f)) t1)] (cond
[(_ (Union: _)) (union-map (lambda (e) (restrict* t1 e f)) t2)] [(subtype t1 t2) t1] ;; already a subtype
[((? needs-resolving?) _) (restrict* (resolve-once t1) t2 f)] [(match t2
[(_ (? needs-resolving?)) (restrict* t1 (resolve-once t2) f)] [(Poly: vars t)
[(_ _) (let ([subst (infer vars null (list t1) (list t) t1)])
(cond [(subtype t2 t1) t2] ;; we don't actually want this - want something that's a part of t1 (and subst (restrict* t1 (subst-all subst t1) f)))]
[(not (overlap t1 t2)) (Un)] ;; there's no overlap, so the restriction is empty [_ #f])]
[else (if (eq? f 'new) t2 t1)])])) ;; t2 and t1 have a complex relationship, so we punt [(Union? t1) (union-map (lambda (e) (restrict* e t2 f)) t1)]
[(Union? t2) (union-map (lambda (e) (restrict* t1 e f)) t2)]
[(needs-resolving? t1) (restrict* (resolve-once t1) t2 f)]
[(needs-resolving? t2) (restrict* t1 (resolve-once t2) f)]
[(subtype t2 t1) t2] ;; we don't actually want this - want something that's a part of t1
[(not (overlap t1 t2)) (Un)] ;; there's no overlap, so the restriction is empty
[else (if (eq? f 'new) t2 t1)])) ;; t2 and t1 have a complex relationship, so we punt
(define restrict restrict*) (define restrict restrict*)

3
collects/typed-racket/typecheck/tc-app.rkt
View File

@ -153,7 +153,8 @@
(define (type->list t) (define (type->list t)
(match t (match t
[(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] [(Pair: (Value: (? keyword? k)) b)
(cons k (type->list b))]
[(Value: '()) null] [(Value: '()) null]
[_ (int-err "bad value in type->list: ~a" t)])) [_ (int-err "bad value in type->list: ~a" t)]))

179
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -23,98 +23,99 @@
(export tc-expr^) (export tc-expr^)
;; return the type of a literal value ;; return the type of a literal value
;; scheme-value -> type ;; scheme-value [type] -> type
(define (tc-literal v-stx [expected #f]) (define (tc-literal v-stx [expected #f])
(define-syntax-class exp (define r
(pattern i (syntax-parse v-stx
#:fail-unless expected #f [i:boolean (-val (syntax-e #'i))]
#:attr datum (syntax-e #'i) [i:identifier (-val (syntax-e #'i))]
#:fail-unless (subtype (-val (attribute datum)) expected) #f))
(syntax-parse v-stx
[i:exp expected]
[i:boolean (-val (syntax-e #'i))]
[i:identifier (-val (syntax-e #'i))]
;; Numbers ;; Numbers
[0 -Zero] [0 -Zero]
[1 -One] [1 -One]
[(~var i (3d (conjoin byte? positive?))) -PosByte] [(~var i (3d (conjoin byte? positive?))) -PosByte]
[(~var i (3d byte?)) -Byte] [(~var i (3d byte?)) -Byte]
[(~var i (3d (conjoin portable-index? positive?))) -PosIndex] [(~var i (3d (conjoin portable-index? positive?))) -PosIndex]
[(~var i (3d (conjoin portable-fixnum? positive?))) -PosFixnum] [(~var i (3d (conjoin portable-fixnum? positive?))) -PosFixnum]
[(~var i (3d (conjoin portable-fixnum? negative?))) -NegFixnum] [(~var i (3d (conjoin portable-fixnum? negative?))) -NegFixnum]
[(~var i (3d exact-positive-integer?)) -PosInt] [(~var i (3d exact-positive-integer?)) -PosInt]
[(~var i (3d (conjoin exact-integer? negative?))) -NegInt] [(~var i (3d (conjoin exact-integer? negative?))) -NegInt]
[(~var i (3d (conjoin number? exact? rational? positive?))) -PosRat] [(~var i (3d (conjoin number? exact? rational? positive?))) -PosRat]
[(~var i (3d (conjoin number? exact? rational? negative?))) -NegRat] [(~var i (3d (conjoin number? exact? rational? negative?))) -NegRat]
[(~var i (3d (lambda (x) (eq? x 0.0)))) -FlonumPosZero] [(~var i (3d (lambda (x) (eq? x 0.0)))) -FlonumPosZero]
[(~var i (3d (lambda (x) (eq? x -0.0)))) -FlonumNegZero] [(~var i (3d (lambda (x) (eq? x -0.0)))) -FlonumNegZero]
[(~var i (3d (conjoin flonum? positive?))) -PosFlonum] [(~var i (3d (conjoin flonum? positive?))) -PosFlonum]
[(~var i (3d (conjoin flonum? negative?))) -NegFlonum] [(~var i (3d (conjoin flonum? negative?))) -NegFlonum]
[(~var i (3d flonum?)) -Flonum] ; for nan [(~var i (3d flonum?)) -Flonum] ; for nan
[(~var i (3d (lambda (x) (eq? x 0.0f0)))) -SingleFlonumPosZero] [(~var i (3d (lambda (x) (eq? x 0.0f0)))) -SingleFlonumPosZero]
[(~var i (3d (lambda (x) (eq? x -0.0f0)))) -SingleFlonumNegZero] [(~var i (3d (lambda (x) (eq? x -0.0f0)))) -SingleFlonumNegZero]
[(~var i (3d (conjoin single-flonum? positive?))) -PosSingleFlonum] [(~var i (3d (conjoin single-flonum? positive?))) -PosSingleFlonum]
[(~var i (3d (conjoin single-flonum? negative?))) -NegSingleFlonum] [(~var i (3d (conjoin single-flonum? negative?))) -NegSingleFlonum]
[(~var i (3d single-flonum?)) -SingleFlonum] ; for nan [(~var i (3d single-flonum?)) -SingleFlonum] ; for nan
[(~var i (3d inexact-real?)) -InexactReal] ; catch-all, just in case [(~var i (3d inexact-real?)) -InexactReal] ; catch-all, just in case
[(~var i (3d real?)) -Real] ; catch-all, just in case [(~var i (3d real?)) -Real] ; catch-all, just in case
;; a complex number can't have a float imaginary part and an exact real part ;; a complex number can't have a float imaginary part and an exact real part
[(~var i (3d (conjoin number? exact?))) [(~var i (3d (conjoin number? exact?)))
-ExactNumber] -ExactNumber]
[(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x)) [(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x))
(flonum? (real-part x))))))) (flonum? (real-part x)))))))
-FloatComplex] -FloatComplex]
[(~var i (3d (conjoin number? (lambda (x) (and (single-flonum? (imag-part x)) [(~var i (3d (conjoin number? (lambda (x) (and (single-flonum? (imag-part x))
(single-flonum? (real-part x))))))) (single-flonum? (real-part x)))))))
-InexactComplex] -InexactComplex]
[(~var i (3d number?)) -Number] ; otherwise, Number [(~var i (3d number?)) -Number] ; otherwise, Number
[i:str -String] [i:str -String]
[i:char -Char] [i:char -Char]
[i:keyword (-val (syntax-e #'i))] [i:keyword (-val (syntax-e #'i))]
[i:bytes -Bytes] [i:bytes -Bytes]
[i:byte-pregexp -Byte-PRegexp] [i:byte-pregexp -Byte-PRegexp]
[i:byte-regexp -Byte-Regexp] [i:byte-regexp -Byte-Regexp]
[i:pregexp -PRegexp] [i:pregexp -PRegexp]
[i:regexp -Regexp] [i:regexp -Regexp]
[(i ...) [(~and i ()) (-val '())]
(match expected [(i . r)
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (match (and expected (restrict expected (-pair Univ Univ) 'orig))
(-Tuple [(Pair: a-ty d-ty)
(for/list ([l (in-list (syntax->list #'(i ...)))]) (-pair
(tc-literal l elem-ty)))] (tc-literal #'i a-ty)
;; errors are handled elsewhere (tc-literal #'r d-ty))]
[_ (-Tuple [(Union: '())
(for/list ([l (in-list (syntax->list #'(i ...)))]) (tc-error/expr "expected ~a, but got" expected #:return expected)]
(tc-literal l #f)))])] ;; errors are handled elsewhere
[(~var i (3d vector?)) [t
(match expected (-pair (tc-literal #'i) (tc-literal #'r))])]
[(Vector: t) [(~var i (3d vector?))
(make-Vector (apply Un (match (and expected (restrict expected (-vec Univ) 'orig))
(for/list ([l (in-vector (syntax-e #'i))]) [(Vector: t)
(tc-literal l t))))] (make-Vector (apply Un
[(HeterogenousVector: ts) t ;; so that this isn't (Un) when we get no elems
(make-HeterogenousVector (for/list ([l (in-vector (syntax-e #'i))])
(for/list ([l (in-vector (syntax-e #'i))] (tc-literal l t))))]
[t (in-list ts)]) [(HeterogenousVector: ts)
(tc-literal l t)))] (make-HeterogenousVector
;; errors are handled elsewhere (for/list ([l (in-vector (syntax-e #'i))]
[_ (make-HeterogenousVector (for/list ([l (syntax-e #'i)]) [t (in-list ts)])
(generalize (tc-literal l #f))))])] (tc-literal l t)))]
[(~var i (3d hash?)) ;; errors are handled elsewhere
(match expected [_ (make-HeterogenousVector (for/list ([l (syntax-e #'i)])
[(Hashtable: k v) (generalize (tc-literal l #f))))])]
(let* ([h (syntax-e #'i)] [(~var i (3d hash?))
[ks (hash-map h (lambda (x y) (tc-literal x k)))] (match expected
[vs (hash-map h (lambda (x y) (tc-literal y v)))]) [(Hashtable: k v)
(make-Hashtable (generalize (check-below (apply Un ks)) k) (generalize (check-below (apply Un vs)))))] (let* ([h (syntax-e #'i)]
[_ (let* ([h (syntax-e #'i)] [ks (hash-map h (lambda (x y) (tc-literal x k)))]
[ks (hash-map h (lambda (x y) (tc-literal x)))] [vs (hash-map h (lambda (x y) (tc-literal y v)))])
[vs (hash-map h (lambda (x y) (tc-literal y)))]) (make-Hashtable (generalize (check-below (apply Un ks)) k) (generalize (check-below (apply Un vs)))))]
(make-Hashtable (generalize (apply Un ks)) (generalize (apply Un vs))))])] [_ (let* ([h (syntax-e #'i)]
[(a . b) (-pair (tc-literal #'a) (tc-literal #'b))] [ks (hash-map h (lambda (x y) (tc-literal x)))]
[_ Univ])) [vs (hash-map h (lambda (x y) (tc-literal y)))])
(make-Hashtable (generalize (apply Un ks)) (generalize (apply Un vs))))])]
[_ Univ]))
(if expected
(check-below r expected)
r))
;; do-inst : syntax type -> type ;; do-inst : syntax type -> type