diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt index 6d14e0ac..6535c1aa 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt index e9352f2e..536d95d6 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt @@ -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)) \ No newline at end of file diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt index 1dd72202..48bc3283 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt @@ -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)) \ No newline at end of file diff --git a/typed-racket-lib/typed-racket/static-contracts/constraints.rkt b/typed-racket-lib/typed-racket/static-contracts/constraints.rkt index 04077f44..eb9ae6c3 100644 --- a/typed-racket-lib/typed-racket/static-contracts/constraints.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/constraints.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/static-contracts/equations.rkt b/typed-racket-lib/typed-racket/static-contracts/equations.rkt index cdbe35be..f5cf37bf 100644 --- a/typed-racket-lib/typed-racket/static-contracts/equations.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/equations.rkt @@ -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)))) diff --git a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt index c2a20de7..9f9297bc 100644 --- a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/typed-racket-lib/typed-racket/static-contracts/optimize.rkt index acd4ae5f..d2614981 100644 --- a/typed-racket-lib/typed-racket/static-contracts/optimize.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/optimize.rkt @@ -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)) diff --git a/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt b/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt index 06e24909..632ad672 100644 --- a/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/typed-racket-lib/typed-racket/static-contracts/structures.rkt index 9c2a37b6..e78bd627 100644 --- a/typed-racket-lib/typed-racket/static-contracts/structures.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/structures.rkt @@ -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))