diff --git a/racket/src/expander/compile/header.rkt b/racket/src/expander/compile/header.rkt index bc43a9738f..190e0615b1 100644 --- a/racket/src/expander/compile/header.rkt +++ b/racket/src/expander/compile/header.rkt @@ -260,18 +260,18 @@ ;; extra-inspectorsss : a list of hash of symbol to (or/c #f (set/c inspector?)) ;; def-decls : a list of S-expressions for forward-reference declarations (define (generate-links+imports header phase cctx cross-linklet-inlining?) - ;; Find each distinct module+phase: - (define mod-use-ht - (for/fold ([ht #hash()]) ([(vu) (in-list (header-require-vars-in-order header))]) + ;; Find each distinct module+phase, where `link-mod-uses` is in a + ;; determinsitic order + (define-values (mod-use-ht link-mod-uses) + (for/fold ([ht #hash()] [link-mod-uses null]) ([(vu) (in-list (header-require-vars-in-order header))]) (define mu (variable-use-module-use vu)) (if (or (hash-ref ht mu #f) (eq? (module-use-module mu) (compile-context-self cctx)) (top-level-module-path-index? (module-use-module mu))) - ht - (hash-set ht mu #t)))) - ;; List of distinct module+phases: - (define link-mod-uses (hash-keys mod-use-ht)) + (values ht link-mod-uses) + (values (hash-set ht mu #t) + (cons mu link-mod-uses))))) (values ;; Module-uses list: diff --git a/racket/src/expander/compile/serialize-state.rkt b/racket/src/expander/compile/serialize-state.rkt index 13b5fda418..726f192230 100644 --- a/racket/src/expander/compile/serialize-state.rkt +++ b/racket/src/expander/compile/serialize-state.rkt @@ -1,4 +1,5 @@ #lang racket/base +(require "../common/set.rkt") (provide (struct-out serialize-state) make-serialize-state @@ -20,7 +21,8 @@ bindings-intern ; to record pruned binding tables bulk-bindings-intern ; to record pruned bulk-binding lists scopes ; interned scope sets - shifted-multi-scopes ; interned shifted multi-scope lists + shifted-multi-scopes ; interned shifted multi-scope sets + multi-scope-tables ; interned phase -> scope tables mpi-shifts ; interned module path index shifts context-triples ; combinations of the previous three props ; map full props to previously calculated @@ -29,17 +31,26 @@ sharing-syntaxes)) ; record which syntax objects are `datum->syntax` form (define (make-serialize-state reachable-scopes) - (serialize-state reachable-scopes - (make-hasheq) ; bindings-intern - (make-hasheq) ; bulk-bindings-intern - (make-hash) ; scopes - (make-hash) ; shifted-multi-scopes - (make-hasheq) ; mpi-shifts - (make-hasheq) ; context-triples - (make-hasheq) ; props - (make-hash) ; interned-props - (box null) ; syntax-context - (make-hasheq))) ; sharing-syntaxes + (define state + (serialize-state reachable-scopes + (make-hasheq) ; bindings-intern + (make-hasheq) ; bulk-bindings-intern + (make-hash) ; scopes + (make-hash) ; shifted-multi-scopes + (make-hasheq) ; multi-scope-tables + (make-hasheq) ; mpi-shifts + (make-hasheq) ; context-triples + (make-hasheq) ; props + (make-hash) ; interned-props + (box null) ; syntax-context + (make-hasheq))) ; sharing-syntaxes + ;; Seed intern tables for sets and hashes to use the canonical + ;; empty version for consistent sharing: + (define empty-seteq (seteq)) + (hash-set! (serialize-state-scopes state) empty-seteq empty-seteq) + (hash-set! (serialize-state-shifted-multi-scopes state) empty-seteq empty-seteq) + (hash-set! (serialize-state-interned-props state) empty-seteq empty-seteq) + state) (define (intern-scopes scs state) (or (hash-ref (serialize-state-scopes state) scs #f) diff --git a/racket/src/expander/compile/serialize.rkt b/racket/src/expander/compile/serialize.rkt index 0ca1002ac7..2b646f4993 100644 --- a/racket/src/expander/compile/serialize.rkt +++ b/racket/src/expander/compile/serialize.rkt @@ -110,6 +110,10 @@ pos)))])) (define (generate-module-path-index-deserialize mpis) + (define (unique-list v) + (if (pair? v) + (for/list ([i (in-list v)]) i) ; avoid non-deterministic sharing + v)) (define positions (module-path-index-table-positions mpis)) (define gen-order (make-hasheqv)) (define rev-positions @@ -135,8 +139,9 @@ [(top-level-module-path-index? mpi) 'top] [(not path) - (box (or (resolved-module-path-name - (module-path-index-resolved mpi)) + (box (or (unique-list + (resolved-module-path-name + (module-path-index-resolved mpi))) 'self))] [(not base) (vector path)] @@ -812,8 +817,9 @@ (define (find-reachable-scopes v) (define seen (make-hasheq)) (define reachable-scopes (seteq)) + (define (get-reachable-scopes) reachable-scopes) (define scope-triggers (make-hasheq)) - + (let loop ([v v]) (cond [(interned-literal? v) (void)] @@ -825,10 +831,10 @@ (set! reachable-scopes (set-add reachable-scopes v)) ((reach-scopes-ref v) v loop) - - (define l (hash-ref scope-triggers v null)) - (for ([v (in-list l)]) - (loop v)) + + (for ([proc (in-list (hash-ref scope-triggers v null))]) + (proc loop)) + (hash-remove! scope-triggers v) ;; A binding may have a `free-id=?` equivalence; ;; that equivalence is reachable if all the scopes in the @@ -836,7 +842,7 @@ ;; record a trigger in case the scope bcomes reachable later ((scope-with-bindings-ref v) v - reachable-scopes + get-reachable-scopes loop (lambda (sc-unreachable b) (hash-update! scope-triggers diff --git a/racket/src/expander/syntax/binding-table.rkt b/racket/src/expander/syntax/binding-table.rkt index b54144af31..763cc5aeef 100644 --- a/racket/src/expander/syntax/binding-table.rkt +++ b/racket/src/expander/syntax/binding-table.rkt @@ -33,6 +33,7 @@ binding-table-prune-to-reachable binding-table-register-reachable + prop:implicitly-reachable deserialize-table-with-bulk-bindings deserialize-bulk-binding-at) @@ -124,6 +125,9 @@ [syms new-syms] [syms/serialize new-syms/serialize])])) +(define-values (prop:implicitly-reachable implicitly-reachable? implicitly-reachable-ref) + (make-struct-type-property 'implicitly-reachable)) + ;; Adding a binding for a computed-on-demand set of symbols (define (binding-table-add-bulk bt scopes bulk #:shadow-except [shadow-except #f]) @@ -282,21 +286,46 @@ (hash-set! (serialize-state-bulk-bindings-intern state) bt new-bt) new-bt))) -(define (binding-table-register-reachable bt reachable-scopes reach register-trigger) +(define (binding-table-register-reachable bt get-reachable-scopes reach register-trigger) + ;; Check symbol-specific scopes for both `free-id=?` reachability and + ;; for implicitly reachable scopes (for* ([(sym bindings-for-sym) (in-immutable-hash (if (hash? bt) bt (table-with-bulk-bindings-syms/serialize bt)))] [(scopes binding) (in-immutable-hash bindings-for-sym)]) - (scopes-register-reachable scopes binding reachable-scopes reach register-trigger))) + (define v (and (binding-reach-scopes? binding) + ((binding-reach-scopes-ref binding) binding))) + (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger)) + ;; Need to check bulk-binding scopes for implicitly reachable + (when (table-with-bulk-bindings? bt) + (for ([bba (in-list (table-with-bulk-bindings-bulk-bindings bt))]) + (scopes-register-reachable (bulk-binding-at-scopes bba) #f get-reachable-scopes reach register-trigger)))) -(define (scopes-register-reachable scopes binding reachable-scopes reach register-trigger) - (define v (and (binding-reach-scopes? binding) - ((binding-reach-scopes-ref binding) binding))) - (when v - (cond - [(subset? scopes reachable-scopes) - (reach v)] - [else - (for ([sc (in-set scopes)] - #:unless (set-member? reachable-scopes sc)) - (register-trigger sc v))]))) +(define (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger) + (define reachable-scopes (get-reachable-scopes)) + (cond + [(subset? scopes reachable-scopes) + (reach v)] + [else + ;; There may be implicitly reachable scopes (i.e., multi-scope + ;; representatives that should only be reachable if they + ;; participate in a binding) + (define pending-scopes + (for/seteq ([sc (in-set scopes)] + #:unless (or (set-member? reachable-scopes sc) + (implicitly-reachable? sc))) + sc)) + (define (check-trigger reach) + (when (zero? (hash-count pending-scopes)) + ;; All scopes became reachable, so make the value reachable, + ;; and declare implcitily reachables as explicitly reachable + (reach v) + (for ([sc (in-set scopes)]) + (when (implicitly-reachable? sc) + (reach sc))))) + (for ([sc (in-set pending-scopes)]) + (register-trigger sc (lambda (reach) + (set! pending-scopes (hash-remove pending-scopes sc)) + (check-trigger reach)))) + ;; In case there were only implicitly reachable scopes: + (check-trigger reach)])) diff --git a/racket/src/expander/syntax/scope.rkt b/racket/src/expander/syntax/scope.rkt index 5caa94a086..2bb8dc6b35 100644 --- a/racket/src/expander/syntax/scope.rkt +++ b/racket/src/expander/syntax/scope.rkt @@ -106,9 +106,9 @@ ;; the `bindings` field is handled via `prop:scope-with-bindings` (void)) #:property prop:scope-with-bindings - (lambda (s reachable-scopes reach register-trigger) + (lambda (s get-reachable-scopes reach register-trigger) (binding-table-register-reachable (scope-binding-table s) - reachable-scopes + get-reachable-scopes reach register-trigger))) @@ -143,10 +143,37 @@ (lambda (ms ser-push! state) (ser-push! 'tag '#:multi-scope) (ser-push! (multi-scope-name ms)) - (ser-push! (multi-scope-scopes ms))) + ;; Prune to reachable representative scopes + (define multi-scope-tables (serialize-state-multi-scope-tables state)) + (ser-push! (or (hash-ref multi-scope-tables (multi-scope-scopes ms) #f) + (let ([ht (make-hasheqv)]) + (for ([(phase sc) (in-hash (multi-scope-scopes ms))]) + (when (set-member? (serialize-state-reachable-scopes state) sc) + (hash-set! ht phase sc))) + (hash-set! multi-scope-tables (multi-scope-scopes ms) ht) + ht)))) #:property prop:reach-scopes - (lambda (ms reach) - (reach (multi-scope-scopes ms)))) + (lambda (s reach) + ;; the `scopes` field is handled via `prop:scope-with-bindings` + (void)) + #:property prop:scope-with-bindings + (lambda (ms get-reachable-scopes reach register-trigger) + ;; This scope is reachable via its multi-scope, but it only + ;; matters if it's reachable through a binding (otherwise it + ;; can be re-generated later). We don't want to keep a scope + ;; that can be re-generated, because pruning it makes + ;; compilation more deterministic relative to other + ;; compilations that involve a shared module. If the scope + ;; itself has any bindings, then we count it as reachable + ;; through a binding (which is an approxmation, because + ;; other scopes in the binding may be unreachable, but it + ;; seems good enough for determinism). + ;; To make that work, `binding-table-register-reachable` + ;; needs to recognize representative scopes and treat + ;; them differently, hence `prop:implicitly-reachable`. + (for ([sc (in-hash-values (multi-scope-scopes ms))]) + (unless (binding-table-empty? (scope-binding-table sc)) + (reach sc))))) (define (deserialize-multi-scope name scopes) (multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash)))) @@ -178,7 +205,9 @@ #:property prop:reach-scopes (lambda (s reach) ;; the inherited `bindings` field is handled via `prop:scope-with-bindings` - (reach (representative-scope-owner s)))) + (reach (representative-scope-owner s))) + ;; Used by `binding-table-register-reachable`: + #:property prop:implicitly-reachable #t) (define (deserialize-representative-scope kind phase) (define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase)) @@ -252,6 +281,9 @@ ;; having a larger id (- (new-scope-id!))) +(define (deserialized-scope-id? scope-id) + (negative? scope-id)) + ;; A shared "outside-edge" scope for all top-level contexts (define top-level-common-scope (scope 0 'module empty-binding-table)) @@ -264,7 +296,10 @@ (define (multi-scope-to-scope-at-phase ms phase) ;; Get the identity of `ms` at phase` (or (hash-ref (multi-scope-scopes ms) phase #f) - (let ([s (representative-scope (new-scope-id!) 'module + (let ([s (representative-scope (if (deserialized-scope-id? (multi-scope-id ms)) + (new-deserialize-scope-id!) + (new-scope-id!)) + 'module empty-binding-table ms phase)]) (hash-set! (multi-scope-scopes ms) phase s)