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

Avoid a parameter for controlling resolve caching

Browse Source 
The parameter dereference slowed down type-checking
new-metrics.rkt to about 28s from 16s on DrDr.

Instead of the parameter, explicitly remove items from the
cache during type alias setup.
This commit is contained in:
Asumu Takikawa 2014-03-21 00:57:30 -04:00
parent e4716bd68a
commit 862d58a2f4
2 changed files with 158 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

293
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt vendored
View File

@ -101,166 +101,171 @@
;; other definitions need to be registered, do that before calling ;; other definitions need to be registered, do that before calling
;; this function. ;; this function.
(define (register-all-type-aliases type-alias-names type-alias-map) (define (register-all-type-aliases type-alias-names type-alias-map)
;; Disable resolve caching for the extent of this setup. ;; Find type alias dependencies
;; Makes sure Name types don't get cached too soon. ;; The two maps defined here contains the dependency structure
(parameterize ([current-cache-resolve? #f]) ;; of type aliases in two senses:
;; Find type alias dependencies ;; (1) other type aliases referenced in a type alias
;; The two maps defined here contains the dependency structure ;; (2) other type aliases referenced by some class in a
;; of type aliases in two senses: ;; type alias in a #:implements clause
;; (1) other type aliases referenced in a type alias ;;
;; (2) other type aliases referenced by some class in a ;; The second is necessary in order to prevent recursive
;; type alias in a #:implements clause ;; #:implements clauses and to determine the order in which
;; ;; recursive type aliases should be initialized.
;; The second is necessary in order to prevent recursive (define-values (type-alias-dependency-map type-alias-class-map)
;; #:implements clauses and to determine the order in which (for/lists (_1 _2)
;; recursive type aliases should be initialized. ([(name alias-info) (in-dict type-alias-map)])
(define-values (type-alias-dependency-map type-alias-class-map) (define links-box (box null))
(for/lists (_1 _2) (define class-box (box null))
([(name alias-info) (in-dict type-alias-map)]) (define type
(define links-box (box null)) (parameterize ([current-type-alias-name name]
(define class-box (box null)) [current-referenced-aliases links-box]
(define type [current-referenced-class-parents class-box])
(parameterize ([current-type-alias-name name] (parse-type (car alias-info))))
[current-referenced-aliases links-box] (define pre-dependencies
[current-referenced-class-parents class-box]) (remove-duplicates (unbox links-box) free-identifier=?))
(parse-type (car alias-info)))) (define (filter-by-type-alias-names names)
(define pre-dependencies (for/list ([id (in-list names)]
(remove-duplicates (unbox links-box) free-identifier=?)) #:when (memf (λ (id2) (free-identifier=? id id2))
(define (filter-by-type-alias-names names) type-alias-names))
(for/list ([id (in-list names)] id))
#:when (memf (λ (id2) (free-identifier=? id id2)) (define alias-dependencies
type-alias-names)) (filter-by-type-alias-names pre-dependencies))
id)) (define class-dependencies
(define alias-dependencies (filter-by-type-alias-names (unbox class-box)))
(filter-by-type-alias-names pre-dependencies)) (values (cons name alias-dependencies)
(define class-dependencies (cons name class-dependencies))))
(filter-by-type-alias-names (unbox class-box)))
(values (cons name alias-dependencies)
(cons name class-dependencies))))
(define components (define components
(find-strongly-connected-type-aliases type-alias-dependency-map)) (find-strongly-connected-type-aliases type-alias-dependency-map))
(define class-components (define class-components
(find-strongly-connected-type-aliases type-alias-class-map)) (find-strongly-connected-type-aliases type-alias-class-map))
;; helper function for defining singletons ;; helper function for defining singletons
(define (has-self-cycle? component [map type-alias-dependency-map]) (define (has-self-cycle? component [map type-alias-dependency-map])
(define id (car component)) (define id (car component))
(memf (λ (id2) (free-identifier=? id id2)) (memf (λ (id2) (free-identifier=? id id2))
(dict-ref map id))) (dict-ref map id)))
;; A singleton component can be either a self-cycle or a node that ;; A singleton component can be either a self-cycle or a node that
;; that does not participate in cycles, so we disambiguate ;; that does not participate in cycles, so we disambiguate
(define-values (acyclic-singletons recursive-aliases) (define-values (acyclic-singletons recursive-aliases)
(for/fold ([singletons '()] [other '()]) (for/fold ([singletons '()] [other '()])
([component (in-list components)]) ([component (in-list components)])
(if (and (= (length component) 1) (if (and (= (length component) 1)
(not (has-self-cycle? component))) (not (has-self-cycle? component)))
(values (cons (car component) singletons) other) (values (cons (car component) singletons) other)
(values singletons (append component other))))) (values singletons (append component other)))))
;; Check that no #:implements clauses are recursive ;; Check that no #:implements clauses are recursive
(define counterexample (define counterexample
(for/or ([component class-components]) (for/or ([component class-components])
(and (or (not (= (length component) 1)) (and (or (not (= (length component) 1))
(has-self-cycle? component type-alias-class-map)) (has-self-cycle? component type-alias-class-map))
component))) component)))
(when counterexample (when counterexample
(tc-error/stx (tc-error/stx
(car counterexample) (car counterexample)
"Recursive #:implements clause not allowed")) "Recursive #:implements clause not allowed"))
;; Split recursive aliases into those involving classes ;; Split recursive aliases into those involving classes
;; (in reverse topological order) and the rest of the aliases ;; (in reverse topological order) and the rest of the aliases
(define class-aliases (define class-aliases
(for/list ([component (in-list (reverse class-components))] (for/list ([component (in-list (reverse class-components))]
#:when (member (car component) #:when (member (car component)
recursive-aliases recursive-aliases
free-identifier=?))
(car component)))
(define other-recursive-aliases
(for/list ([alias (in-list recursive-aliases)]
#:unless (member alias
class-aliases
free-identifier=?)) free-identifier=?))
(car component))) alias))
(define other-recursive-aliases
(for/list ([alias (in-list recursive-aliases)] ;; Reconstruct type alias dependency map based on class parent
#:unless (member alias ;; information. This ensures that the `deps` field is precise
class-aliases ;; in all type aliases involving class types
(define (get-all-parent-deps id)
(define (get-deps parent)
(cdr (assoc parent type-alias-dependency-map free-identifier=?)))
(define parents (cdr (assoc id type-alias-class-map free-identifier=?)))
(cond [(null? parents) null]
[else
(define all-deps
(for/list ([parent parents])
(append (get-deps parent)
(get-all-parent-deps parent))))
(apply append all-deps)]))
(define new-dependency-map/classes
(for/list ([(id deps) (in-dict type-alias-dependency-map)])
(cond [(dict-has-key? type-alias-class-map id)
(define new-deps
(remove-duplicates (append (get-all-parent-deps id) deps)
free-identifier=?)) free-identifier=?))
alias)) (cons id new-deps)]
[else (cons id deps)])))
;; Reconstruct type alias dependency map based on class parent ;; Do another pass on dependency map, using the connected
;; information. This ensures that the `deps` field is precise ;; components analysis data to determine which dependencies are
;; in all type aliases involving class types ;; actually needed for mutual recursion. Drop all others.
(define (get-all-parent-deps id) (define new-dependency-map
(define (get-deps parent) (for/list ([(id deps) (in-dict new-dependency-map/classes)])
(cdr (assoc parent type-alias-dependency-map free-identifier=?))) ;; find the component this `id` participated in so
(define parents (cdr (assoc id type-alias-class-map free-identifier=?))) ;; that we can drop `deps` that aren't in that component
(cond [(null? parents) null] (define component
[else (findf (λ (component) (member id component free-identifier=?))
(define all-deps components))
(for/list ([parent parents]) (define new-deps
(append (get-deps parent) (filter (λ (dep) (member dep component free-identifier=?)) deps))
(get-all-parent-deps parent)))) (cons id new-deps)))
(apply append all-deps)]))
(define new-dependency-map/classes ;; Actually register recursive type aliases
(for/list ([(id deps) (in-dict type-alias-dependency-map)]) (define name-types
(cond [(dict-has-key? type-alias-class-map id) (for/list ([id (in-list recursive-aliases)])
(define new-deps
(remove-duplicates (append (get-all-parent-deps id) deps)
free-identifier=?))
(cons id new-deps)]
[else (cons id deps)])))
;; Do another pass on dependency map, using the connected
;; components analysis data to determine which dependencies are
;; actually needed for mutual recursion. Drop all others.
(define new-dependency-map
(for/list ([(id deps) (in-dict new-dependency-map/classes)])
;; find the component this `id` participated in so
;; that we can drop `deps` that aren't in that component
(define component
(findf (λ (component) (member id component free-identifier=?))
components))
(define new-deps
(filter (λ (dep) (member dep component free-identifier=?)) deps))
(cons id new-deps)))
;; Actually register recursive type aliases
(for ([id (in-list recursive-aliases)])
(define record (dict-ref type-alias-map id)) (define record (dict-ref type-alias-map id))
(match-define (list _ args) record) (match-define (list _ args) record)
(define deps (dict-ref new-dependency-map id)) (define deps (dict-ref new-dependency-map id))
(register-resolved-type-alias id (make-Name id deps args #f))) (define name-type (make-Name id deps args #f))
(register-resolved-type-alias id name-type)
name-type))
;; Register non-recursive type aliases ;; Register non-recursive type aliases
;; ;;
;; Note that the connected component algorithm returns results ;; Note that the connected component algorithm returns results
;; in topologically sorted order, so we want to go through in the ;; in topologically sorted order, so we want to go through in the
;; reverse order of that to avoid unbound type aliases. ;; reverse order of that to avoid unbound type aliases.
(for ([id (in-list acyclic-singletons)]) (for ([id (in-list acyclic-singletons)])
(define type-stx (car (dict-ref type-alias-map id))) (define type-stx (car (dict-ref type-alias-map id)))
(register-resolved-type-alias id (parse-type type-stx))) (register-resolved-type-alias id (parse-type type-stx)))
;; Finish registering recursive aliases ;; Clear the resolver cache of Name types from this block
;; names-to-refine : Listof<Id> (define (reset-resolver-cache!) (resolver-cache-remove! name-types))
;; types-to-refine : Listof<Type> (reset-resolver-cache!)
;; tvarss : Listof<Listof<Symbol>>
(define-values (names-to-refine types-to-refine tvarss)
(for/lists (_1 _2 _3)
([id (in-list (append other-recursive-aliases class-aliases))])
(define record (dict-ref type-alias-map id))
(match-define (list type-stx args) record)
(define type
;; make sure to reject the type if it uses polymorphic
;; recursion (see resolve.rkt)
(parameterize ([current-check-polymorphic-recursion args])
(parse-type type-stx)))
(register-type-name id type)
(add-constant-variance! id args)
(check-type-alias-contractive id type)
(values id type args)))
;; Finally, do a last pass to refine the variance ;; Finish registering recursive aliases
(refine-variance! names-to-refine types-to-refine tvarss))) ;; names-to-refine : Listof<Id>
;; types-to-refine : Listof<Type>
;; tvarss : Listof<Listof<Symbol>>
(define-values (names-to-refine types-to-refine tvarss)
(for/lists (_1 _2 _3)
([id (in-list (append other-recursive-aliases class-aliases))])
(define record (dict-ref type-alias-map id))
(match-define (list type-stx args) record)
(define type
;; make sure to reject the type if it uses polymorphic
;; recursion (see resolve.rkt)
(parameterize ([current-check-polymorphic-recursion args])
(parse-type type-stx)))
(reset-resolver-cache!)
(register-type-name id type)
(add-constant-variance! id args)
(check-type-alias-contractive id type)
(values id type args)))
;; Finally, do a last pass to refine the variance
(refine-variance! names-to-refine types-to-refine tvarss))
;; Syntax -> Syntax Syntax Syntax Option<Integer> ;; Syntax -> Syntax Syntax Syntax Option<Integer>
;; Parse a type alias internal declaration ;; Parse a type alias internal declaration

