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?))
;; 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:

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

@ -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)

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

@ -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,6 +817,7 @@
(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])
@ -826,9 +832,9 @@
((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

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

@ -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)]))

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

@ -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)