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

reduce non-determinism in serialized syntax

Browse Source
This commit is contained in:
Matthew Flatt 2018-03-02 06:58:57 -07:00
parent f439ab6b4e
commit 2104d02a23
5 changed files with 128 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
racket/src/expander/compile/header.rkt
View File

@ -260,18 +260,18 @@
;; extra-inspectorsss : a list of hash of symbol to (or/c #f (set/c inspector?)) ;; 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 ;; def-decls : a list of S-expressions for forward-reference declarations
(define (generate-links+imports header phase cctx cross-linklet-inlining?) (define (generate-links+imports header phase cctx cross-linklet-inlining?)
;; Find each distinct module+phase: ;; Find each distinct module+phase, where `link-mod-uses` is in a
(define mod-use-ht ;; determinsitic order
(for/fold ([ht #hash()]) ([(vu) (in-list (header-require-vars-in-order header))]) (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)) (define mu (variable-use-module-use vu))
(if (or (hash-ref ht mu #f) (if (or (hash-ref ht mu #f)
(eq? (module-use-module mu) (eq? (module-use-module mu)
(compile-context-self cctx)) (compile-context-self cctx))
(top-level-module-path-index? (module-use-module mu))) (top-level-module-path-index? (module-use-module mu)))
ht (values ht link-mod-uses)
(hash-set ht mu #t)))) (values (hash-set ht mu #t)
;; List of distinct module+phases: (cons mu link-mod-uses)))))
(define link-mod-uses (hash-keys mod-use-ht))
(values (values
;; Module-uses list: ;; Module-uses list:

35
racket/src/expander/compile/serialize-state.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base #lang racket/base
(require "../common/set.rkt")
(provide (struct-out serialize-state) (provide (struct-out serialize-state)
make-serialize-state make-serialize-state
@ -20,7 +21,8 @@
bindings-intern ; to record pruned binding tables bindings-intern ; to record pruned binding tables
bulk-bindings-intern ; to record pruned bulk-binding lists bulk-bindings-intern ; to record pruned bulk-binding lists
scopes ; interned scope sets 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 mpi-shifts ; interned module path index shifts
context-triples ; combinations of the previous three context-triples ; combinations of the previous three
props ; map full props to previously calculated props ; map full props to previously calculated
@ -29,17 +31,26 @@
sharing-syntaxes)) ; record which syntax objects are `datum->syntax` form sharing-syntaxes)) ; record which syntax objects are `datum->syntax` form
(define (make-serialize-state reachable-scopes) (define (make-serialize-state reachable-scopes)
(serialize-state reachable-scopes (define state
(make-hasheq) ; bindings-intern (serialize-state reachable-scopes
(make-hasheq) ; bulk-bindings-intern (make-hasheq) ; bindings-intern
(make-hash) ; scopes (make-hasheq) ; bulk-bindings-intern
(make-hash) ; shifted-multi-scopes (make-hash) ; scopes
(make-hasheq) ; mpi-shifts (make-hash) ; shifted-multi-scopes
(make-hasheq) ; context-triples (make-hasheq) ; multi-scope-tables
(make-hasheq) ; props (make-hasheq) ; mpi-shifts
(make-hash) ; interned-props (make-hasheq) ; context-triples
(box null) ; syntax-context (make-hasheq) ; props
(make-hasheq))) ; sharing-syntaxes (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) (define (intern-scopes scs state)
(or (hash-ref (serialize-state-scopes state) scs #f) (or (hash-ref (serialize-state-scopes state) scs #f)

22
racket/src/expander/compile/serialize.rkt
View File

@ -110,6 +110,10 @@
pos)))])) pos)))]))
(define (generate-module-path-index-deserialize mpis) (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 positions (module-path-index-table-positions mpis))
(define gen-order (make-hasheqv)) (define gen-order (make-hasheqv))
(define rev-positions (define rev-positions
@ -135,8 +139,9 @@
[(top-level-module-path-index? mpi) [(top-level-module-path-index? mpi)
'top] 'top]
[(not path) [(not path)
(box (or (resolved-module-path-name (box (or (unique-list
(module-path-index-resolved mpi)) (resolved-module-path-name
(module-path-index-resolved mpi)))
'self))] 'self))]
[(not base) [(not base)
(vector path)] (vector path)]
@ -812,8 +817,9 @@
(define (find-reachable-scopes v) (define (find-reachable-scopes v)
(define seen (make-hasheq)) (define seen (make-hasheq))
(define reachable-scopes (seteq)) (define reachable-scopes (seteq))
(define (get-reachable-scopes) reachable-scopes)
(define scope-triggers (make-hasheq)) (define scope-triggers (make-hasheq))
(let loop ([v v]) (let loop ([v v])
(cond (cond
[(interned-literal? v) (void)] [(interned-literal? v) (void)]
@ -825,10 +831,10 @@
(set! reachable-scopes (set-add reachable-scopes v)) (set! reachable-scopes (set-add reachable-scopes v))
((reach-scopes-ref v) v loop) ((reach-scopes-ref v) v loop)
(define l (hash-ref scope-triggers v null)) (for ([proc (in-list (hash-ref scope-triggers v null))])
(for ([v (in-list l)]) (proc loop))
(loop v)) (hash-remove! scope-triggers v)
;; A binding may have a `free-id=?` equivalence; ;; A binding may have a `free-id=?` equivalence;
;; that equivalence is reachable if all the scopes in the ;; that equivalence is reachable if all the scopes in the
@ -836,7 +842,7 @@
;; record a trigger in case the scope bcomes reachable later ;; record a trigger in case the scope bcomes reachable later
((scope-with-bindings-ref v) ((scope-with-bindings-ref v)
v v
reachable-scopes get-reachable-scopes
loop loop
(lambda (sc-unreachable b) (lambda (sc-unreachable b)
(hash-update! scope-triggers (hash-update! scope-triggers

55
racket/src/expander/syntax/binding-table.rkt
View File

@ -33,6 +33,7 @@
binding-table-prune-to-reachable binding-table-prune-to-reachable
binding-table-register-reachable binding-table-register-reachable
prop:implicitly-reachable
deserialize-table-with-bulk-bindings deserialize-table-with-bulk-bindings
deserialize-bulk-binding-at) deserialize-bulk-binding-at)
@ -124,6 +125,9 @@
[syms new-syms] [syms new-syms]
[syms/serialize new-syms/serialize])])) [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 ;; Adding a binding for a computed-on-demand set of symbols
(define (binding-table-add-bulk bt scopes bulk (define (binding-table-add-bulk bt scopes bulk
#:shadow-except [shadow-except #f]) #:shadow-except [shadow-except #f])
@ -282,21 +286,46 @@
(hash-set! (serialize-state-bulk-bindings-intern state) bt new-bt) (hash-set! (serialize-state-bulk-bindings-intern state) bt new-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) (for* ([(sym bindings-for-sym) (in-immutable-hash (if (hash? bt)
bt bt
(table-with-bulk-bindings-syms/serialize bt)))] (table-with-bulk-bindings-syms/serialize bt)))]
[(scopes binding) (in-immutable-hash bindings-for-sym)]) [(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 (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger)
(define v (and (binding-reach-scopes? binding) (define reachable-scopes (get-reachable-scopes))
((binding-reach-scopes-ref binding) binding))) (cond
(when v [(subset? scopes reachable-scopes)
(cond (reach v)]
[(subset? scopes reachable-scopes) [else
(reach v)] ;; There may be implicitly reachable scopes (i.e., multi-scope
[else ;; representatives that should only be reachable if they
(for ([sc (in-set scopes)] ;; participate in a binding)
#:unless (set-member? reachable-scopes sc)) (define pending-scopes
(register-trigger sc v))]))) (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)]))

49
racket/src/expander/syntax/scope.rkt
View File

@ -106,9 +106,9 @@
;; the `bindings` field is handled via `prop:scope-with-bindings` ;; the `bindings` field is handled via `prop:scope-with-bindings`
(void)) (void))
#:property prop:scope-with-bindings #: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) (binding-table-register-reachable (scope-binding-table s)
reachable-scopes get-reachable-scopes
reach reach
register-trigger))) register-trigger)))
@ -143,10 +143,37 @@
(lambda (ms ser-push! state) (lambda (ms ser-push! state)
(ser-push! 'tag '#:multi-scope) (ser-push! 'tag '#:multi-scope)
(ser-push! (multi-scope-name ms)) (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 #:property prop:reach-scopes
(lambda (ms reach) (lambda (s reach)
(reach (multi-scope-scopes ms)))) ;; 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) (define (deserialize-multi-scope name scopes)
(multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash)))) (multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash))))
@ -178,7 +205,9 @@
#:property prop:reach-scopes #:property prop:reach-scopes
(lambda (s reach) (lambda (s reach)
;; the inherited `bindings` field is handled via `prop:scope-with-bindings` ;; 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 (deserialize-representative-scope kind phase)
(define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase)) (define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase))
@ -252,6 +281,9 @@
;; having a larger id ;; having a larger id
(- (new-scope-id!))) (- (new-scope-id!)))
(define (deserialized-scope-id? scope-id)
(negative? scope-id))
;; A shared "outside-edge" scope for all top-level contexts ;; A shared "outside-edge" scope for all top-level contexts
(define top-level-common-scope (scope 0 'module empty-binding-table)) (define top-level-common-scope (scope 0 'module empty-binding-table))
@ -264,7 +296,10 @@
(define (multi-scope-to-scope-at-phase ms phase) (define (multi-scope-to-scope-at-phase ms phase)
;; Get the identity of `ms` at phase` ;; Get the identity of `ms` at phase`
(or (hash-ref (multi-scope-scopes ms) phase #f) (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 empty-binding-table
ms phase)]) ms phase)])
(hash-set! (multi-scope-scopes ms) phase s) (hash-set! (multi-scope-scopes ms) phase s)