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

less dynamic dispatch in contract gen

Browse Source
This commit is contained in:
Andrew Kent 2016-10-30 16:25:26 -04:00
parent a8b20d87aa
commit 6f1eff8d2a
9 changed files with 136 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt
View File

@ -73,7 +73,7 @@
;; currently simple-result-> only handles up to arity 3
(member (length mand-ctcs) '(0 1 2 3))
(and range-ctcs (= 1 (length range-ctcs)))
(for/and ([a args]) (eq? 'flat (sc-terminal-kind a)))
(for/and ([a (in-list args)]) (eq? 'flat (sc-terminal-kind a)))
(not typed-side?))
#`(simple-result-> #,@range-ctcs #,(length mand-ctcs))]
[else

14
typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
View File

@ -55,13 +55,13 @@
(recur (simple-contract-name s1)
(simple-contract-name s2))))
(define (hash-proc sc hash-code)
(hash-code (list (syntax->datum (simple-contract-syntax sc))
(simple-contract-kind sc)
(simple-contract-name sc))))
(bitwise-ior (hash-code (syntax->datum (simple-contract-syntax sc)))
(hash-code (simple-contract-kind sc))
(hash-code (simple-contract-name sc))))
(define (hash2-proc sc hash-code)
(hash-code (list (syntax->datum (simple-contract-syntax sc))
(simple-contract-kind sc)
(simple-contract-name sc))))]
(bitwise-ior (hash-code (syntax->datum (simple-contract-syntax sc)))
(hash-code (simple-contract-kind sc))
(hash-code (simple-contract-name sc))))]
#:methods gen:sc
[(define (sc-map v f) v)
(define (sc-traverse v f) (void))
@ -75,4 +75,4 @@
(define (chaperone/sc ctc [name #f])
(simple-contract ctc 'chaperone name))
(define (impersonator/sc ctc [name #f])
(simple-contract ctc 'impersonator name))
(simple-contract ctc 'impersonator name))

54
typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
View File

@ -111,32 +111,32 @@
[(_ sc:static-combinator-form c:expr kind:contract-category-keyword)
#'(begin
(struct sc.struct-name combinator ()
#:transparent
#:methods gen:sc
[(define sc-map sc.map)
(define sc-traverse sc.traverse)
(define (sc->contract v recur)
(apply
(sc.combinator2 (lambda (args) #`(c #,@args)))
(map recur (combinator-args v))))
(define (sc->constraints v recur)
(merge-restricts* 'kind.category-stx (sc.->restricts v recur)))]
#:methods gen:equal+hash
[(define (equal-proc a b recur)
(and (recur (length (combinator-args a))
(length (combinator-args b)))
(for/and ([sub-a (in-list (combinator-args a))]
[sub-b (in-list (combinator-args b))])
(recur sub-a sub-b))))
(define (hash-proc v recur)
(+ (recur 'sc.name)
(for/sum ((sub (in-list (combinator-args v))))
(recur sub))))
(define (hash2-proc v recur)
(+ (recur 'sc.name)
(for/sum ((sub (in-list (combinator-args v))))
(recur sub))))]
#:property prop:combinator-name (symbol->string 'sc.name))
#:transparent
#:methods gen:sc
[(define sc-map sc.map)
(define sc-traverse sc.traverse)
(define (sc->contract v recur)
(apply
(sc.combinator2 (lambda (args) #`(c #,@args)))
(map recur (combinator-args v))))
(define (sc->constraints v recur)
(merge-restricts* 'kind.category-stx (sc.->restricts v recur)))]
#:methods gen:equal+hash
[(define (equal-proc a b recur)
(and (eqv? (length (combinator-args a))
(length (combinator-args b)))
(for/and ([sub-a (in-list (combinator-args a))]
[sub-b (in-list (combinator-args b))])
(recur sub-a sub-b))))
(define (hash-proc v recur)
(for/fold ([hc (recur 'sc.name)])
([sub (in-list (combinator-args v))])
(bitwise-ior hc (recur sub))))
(define (hash2-proc v recur)
(for/fold ([hc (recur 'sc.name)])
([sub (in-list (combinator-args v))])
(bitwise-ior hc (recur sub))))]
#:property prop:combinator-name (symbol->string 'sc.name))
sc.matcher
sc.definition
sc.provides)]))
@ -166,4 +166,4 @@
((channel/sc . (#:invariant)) channel/c #:chaperone)
((continuation-mark-key/sc (#:invariant)) continuation-mark-key/c #:chaperone)
((evt/sc (#:covariant)) tr:evt/c #:chaperone)
((async-channel/sc (#:invariant)) async-channel/c #:chaperone))
((async-channel/sc (#:invariant)) async-channel/c #:chaperone))

103
typed-racket-lib/typed-racket/static-contracts/constraints.rkt
View File

@ -41,9 +41,8 @@
racket/list
racket/format
racket/function
(contract-req)
racket/dict
racket/set
(contract-req)
syntax/private/id-table
"kinds.rkt"
"equations.rkt")
@ -63,7 +62,6 @@
(require "../utils/utils.rkt"
(contract-req)
racket/match
racket/dict
racket/list
racket/set
syntax/private/id-table
@ -88,7 +86,8 @@
(display open port)
(fprintf port "kind-max")
(display " " port)
(display (map syntax-e (dict-keys variables)) port)
(display (for/list ([(id _) (in-free-id-table variables)]) (syntax-e id))
port)
(display " " port)
(recur max port)
(display close port))])
@ -116,12 +115,12 @@
(recur val port)
(display ")" port))
(define-values (names vals)
(let ((assoc (dict->list recursive-values)))
(values (map car assoc) (map cdr assoc))))
(for/lists (_1 _2) ([(id val) (in-free-id-table recursive-values)])
(values id val)))
(when (cons? names)
(recur-pair (first names) (first vals))
(for ((name (rest names))
(val (rest vals)))
(for ([name (in-list (rest names))]
[val (in-list (rest vals))])
(display " " port)
(recur-pair name val)))
(display ") " port)
@ -152,13 +151,13 @@
(define (free-id-set-union tables)
(for*/fold ([table (make-immutable-free-id-table)])
([new-table (in-list tables)]
[(k _) (in-dict new-table)])
[(k _) (in-free-id-table new-table)])
(free-id-table-set table k #t)))
(define (free-id-table-union tables)
(for*/fold ([table (make-immutable-free-id-table)])
([new-table (in-list tables)]
[(k v) (in-dict new-table)])
[(k v) (in-free-id-table new-table)])
(free-id-table-set table k v)))
(define (simple-contract-restrict kind)
@ -178,7 +177,7 @@
(match con
[(constraint _ 'impersonator)
#t]
[(constraint (kind-max (app dict-count 0) actual) bound)
[(constraint (kind-max (app free-id-table-count 0) actual) bound)
(contract-kind<= actual bound)]
[else #f]))
@ -214,22 +213,25 @@
(define (close-loop names crs body)
(define eqs (make-equation-set))
(define vars
(for*/hash ((name (in-list names)))
(values name
(add-variable! eqs (simple-contract-restrict 'flat)))))
(for/fold ([t (make-immutable-free-id-table)])
([name (in-list names)])
(free-id-table-set t name
(add-variable! eqs (simple-contract-restrict 'flat)))))
(define (variable-lookup name)
(variable-ref (hash-ref vars name)))
(variable-ref (free-id-table-ref vars name)))
(define (instantiate-cr cr lookup-id)
(define (instantiate-kind-max km)
(match km
[(kind-max ids actual)
(define-values (bound-ids unbound-ids)
(partition (lambda (id) (member id names)) (dict-keys ids)))
(merge-kind-maxes 'flat (cons (kind-max (apply free-id-set unbound-ids) actual)
(for/list ([id (in-list bound-ids)])
(contract-restrict-value (lookup-id id)))))]))
(define-values (bvals unbound-ids)
(for/fold ([bvals '()] [ubids (make-immutable-free-id-table)])
([(id _) (in-free-id-table ids)])
(if (member id names)
(values (cons (contract-restrict-value (lookup-id id)) bvals) ubids)
(values bvals (free-id-table-set ubids id #t)))))
(merge-kind-maxes 'flat (cons (kind-max unbound-ids actual) bvals))]))
(define (instantiate-constraint con)
(match con
@ -238,45 +240,52 @@
(match cr
[(contract-restrict (kind-max ids max) rec constraints)
(define-values (bound-ids unbound-ids)
(partition (lambda (id) (member id names)) (dict-keys ids)))
(define-values (bound-vals unbound-ids)
(for/fold ([bvs '()] [ubids (make-immutable-free-id-table)])
([(id _) (in-free-id-table ids)])
(if (member id names)
(values (cons (lookup-id id) bvs) ubids)
(values bvs (free-id-table-set ubids id #t)))))
(merge-restricts* 'flat (cons
(contract-restrict
(kind-max (apply free-id-set unbound-ids) max)
rec
(apply set
(filter (negate trivial-constraint?)
(set-map constraints instantiate-constraint))))
(map lookup-id bound-ids)))]))
(contract-restrict
(kind-max unbound-ids max)
rec
(for*/set ([c (in-immutable-set constraints)]
[ic (in-value (instantiate-constraint c))]
#:when (not (trivial-constraint? ic)))
ic))
bound-vals))]))
(for ([name names] [cr crs])
(for ([name (in-list names)]
[cr (in-list crs)])
(add-equation! eqs
(hash-ref vars name)
(lambda ()
(instantiate-cr cr variable-lookup))))
(free-id-table-ref vars name)
(λ () (instantiate-cr cr variable-lookup))))
(define var-values (resolve-equations eqs))
(define id-values
(for/hash (((name var) vars))
(values name (hash-ref var-values var))))
(define-values (id-values new-rec-values)
(for*/fold ([id-vals (make-immutable-free-id-table)]
[new-rec-vals (make-immutable-free-id-table)])
([(name var) (in-free-id-table vars)]
[val (in-value (hash-ref var-values var))])
(values (free-id-table-set id-vals name val)
(free-id-table-set new-rec-vals name (contract-restrict-value val)))))
(define new-rec-values
(for/hash (((name value) id-values))
(values name (contract-restrict-value value))))
(for/fold ([cr (instantiate-cr body (lambda (id) (hash-ref id-values id)))])
([rec-values (cons new-rec-values (map contract-restrict-recursive-values
(hash-values id-values)))])
(add-recursive-values cr rec-values)))
(for*/fold ([cr (add-recursive-values
(instantiate-cr body (λ (id) (free-id-table-ref id-values id)))
new-rec-values)])
([(_ vals) (in-free-id-table id-values)]
[vals (in-value (contract-restrict-recursive-values vals))])
(add-recursive-values cr vals)))
(define (validate-constraints cr)
(match cr
[(contract-restrict (kind-max (app dict-count 0) _) rec constraints)
(for ([const (in-set constraints)])
[(contract-restrict (kind-max (app free-id-table-count 0) _) rec constraints)
(for ([const (in-immutable-set constraints)])
(match const
[(constraint (kind-max (app dict-count 0) kind) bound)
[(constraint (kind-max (app free-id-table-count 0) kind) bound)
(unless (contract-kind<= kind bound)
(define reason (reason-string kind bound))
(raise (exn:fail:constraint-failure

15
typed-racket-lib/typed-racket/static-contracts/equations.rkt
View File

@ -6,24 +6,27 @@
;; 2. a mapping of variables to thunks that compute new values.
;;
;; Variables are an opaque structure, which support accessing their current value.
(require "../utils/utils.rkt"
(contract-req))
(provide
make-equation-set
add-variable!
add-equation!
resolve-equations
variable-ref)
resolve-equations)
(struct var ())
(provide/cond-contract
[variable-ref (-> var? any/c)])
; equations: (hash/c var? (-> value?))
; initial-values: (hash/c var? (-> value?))
(struct equation-set (equations initial-values))
(define (make-equation-set)
(equation-set (make-hash) (make-hash)))
(equation-set (make-hasheq) (make-hasheq)))
; add-variable!: (equation-set? value? -> var?)
(define (add-variable! eqs initial-value)
@ -35,7 +38,7 @@
(define (add-equation! eqs var thunk)
(hash-set! (equation-set-equations eqs) var thunk))
(define current-variable-values (make-parameter (hash)))
(define current-variable-values (make-parameter (make-hasheq)))
;; resolve-equations (equation-set? -> (hash/c var? value?))
;; Produces a mapping of variables to values such that every equation holds.
@ -55,4 +58,4 @@
values))
(define (variable-ref v)
(hash-ref (current-variable-values) v (lambda () (error 'variable-ref "No value available."))))
(hash-ref (current-variable-values) v (λ () (error 'variable-ref "No value available: ~a" v))))

35
typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
View File

@ -5,9 +5,10 @@
(require
"../utils/utils.rkt"
racket/match
racket/dict
racket/list
racket/contract
racket/syntax
syntax/private/id-table
(for-template racket/base racket/contract)
"combinators.rkt"
"combinators/name.rkt"
@ -56,10 +57,10 @@
(define all-name-defs (get-all-name-defs))
;; all-name-defs maps lists of ids to defs
;; we want to match if any id in the list matches
(define (ref b) (for/first ([(k v) (in-dict all-name-defs)]
#:when (for/or ([k* (in-list k)])
(define (ref b) (for/first ([k/v (in-list all-name-defs)]
#:when (for/or ([k* (in-list (car k/v))])
(free-identifier=? b k*)))
(cons k v)))
k/v))
(define bound '())
;; ignores its second argument (variance, passed by sc-traverse)
(let loop ([sc sc] [_ #f])
@ -70,8 +71,8 @@
;; traverse what `name` refers to
(define r (ref name*))
;; ref returns a rib, get the one definition we want
(define target (for/first ([k (car r)]
[v (cdr r)]
(define target (for/first ([k (in-list (car r))]
[v (in-list (cdr r))]
#:when (free-identifier=? name* k))
v))
(loop target #f))]
@ -96,10 +97,10 @@
(hash-set! memo-table sc result)
result]))
(define constraints
(if (null? name-defs)
(if (hash-empty? name-defs)
(recur sc)
(close-loop (apply append (dict-keys name-defs))
(map recur (apply append (dict-values name-defs)))
(close-loop (apply append (hash-keys name-defs))
(map recur (apply append (hash-values name-defs)))
(recur sc))))
(validate-constraints (add-constraint constraints max-kind))
constraints)
@ -108,21 +109,21 @@
(define (compute-recursive-kinds recursives)
(define eqs (make-equation-set))
(define vars
(for/hash ([(name _) (in-dict recursives)])
(for/hash ([(name _) (in-free-id-table recursives)])
(values name (add-variable! eqs 'flat))))
(define (lookup id)
(variable-ref (hash-ref vars id)))
(for ([(name v) (in-dict recursives)])
(for ([(name v) (in-free-id-table recursives)])
(match v
[(kind-max others max)
(add-equation! eqs
(hash-ref vars name)
(lambda ()
(apply combine-kinds max (map lookup (dict-keys others)))))]))
(λ () (apply combine-kinds max (for/list ([(id _) (in-free-id-table others)])
(lookup id)))))]))
(define var-values (resolve-equations eqs))
(for/hash (((name var) (in-hash vars)))
(for/hash ([(name var) (in-hash vars)])
(values name (hash-ref var-values var))))
@ -188,11 +189,11 @@
;; table to see if we've already defined it. If so, we avoid duplicating
;; the definition later.
(define extra-defs
(cond [(null? name-defs) null]
(cond [(hash-empty? name-defs) null]
[else
(define names (apply append (dict-keys name-defs)))
(define names (apply append (hash-keys name-defs)))
(for/list ([name (in-list names)]
[sc (in-list (apply append (dict-values name-defs)))]
[sc (in-list (apply append (hash-values name-defs)))]
#:unless (lookup-name-defined name))
(set-name-defined name)
#`(define #,name

23
typed-racket-lib/typed-racket/static-contracts/optimize.rkt
View File

@ -5,12 +5,11 @@
(require
"../utils/utils.rkt"
racket/set
(contract-req)
"combinators.rkt"
"structures.rkt"
racket/set
racket/syntax
racket/dict
syntax/private/id-table
racket/list
racket/match)
@ -77,7 +76,7 @@
;; We can turn case->/sc contracts int ->* contracts in some cases.
[(list (arr/sc: args #f ranges) ...) (=> fail)
;; All results must have the same range
(unless (equal? (set-count (apply set ranges)) 1)
(unless (equal? (set-count (list->set ranges)) 1)
(fail))
(define sorted-args (sort args (λ (l1 l2) (< (length l1) (length l2)))))
(define shortest-args (first sorted-args))
@ -140,12 +139,12 @@
(define (recur sc variance)
(match sc
[(recursive-sc-use id)
(dict-set! table id #t)]
(free-id-table-set! table id #t)]
[(recursive-sc names values body)
(recur body 'covariant)
(for ([name (in-list names)]
[value (in-list values)])
(dict-set! main-table name ((search) value)))]
(free-id-table-set! main-table name ((search) value)))]
[else
(sc-traverse sc recur)]))
(lambda (sc)
@ -154,13 +153,13 @@
(define reachable ((search) sc))
(define seen (make-free-id-table reachable))
(let loop ((to-look-at reachable))
(unless (zero? (dict-count to-look-at))
(unless (zero? (free-id-table-count to-look-at))
(define new-table (make-free-id-table))
(for ([(id _) (in-dict to-look-at)])
(for ([(id _) (in-dict (dict-ref main-table id))])
(unless (dict-has-key? seen id)
(dict-set! seen id #t)
(dict-set! new-table id #t))))
(for ([(id _) (in-free-id-table to-look-at)])
(for ([(id _) (in-free-id-table (free-id-table-ref main-table id))])
(unless (free-id-table-ref seen id #f)
(free-id-table-set! seen id #t)
(free-id-table-set! new-table id #t))))
(loop new-table)))
;; Determine if the recursive name is referenced in the static contract
@ -183,7 +182,7 @@
(define new-name-values
(for/list ([name (in-list names)]
[value (in-list values)]
#:when (dict-ref seen name #f))
#:when (free-id-table-ref seen name #f))
(list name value)))
(define new-names (map first new-name-values))
(define new-values (map (λ (v) (trim v 'covariant))

8
typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt
View File

@ -7,7 +7,6 @@
"../utils/utils.rkt"
(contract-req)
racket/match
racket/dict
syntax/private/id-table
"structures.rkt"
"equations.rkt"
@ -27,7 +26,7 @@
(define (get-var sc)
(hash-ref! vars sc (lambda () (add-variable! eqs 0))))
(define (get-rec-var id)
(dict-ref! rec-vars id (lambda () (add-variable! eqs 0))))
(free-id-table-ref! rec-vars id (λ () (add-variable! eqs 0))))
(define seen (make-hash))
@ -39,12 +38,13 @@
(set! seen? #t)]
[(or (or/sc: elems ...) (and/sc: elems ...))
(add-equation! eqs (get-var sc)
(lambda () (for/sum ((e elems))
(lambda () (for/sum ((e (in-list elems)))
(variable-ref (get-var e)))))]
[(or (parametric-var/sc: id) (sealing-var/sc: id))
(add-equation! eqs (get-var sc) (lambda () 1))]
[(recursive-sc names values body)
(for ([name names] [value values])
(for ([name (in-list names)]
[value (in-list values)])
(add-equation! eqs (get-rec-var name) (lambda () (variable-ref (get-var value)))))
(add-equation! eqs (get-var sc) (lambda () (variable-ref (get-var body))))]
[(recursive-sc-use id)

6
typed-racket-lib/typed-racket/static-contracts/structures.rkt
View File

@ -31,8 +31,8 @@
(display ")" port))
(when (cons? names)
(recur-pair (first names) (first vals))
(for ((name (rest names))
(val (rest vals)))
(for ([name (in-list (rest names))]
[val (in-list (rest vals))])
(display " " port)
(recur-pair name val)))
(display ") " port)
@ -56,7 +56,7 @@
(values "#<" ">")))
(display open port)
(fprintf port name)
(for ((arg args))
(for ([arg args])
(display " " port)
(recur arg port))
(display close port))