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

Simplify the * <: ... and ... <: * cases in cgen/seq.

Browse Source 
This allows move-vars+rest-to-dmap to be saner, and thus clean up mover.
This commit is contained in:
Eric Dobson 2014-05-19 21:22:29 -07:00
parent f321098cce
commit 6b771a8c25
2 changed files with 31 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -87,7 +87,7 @@
(dmap-meet (dmap-meet
(singleton-dmap (singleton-dmap
dbound dbound
(f cmap dmap)) (f cmap))
(make-dmap (hash-remove (dmap-map dmap) dbound))))) (make-dmap (hash-remove (dmap-map dmap) dbound)))))
cset)) cset))
@ -99,24 +99,12 @@
(define/cond-contract (move-vars-to-dmap cset dbound vars) (define/cond-contract (move-vars-to-dmap cset dbound vars)
(cset? symbol? (listof symbol?) . -> . cset?) (cset? symbol? (listof symbol?) . -> . cset?)
(mover cset dbound vars (mover cset dbound vars
(λ (cmap dmap) (λ (cmap)
(make-dcon (for/list ([v (in-list vars)]) (make-dcon (for/list ([v (in-list vars)])
(hash-ref cmap v (hash-ref cmap v
(λ () (int-err "No constraint for new var ~a" v)))) (λ () (int-err "No constraint for new var ~a" v))))
#f)))) #f))))
;; dbound : index variable
;; cset : the constraints being manipulated
;;
(define/cond-contract (move-rest-to-dmap cset dbound #:exact [exact? #f])
((cset? symbol?) (#:exact boolean?) . ->* . cset?)
(mover cset dbound null
(λ (cmap dmap)
((if exact? make-dcon-exact make-dcon)
null
(hash-ref cmap dbound
(λ () (int-err "No constraint for bound ~a" dbound)))))))
;; cset : the constraints being manipulated ;; cset : the constraints being manipulated
;; var : index variable being inferred ;; var : index variable being inferred
;; dbound : constraining index variable ;; dbound : constraining index variable
@ -124,30 +112,24 @@
(define/cond-contract (move-dotted-rest-to-dmap cset var dbound) (define/cond-contract (move-dotted-rest-to-dmap cset var dbound)
(cset? symbol? symbol? . -> . cset?) (cset? symbol? symbol? . -> . cset?)
(mover cset var null (mover cset var null
(λ (cmap dmap) (λ (cmap)
(make-dcon-dotted (make-dcon-dotted
null null
(hash-ref cmap var (hash-ref cmap var
(λ () (int-err "No constraint for bound ~a" var))) (λ () (int-err "No constraint for bound ~a" var)))
dbound)))) dbound))))
;; This one's weird, because the way we set it up, the rest is already in the dmap. ;; cset : the constraints being manipulated
;; This is because we create all the vars, then recall cgen/arr with the new vars ;; vars : the variables that are the prefix of the dbound
;; in place, and the "simple" case will then call move-rest-to-dmap. This means ;; dbound : index variable
;; we need to extract that result from the dmap and merge it with the fixed vars (define/cond-contract (move-vars+rest-to-dmap cset vars dbound #:exact [exact? #f])
;; we now handled. So I've extended the mover to give access to the dmap, which we use here.
(define/cond-contract (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f])
((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?) ((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?)
(mover cset dbound vars (mover cset dbound vars
(λ (cmap dmap) (λ (cmap)
((if exact? make-dcon-exact make-dcon) ((if exact? make-dcon-exact make-dcon)
(for/list ([v (in-list vars)]) (for/list ([v (in-list vars)])
(hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v)))) (hash-ref cmap v no-constraint))
(match (hash-ref (dmap-map dmap) dbound (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound)))))))
(λ () (int-err "No constraint for bound ~a" dbound)))
[(dcon null rest) rest]
[(dcon-exact null rest) rest]
[_ (int-err "did not get a rest-only dcon when moving to the dmap")])))))
;; Represents a sequence of types. types are the fixed prefix, and end is the remaining types ;; Represents a sequence of types. types are the fixed prefix, and end is the remaining types
;; This is a unification of all of the dotted types that exist ListDots, ->..., and ValuesDots. ;; This is a unification of all of the dotted types that exist ListDots, ->..., and ValuesDots.
@ -296,7 +278,7 @@
(cgen/list V X Y ss ts) (cgen/list V X Y ss ts)
(if (memq dbound Y) (if (memq dbound Y)
(extend-tvars (list dbound) (extend-tvars (list dbound)
(% move-rest-to-dmap (cgen V (cons dbound X) Y s-dty t-dty) dbound)) (% move-vars+rest-to-dmap (cgen V (cons dbound X) Y s-dty t-dty) null dbound))
(cgen V X Y s-dty t-dty)))] (cgen V X Y s-dty t-dty)))]
;; bounds are different ;; bounds are different
@ -321,38 +303,28 @@
(seq ts (dotted-end t-dty dbound))) (seq ts (dotted-end t-dty dbound)))
#:return-unless (memq dbound Y) #:return-unless (memq dbound Y)
#f #f
(cond #:return-unless (<= (length ts) (length ss))
[(= (length ts) (length ss)) #f
;; the simple case (define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts))))
(let* ([arg-mapping (cgen/list V X Y ss ts)] (% move-vars+rest-to-dmap
[darg-mapping (% move-rest-to-dmap (% cset-meet
(cgen V (cons dbound X) Y s-rest t-dty) dbound #:exact #t)]) (cgen/list V (append vars X) Y ss (append ts new-tys))
(% cset-meet arg-mapping darg-mapping))] (cgen V (cons dbound X) Y s-rest t-dty))
[(< (length ts) (length ss)) vars dbound #:exact #t)]
;; the hard case
(define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts))))
(let* ([new-t-seq (seq (append ts new-tys) (dotted-end t-dty dbound))]
[new-cset (cgen/seq V (append vars X) Y s-seq new-t-seq)])
(% move-vars+rest-to-dmap new-cset dbound vars #:exact #t))]
[else #f])]
[((seq ss (dotted-end s-dty dbound)) [((seq ss (dotted-end s-dty dbound))
(seq ts (uniform-end t-rest))) (seq ts (uniform-end t-rest)))
(if (memq dbound Y) (cond
(cond [(< (length ss) (length ts)) [(memq dbound Y)
;; the hard case (define-values (vars new-tys)
(define-values (vars new-tys) (generate-dbound-prefix dbound s-dty (- (length ts) (length ss)))) (generate-dbound-prefix dbound s-dty (max 0 (- (length ts) (length ss)))))
(let* ([new-s-seq (seq (append ss new-tys) (dotted-end s-dty dbound))] (% move-vars+rest-to-dmap
[new-cset (cgen/seq V (append vars X) Y new-s-seq t-seq)]) (% cset-meet
(% move-vars+rest-to-dmap new-cset dbound vars))] (cgen/list V (append vars X) Y (append ss new-tys) (extend ss ts t-rest))
[else (cgen V (cons dbound X) Y s-dty t-rest))
;; the simple case vars dbound)]
(let* ([arg-mapping (cgen/list V X Y ss (extend ss ts t-rest))] [else
[darg-mapping (% move-rest-to-dmap (cgen/seq V X Y (seq ss (uniform-end (substitute Univ dbound s-dty))) t-seq)])]))
(cgen V (cons dbound X) Y s-dty t-rest) dbound)])
(% cset-meet arg-mapping darg-mapping))])
(cgen/seq V X Y (seq ss (uniform-end (substitute Univ dbound s-dty))) t-seq))]))
(define/cond-contract (cgen/arr V X Y s-arr t-arr) (define/cond-contract (cgen/arr V X Y s-arr t-arr)
((listof symbol?) (listof symbol?) (listof symbol?) arr? arr? . -> . (or/c #f cset?)) ((listof symbol?) (listof symbol?) (listof symbol?) arr? arr? . -> . (or/c #f cset?))

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt
View File

@ -12,6 +12,7 @@
(define-signature constraints^ (define-signature constraints^
([cond-contracted cset-meet ((cset? cset?) #:rest (listof cset?) . ->* . (or/c #f cset?))] ([cond-contracted cset-meet ((cset? cset?) #:rest (listof cset?) . ->* . (or/c #f cset?))]
[cond-contracted cset-meet* ((listof cset?) . -> . (or/c #f cset?))] [cond-contracted cset-meet* ((listof cset?) . -> . (or/c #f cset?))]
[cond-contracted no-constraint c?]
[cond-contracted empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)] [cond-contracted empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)]
[cond-contracted insert (cset? symbol? Type/c Type/c . -> . cset?)] [cond-contracted insert (cset? symbol? Type/c Type/c . -> . cset?)]
[cond-contracted cset-join ((listof cset?) . -> . cset?)] [cond-contracted cset-join ((listof cset?) . -> . cset?)]