19
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt
View File

@ -11,19 +11,12 @@
(provide resolve-name resolve-app needs-resolving? (provide resolve-name resolve-app needs-resolving?
resolve resolve-app-check-error resolve resolve-app-check-error
current-cache-resolve? resolver-cache-remove!
current-check-polymorphic-recursion) current-check-polymorphic-recursion)
(provide/cond-contract [resolve-once (Type/c . -> . (or/c Type/c #f))]) (provide/cond-contract [resolve-once (Type/c . -> . (or/c Type/c #f))])
(define-struct poly (name vars) #:prefab) (define-struct poly (name vars) #:prefab)
;; This parameter allows other parts of the typechecker to
;; request that the resolve cache isn't updated. This is needed
;; by the setup for recursive type aliases, since certain Name
;; types should not be cached while their mapping is still being
;; computed.
(define current-cache-resolve? (make-parameter #f))
;; Parameter<Option<Listof<Symbol>>> ;; Parameter<Option<Listof<Symbol>>>
;; This parameter controls whether or not the resolving process ;; This parameter controls whether or not the resolving process
;; should check for polymorphic recursion in implicit recursive ;; should check for polymorphic recursion in implicit recursive
@ -146,11 +139,17 @@
(resolve-app r r* s)] (resolve-app r r* s)]
[(Name: _ _ _ _) (resolve-name t)])]) [(Name: _ _ _ _) (resolve-name t)])])
(when (and r* (when (and r*
(not (currently-subtyping?)) (not (currently-subtyping?)))
(current-cache-resolve?))
(hash-set! resolver-cache seq r*)) (hash-set! resolver-cache seq r*))
r*))) r*)))
;; resolver-cache-remove! : (Listof Type) -> Void
;; Removes the given types from the resolver cache. This is
;; only used by recursive type alias set-up, which sometimes needs to
;; undo certain resolutions.
(define (resolver-cache-remove! keys)
(for ([key (in-list keys)])
(hash-remove! resolver-cache (Rep-seq key))))
;; Repeatedly unfolds Mu, App, and Name constructors until the top type ;; Repeatedly unfolds Mu, App, and Name constructors until the top type
;; constructor is not one of them. ;; constructor is not one of them.