From 5f15a74891b2126686d28a6ad7b9d364d94f7f61 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 21 Mar 2014 00:57:30 -0400 Subject: [PATCH] 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 --- .../typed-racket/env/type-alias-helper.rkt | 293 +++++++++--------- .../typed-racket/types/resolve.rkt | 19 +- 2 files changed, 158 insertions(+), 154 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt index 98aa2326..6a342b39 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt @@ -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 - ;; types-to-refine : Listof - ;; tvarss : Listof> - (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 + ;; types-to-refine : Listof + ;; tvarss : Listof> + (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 ;; Parse a type alias internal declaration diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt index 5fccb2e4..a151b808 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt @@ -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>> ;; 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.