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

Add performance hint to var-promote.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-19 22:31:18 -07:00
parent 9efa4af051
commit 01b2b8376e
1 changed files with 39 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -3,6 +3,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(rep type-rep rep-utils) (rep type-rep rep-utils)
(types abbrev union utils structural) (types abbrev union utils structural)
racket/performance-hint
racket/list racket/match) racket/list racket/match)
(provide/cond-contract (provide/cond-contract
@ -21,43 +22,43 @@
[(Values: (list (Result: _ lf _) ...)) lf] [(Values: (list (Result: _ lf _) ...)) lf]
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf])) [(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
(define-values (var-promote var-demote)
(let ()
(define (var-change V T change)
(define (structural-recur t sym)
(case sym
[(co) (var-change V t change)]
[(contra) (var-change V t (not change))]
[(inv)
(if (V-in? V t)
(if change Univ -Bottom)
t)]))
(define (co t) (structural-recur t 'co))
(define (contra t) (structural-recur t 'contra))
(match T (begin-encourage-inline
[(? structural?) (structural-map T structural-recur)] (define (var-change V T change)
[(F: name) (if (memq name V) (if change Univ -Bottom) T)] (define (structural-recur t sym)
[(arr: dom rng rest drest kws) (case sym
(cond [(co) (var-change V t change)]
[(apply V-in? V (get-filters rng)) [(contra) (var-change V t (not change))]
(make-top-arr)] [(inv)
[(and drest (memq (cdr drest) V)) (if (V-in? V t)
(make-arr (map contra dom) (if change Univ -Bottom)
(co rng) t)]))
(contra (car drest)) (define (co t) (structural-recur t 'co))
#f (define (contra t) (structural-recur t 'contra))
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]
[(? Filter?) ((sub-f co) T)]
[(? Object?) ((sub-o co) T)]
[(? Type?) ((sub-t co) T)]))
(values (match T
(lambda (T V) (var-change V T #t)) [(? structural?) (structural-map T structural-recur)]
(lambda (T V) (var-change V T #f))))) [(F: name) (if (memq name V) (if change Univ -Bottom) T)]
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
(co rng)
(contra (car drest))
#f
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]
[(? Filter?) ((sub-f co) T)]
[(? Object?) ((sub-o co) T)]
[(? Type?) ((sub-t co) T)]))
(define (var-promote T V)
(var-change V T #t))
(define (var-demote T V)
(var-change V T #f)))