Avoid a parameter for controlling resolve caching
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. original commit: 862d58a2f4802e13018b6acb26db7c37842b841a
This commit is contained in:
Asumu Takikawa
parent
4ca82450a1
commit
5f15a74891
|
|
@ -101,166 +101,171 @@
|
|||
;; other definitions need to be registered, do that before calling
|
||||
;; this function.
|
||||
(define (register-all-type-aliases type-alias-names type-alias-map)
|
||||
;; Disable resolve caching for the extent of this setup.
|
||||
;; Makes sure Name types don't get cached too soon.
|
||||
(parameterize ([current-cache-resolve? #f])
|
||||
;; Find type alias dependencies
|
||||
;; The two maps defined here contains the dependency structure
|
||||
;; of type aliases in two senses:
|
||||
;; (1) other type aliases referenced in a type alias
|
||||
;; (2) other type aliases referenced by some class in a
|
||||
;; type alias in a #:implements clause
|
||||
;;
|
||||
;; The second is necessary in order to prevent recursive
|
||||
;; #:implements clauses and to determine the order in which
|
||||
;; recursive type aliases should be initialized.
|
||||
(define-values (type-alias-dependency-map type-alias-class-map)
|
||||
(for/lists (_1 _2)
|
||||
([(name alias-info) (in-dict type-alias-map)])
|
||||
(define links-box (box null))
|
||||
(define class-box (box null))
|
||||
(define type
|
||||
(parameterize ([current-type-alias-name name]
|
||||
[current-referenced-aliases links-box]
|
||||
[current-referenced-class-parents class-box])
|
||||
(parse-type (car alias-info))))
|
||||
(define pre-dependencies
|
||||
(remove-duplicates (unbox links-box) free-identifier=?))
|
||||
(define (filter-by-type-alias-names names)
|
||||
(for/list ([id (in-list names)]
|
||||
#:when (memf (λ (id2) (free-identifier=? id id2))
|
||||
type-alias-names))
|
||||
id))
|
||||
(define alias-dependencies
|
||||
(filter-by-type-alias-names pre-dependencies))
|
||||
(define class-dependencies
|
||||
(filter-by-type-alias-names (unbox class-box)))
|
||||
(values (cons name alias-dependencies)
|
||||
(cons name class-dependencies))))
|
||||
;; Find type alias dependencies
|
||||
;; The two maps defined here contains the dependency structure
|
||||
;; of type aliases in two senses:
|
||||
;; (1) other type aliases referenced in a type alias
|
||||
;; (2) other type aliases referenced by some class in a
|
||||
;; type alias in a #:implements clause
|
||||
;;
|
||||
;; The second is necessary in order to prevent recursive
|
||||
;; #:implements clauses and to determine the order in which
|
||||
;; recursive type aliases should be initialized.
|
||||
(define-values (type-alias-dependency-map type-alias-class-map)
|
||||
(for/lists (_1 _2)
|
||||
([(name alias-info) (in-dict type-alias-map)])
|
||||
(define links-box (box null))
|
||||
(define class-box (box null))
|
||||
(define type
|
||||
(parameterize ([current-type-alias-name name]
|
||||
[current-referenced-aliases links-box]
|
||||
[current-referenced-class-parents class-box])
|
||||
(parse-type (car alias-info))))
|
||||
(define pre-dependencies
|
||||
(remove-duplicates (unbox links-box) free-identifier=?))
|
||||
(define (filter-by-type-alias-names names)
|
||||
(for/list ([id (in-list names)]
|
||||
#:when (memf (λ (id2) (free-identifier=? id id2))
|
||||
type-alias-names))
|
||||
id))
|
||||
(define alias-dependencies
|
||||
(filter-by-type-alias-names pre-dependencies))
|
||||
(define class-dependencies
|
||||
(filter-by-type-alias-names (unbox class-box)))
|
||||
(values (cons name alias-dependencies)
|
||||
(cons name class-dependencies))))
|
||||
|
||||
(define components
|
||||
(find-strongly-connected-type-aliases type-alias-dependency-map))
|
||||
(define components
|
||||
(find-strongly-connected-type-aliases type-alias-dependency-map))
|
||||
|
||||
(define class-components
|
||||
(find-strongly-connected-type-aliases type-alias-class-map))
|
||||
(define class-components
|
||||
(find-strongly-connected-type-aliases type-alias-class-map))
|
||||
|
||||
;; helper function for defining singletons
|
||||
(define (has-self-cycle? component [map type-alias-dependency-map])
|
||||
(define id (car component))
|
||||
(memf (λ (id2) (free-identifier=? id id2))
|
||||
(dict-ref map id)))
|
||||
;; helper function for defining singletons
|
||||
(define (has-self-cycle? component [map type-alias-dependency-map])
|
||||
(define id (car component))
|
||||
(memf (λ (id2) (free-identifier=? id id2))
|
||||
(dict-ref map id)))
|
||||
|
||||
;; A singleton component can be either a self-cycle or a node that
|
||||
;; that does not participate in cycles, so we disambiguate
|
||||
(define-values (acyclic-singletons recursive-aliases)
|
||||
(for/fold ([singletons '()] [other '()])
|
||||
([component (in-list components)])
|
||||
(if (and (= (length component) 1)
|
||||
(not (has-self-cycle? component)))
|
||||
(values (cons (car component) singletons) other)
|
||||
(values singletons (append component other)))))
|
||||
;; A singleton component can be either a self-cycle or a node that
|
||||
;; that does not participate in cycles, so we disambiguate
|
||||
(define-values (acyclic-singletons recursive-aliases)
|
||||
(for/fold ([singletons '()] [other '()])
|
||||
([component (in-list components)])
|
||||
(if (and (= (length component) 1)
|
||||
(not (has-self-cycle? component)))
|
||||
(values (cons (car component) singletons) other)
|
||||
(values singletons (append component other)))))
|
||||
|
||||
;; Check that no #:implements clauses are recursive
|
||||
(define counterexample
|
||||
(for/or ([component class-components])
|
||||
(and (or (not (= (length component) 1))
|
||||
(has-self-cycle? component type-alias-class-map))
|
||||
component)))
|
||||
(when counterexample
|
||||
(tc-error/stx
|
||||
(car counterexample)
|
||||
"Recursive #:implements clause not allowed"))
|
||||
;; Check that no #:implements clauses are recursive
|
||||
(define counterexample
|
||||
(for/or ([component class-components])
|
||||
(and (or (not (= (length component) 1))
|
||||
(has-self-cycle? component type-alias-class-map))
|
||||
component)))
|
||||
(when counterexample
|
||||
(tc-error/stx
|
||||
(car counterexample)
|
||||
"Recursive #:implements clause not allowed"))
|
||||
|
||||
;; Split recursive aliases into those involving classes
|
||||
;; (in reverse topological order) and the rest of the aliases
|
||||
(define class-aliases
|
||||
(for/list ([component (in-list (reverse class-components))]
|
||||
#:when (member (car component)
|
||||
recursive-aliases
|
||||
;; Split recursive aliases into those involving classes
|
||||
;; (in reverse topological order) and the rest of the aliases
|
||||
(define class-aliases
|
||||
(for/list ([component (in-list (reverse class-components))]
|
||||
#:when (member (car component)
|
||||
recursive-aliases
|
||||
free-identifier=?))
|
||||
(car component)))
|
||||
(define other-recursive-aliases
|
||||
(for/list ([alias (in-list recursive-aliases)]
|
||||
#:unless (member alias
|
||||
class-aliases
|
||||
free-identifier=?))
|
||||
(car component)))
|
||||
(define other-recursive-aliases
|
||||
(for/list ([alias (in-list recursive-aliases)]
|
||||
#:unless (member alias
|
||||
class-aliases
|
||||
alias))
|
||||
|
||||
;; Reconstruct type alias dependency map based on class parent
|
||||
;; information. This ensures that the `deps` field is precise
|
||||
;; 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=?))
|
||||
alias))
|
||||
(cons id new-deps)]
|
||||
[else (cons id deps)])))
|
||||
|
||||
;; Reconstruct type alias dependency map based on class parent
|
||||
;; information. This ensures that the `deps` field is precise
|
||||
;; 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)]))
|
||||
;; 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)))
|
||||
|
||||
(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=?))
|
||||
(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)])
|
||||
;; Actually register recursive type aliases
|
||||
(define name-types
|
||||
(for/list ([id (in-list recursive-aliases)])
|
||||
(define record (dict-ref type-alias-map id))
|
||||
(match-define (list _ args) record)
|
||||
(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
|
||||
;;
|
||||
;; Note that the connected component algorithm returns results
|
||||
;; in topologically sorted order, so we want to go through in the
|
||||
;; reverse order of that to avoid unbound type aliases.
|
||||
(for ([id (in-list acyclic-singletons)])
|
||||
(define type-stx (car (dict-ref type-alias-map id)))
|
||||
(register-resolved-type-alias id (parse-type type-stx)))
|
||||
;; Register non-recursive type aliases
|
||||
;;
|
||||
;; Note that the connected component algorithm returns results
|
||||
;; in topologically sorted order, so we want to go through in the
|
||||
;; reverse order of that to avoid unbound type aliases.
|
||||
(for ([id (in-list acyclic-singletons)])
|
||||
(define type-stx (car (dict-ref type-alias-map id)))
|
||||
(register-resolved-type-alias id (parse-type type-stx)))
|
||||
|
||||
;; Finish registering recursive aliases
|
||||
;; 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)))
|
||||
(register-type-name id type)
|
||||
(add-constant-variance! id args)
|
||||
(check-type-alias-contractive id type)
|
||||
(values id type args)))
|
||||
;; Clear the resolver cache of Name types from this block
|
||||
(define (reset-resolver-cache!) (resolver-cache-remove! name-types))
|
||||
(reset-resolver-cache!)
|
||||
|
||||
;; Finally, do a last pass to refine the variance
|
||||
(refine-variance! names-to-refine types-to-refine tvarss)))
|
||||
;; Finish registering recursive aliases
|
||||
;; 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>
|
||||
;; Parse a type alias internal declaration
|
||||
|
|
|
|||
|
|
@ -11,19 +11,12 @@
|
|||
|
||||
(provide resolve-name resolve-app needs-resolving?
|
||||
resolve resolve-app-check-error
|
||||
current-cache-resolve?
|
||||
resolver-cache-remove!
|
||||
current-check-polymorphic-recursion)
|
||||
(provide/cond-contract [resolve-once (Type/c . -> . (or/c Type/c #f))])
|
||||
|
||||
(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>>>
|
||||
;; This parameter controls whether or not the resolving process
|
||||
;; should check for polymorphic recursion in implicit recursive
|
||||
|
|
@ -146,11 +139,17 @@
|
|||
(resolve-app r r* s)]
|
||||
[(Name: _ _ _ _) (resolve-name t)])])
|
||||
(when (and r*
|
||||
(not (currently-subtyping?))
|
||||
(current-cache-resolve?))
|
||||
(not (currently-subtyping?)))
|
||||
(hash-set! resolver-cache seq 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
|
||||
;; constructor is not one of them.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user