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*)

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

@ -40,7 +40,7 @@
ta))]) ta))])
(define-values (t-r f-r o-r) (define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r) (for/lists (t-r f-r o-r)
([r (in-list results)]) ([r (in-list results)])
(open-Result r o-a t-a))) (open-Result r o-a t-a)))
(ret t-r f-r o-r)))] (ret t-r f-r o-r)))]
[((arr: _ _ _ drest '()) _) [((arr: _ _ _ drest '()) _)

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)]))

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