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

add syntax-serialize and syntax-deserialize

Browse Source 
The new functions provide a more direct way to serialize and
deserialize syntax objects than compiling and running a `quote-syntax`
form. The new functions also offer additional configuration related to
preserving extra syntax properties and limiting the use of shared
"bulk binding" tables (i.e., tables that must provided by module
declarations in the namespace).

This change does not add syntax-object support to `serialize` or
`s-exp->fasl`, because serialized syntax objects are still in many
ways like code: they are version-specific, and their invariants can be
broken by mangling the serialized form (in much the same way that
compiled code can be broken by mangling, and with similar safetly
implications).
This commit is contained in:
Matthew Flatt 2021-04-01 06:57:56 -06:00
parent 2606ae3d8e
commit 181b9c80ac
20 changed files with 4258 additions and 2456 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "8.0.0.12")
(define version "8.0.0.13")
(define deps `("racket-lib"
["racket" #:version ,version]))

1
pkgs/racket-doc/scribblings/reference/macros.scrbl
View File

@ -23,5 +23,6 @@ called.
@include-section["stx-props.scrbl"]
@include-section["stx-taints.scrbl"]
@include-section["stx-expand.scrbl"]
@include-section["stx-serialize.scrbl"]
@include-section["include.scrbl"]
@include-section["syntax-util.scrbl"]

76
pkgs/racket-doc/scribblings/reference/stx-serialize.scrbl Normal file
View File

@ -0,0 +1,76 @@
#lang scribble/doc
@(require "mz.rkt"
(for-label racket/fasl
racket/serialize))
@title{Serializing Syntax}
@defproc[(syntax-serialize [stx syntax?]
[#:preserve-property-keys preserve-property-keys (listof symbol)]
[#:provides-namespace provides-namespace (or/c namespace? #f) (current-namespace)]
[#:base-module-path-index base-module-path-index (or/c module-path-index? #f) #f])
any/c]{
Converts @racket[stx] to a serialized form that is suitable for use
with @racket[s-exp->fasl] or @racket[serialize]. Although @racket[stx]
could be serialized with @racket[(compile `(quote-syntax ,stx))] and
then writing the compiled form, @racket[syntax-serialize] provides
more control over serialization:
@itemlist[
@item{The @racket[preserve-property-keys] lists syntax-property keys
to whose values should be preserved in serialization, even if
the property value was not added as preserved with
@racket[syntax-property] (so it would be discarded in compiled
form). The values associated with the properties to preserve
must be serializable in the sense required by
@racket[syntax-property] for a preserved property.}
@item{The @racket[provides-namespace] argument constrains how much
the serialized syntax object can rely on @deftech{bulk
bindings}, which are shared binding tables provided by
exporting modules. If @racket[provides-namespace] is
@racket[#f], then complete binding information is recorded in
the syntax object's serialized form, and no bulk bindings will
be needed from the namespace at deserialization. Otherwise,
bulk bindings will be used only for modules declared in
@racket[provides-namespace] (i.e., the deserialize-time
namespace will have the same module declarations as
@racket[provides-namespace]); note that supplying a namespace
with no module bindings is equivalent to supplying
@racket[#f].}
@item{The @racket[base-module-path-index] argument specifies a
@tech{module path index} to which binding information in
@racket[stx] is relative. For example, if a syntax object
originates from @racket[quote-syntax] in the body of a module,
then @racket[base-module-path-index] could usefully be the
enclosing module's module path index as produced by
@racket[(variable-reference->module-path-index
(#%variable-reference))] within the module. On deserialization,
a different module path index can be supplied to substitute in
place of @racket[base-module-path-index], which shifts any
binding that is relative to the serialize-time module's
identity to be relative to the module identity supplied at
deserialize time. If @racket[base-module-path-index] is
@racket[#f], then no shifting is supported at deserialize time,
and any @racket[base-module-path-index] supplied at that time
is ignored.}
]
A serialized syntax object is otherwise similar to compiled code: it
is version-specific, and deserialization will require a sufficiently
powerful @tech{code inspector}.
@history[#:added "8.0.0.13"]}
@defproc[(syntax-deserialize [v any/c]
[#:base-module-path-index base-module-path-index (or/c module-path-index? #f) #f])
syntax?]{
Converts the result of @racket[syntax-serialize] back to a syntax
object. See @racket[syntax-serialize] for more information.
@history[#:added "8.0.0.13"]}

27
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -2768,6 +2768,33 @@
#rx"key for a preserved property must be an interned symbol"
(exn-message exn))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(for ([provides-namespace (list (current-namespace) #f)])
(let ([s (syntax-serialize #'list #:provides-namespace provides-namespace)])
(test 'list syntax->datum (syntax-deserialize s))
(let ([id (syntax-deserialize s)])
(test (identifier-binding #'list) identifier-binding id)
(test (identifier-binding #'cons) identifier-binding (datum->syntax id 'cons)))))
(let ([s (syntax-serialize (syntax-property #'something 'wicked "this way comes")
#:preserve-property-keys '(wicked))])
(let ([id (syntax-deserialize s)])
(test "this way comes" syntax-property id 'wicked)))
(module has-syntax-to-serialize-with-base-mpi racket/base
(provide id mpi)
(define id #'id)
(define mpi (variable-reference->module-path-index (#%variable-reference))))
(let ([id (dynamic-require ''has-syntax-to-serialize-with-base-mpi 'id)]
[mpi (dynamic-require ''has-syntax-to-serialize-with-base-mpi 'mpi)])
(test (list mpi 'id mpi 'id 0 0 0) identifier-binding id)
(let* ([new-mpi (module-path-index-join 'somewhere-over-the-rainbow #f)]
[id2 (syntax-deserialize (syntax-serialize id #:base-module-path-index mpi)
#:base-module-path-index new-mpi)])
(test (list new-mpi 'id new-mpi 'id 0 0 0) identifier-binding id2)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that paths from the current installation are not
;; preserved in marshaled bytecode

2
racket/collects/racket/private/base.rkt
View File

@ -13,6 +13,7 @@
"submodule.rkt"
"generic-interfaces.rkt"
"kw-syntax-binding.rkt" ; shadows `syntax-binding-set-extend`
"kw-syntax-serialize.rkt" ; shadows `syntax-serialize` and `syntax-deserialize
(for-syntax "stxcase-scheme.rkt"))
(#%provide (all-from-except "pre-base.rkt"
@ -40,6 +41,7 @@
(all-from "submodule.rkt")
(all-from "generic-interfaces.rkt")
(all-from "kw-syntax-binding.rkt")
(all-from "kw-syntax-serialize.rkt")
(for-syntax syntax-rules syntax-id-rules ... _)
(rename -open-input-file open-input-file)
(rename -open-output-file open-output-file)

15
racket/collects/racket/private/kw-syntax-serialize.rkt Normal file
View File

@ -0,0 +1,15 @@
(module kw-syntax-binding "pre-base.rkt"
(require (prefix-in k: '#%kernel))
(provide syntax-serialize
syntax-deserialize)
(define (syntax-serialize stx
#:base-module-path-index [base-mpi #f]
#:preserve-property-keys [preserve-prop-keys '()]
#:provides-namespace [provides-namespace (current-namespace)])
(k:syntax-serialize stx base-mpi preserve-prop-keys provides-namespace))
(define (syntax-deserialize data
#:base-module-path-index [base-mpi #f])
(k:syntax-deserialize data base-mpi)))

1067
racket/src/bc/src/startup.inc
View File

File diff suppressed because it is too large Load Diff

5145
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

4
racket/src/expander/boot/core-primitive.rkt
View File

@ -21,6 +21,7 @@
"../syntax/api.rkt"
"../syntax/api-taint.rkt"
"../syntax/error.rkt"
"../syntax/serialize.rkt"
"../read/api.rkt"
"../common/module-path.rkt"
"../namespace/variable-reference.rkt"
@ -85,6 +86,9 @@
syntax-binding-set-extend
syntax-binding-set->syntax
syntax-serialize
syntax-deserialize
raise-syntax-error
struct:exn:fail:syntax
exn:fail:syntax

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

@ -160,7 +160,7 @@
,(generate-deserialize (vector->immutable-vector
(list->vector
(reverse (syntax-literals-stxes sl))))
mpis)))
#:mpis mpis)))
(set! ,deserialize-syntax-id #f)))))]))
(define (generate-lazy-syntax-literal-lookup pos)
@ -180,7 +180,7 @@
(encode-namespace-scopes ns)
(reverse
(syntax-literals-stxes sl)))
mpis)])
#:mpis mpis)])
(let-values ([(ns-scope-s) (car ns+stxss)])
(list->vector
(map (lambda (stx)

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

@ -28,10 +28,14 @@
props ; map full props to previously calculated
interned-props ; intern filtered props
syntax-context ; used to collapse encoding of syntax literals
sharing-syntaxes) ; record which syntax objects are `datum->syntax` form
sharing-syntaxes ; record which syntax objects are `datum->syntax` form
preserve-prop-keys ; property keys to preserve (that otherwise wouldn't be)
keep-provides?) ; non-#f => predicate for when to keep bulk provides
#:authentic)
(define (make-serialize-state reachable-scopes)
(define (make-serialize-state reachable-scopes
preserve-prop-keys
keep-provides?)
(define state
(serialize-state reachable-scopes
(make-hasheq) ; bindings-intern
@ -44,7 +48,9 @@
(make-hasheq) ; props
(make-hash) ; interned-props
(box null) ; syntax-context
(make-hasheq))) ; sharing-syntaxes
(make-hasheq) ; sharing-syntaxes
preserve-prop-keys
keep-provides?))
;; Seed intern tables for sets and hashes to use the canonical
;; empty version for consistent sharing:
(define empty-seteq (seteq))

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

@ -19,7 +19,7 @@
"built-in-symbol.rkt"
"reserved-symbol.rkt")
;; Serialization is mostly for syntax object and module path indexes.
;; Serialization is mostly for syntax objects and module path indexes.
;;
;; Serialization is implemented by a combination of direct handling
;; for some primitive datatypes, `prop:serialize` handlers attached
@ -73,12 +73,14 @@
add-module-path-index!
add-module-path-index!/pos
generate-module-path-index-deserialize
deserialize-module-path-index-data
mpis-as-vector
generate-module-data-linklet
generate-module-declaration-linklet
generate-deserialize
generate-deserialize ; i.e., `serialize`
deserialize-data
deserialize-instance
deserialize-imports
@ -112,7 +114,8 @@
(hash-set! positions mpi pos)
pos)))]))
(define (generate-module-path-index-deserialize mpis)
(define (generate-module-path-index-deserialize mpis
#:as-data? [as-data? #f])
(define (unique-list v)
(if (pair? v)
(for/list ([i (in-list v)]) i) ; avoid non-deterministic sharing
@ -150,13 +153,18 @@
(vector path)]
[base
(vector path (hash-ref gen-order base))])))
`(deserialize-module-path-indexes
;; Vector of deserialization instructions, where earlier
;; must be constructed first:
',gens
;; Vector of reordering to match reference order:
',(for/vector ([i (in-range (hash-count rev-positions))])
(hash-ref gen-order (hash-ref rev-positions i)))))
(define reorder-vec
(for/vector ([i (in-range (hash-count rev-positions))])
(hash-ref gen-order (hash-ref rev-positions i))))
(cond
[as-data? (vector gens reorder-vec)]
[else
`(deserialize-module-path-indexes
;; Vector of deserialization instructions, where earlier
;; must be constructed first:
',gens
;; Vector of reordering to match reference order:
',reorder-vec)]))
(define (deserialize-module-path-indexes gen-vec order-vec)
(define gen (make-vector (vector-length gen-vec) #f))
@ -175,6 +183,11 @@
(for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)])
(vector*-ref gen p)))
(define (deserialize-module-path-index-data v)
(unless (and (vector? v) (= 2 (vector-length v)))
(error 'syntax-deserialize "ill-formed serialization"))
(deserialize-module-path-indexes (vector-ref v 0) (vector-ref v 1)))
(define (mpis-as-vector mpis)
(define positions (module-path-index-table-positions mpis))
(define vec (make-vector (hash-count positions) #f))
@ -226,8 +239,8 @@
phase-to-link-modules)
;; body
(define-values (self-mpi) ,(add-module-path-index! mpis self))
(define-values (requires) ,(generate-deserialize requires mpis #:syntax-support? #f))
(define-values (provides) ,(generate-deserialize provides mpis #:syntax-support? #f))
(define-values (requires) ,(generate-deserialize requires #:mpis mpis #:syntax-support? #f))
(define-values (provides) ,(generate-deserialize provides #:mpis mpis #:syntax-support? #f))
(define-values (phase-to-link-modules) ,phase-to-link-module-uses-expr)))
;; ----------------------------------------
@ -261,10 +274,23 @@
;; ----------------------------------------
;; Serialization for everything else
(define (generate-deserialize v mpis #:syntax-support? [syntax-support? #t])
(define reachable-scopes (find-reachable-scopes v))
(define (generate-deserialize v
#:mpis mpis
#:as-data? [as-data? #f]
#:syntax-support? [syntax-support? #t]
#:preserve-prop-keys [preserve-prop-keys #hasheq()]
#:keep-provides? [keep-provides? #f])
(define bulk-shifts (and keep-provides? (list (make-hasheq))))
(define state (make-serialize-state reachable-scopes))
(define reachable-scopes (find-reachable-scopes v bulk-shifts))
(define state (make-serialize-state reachable-scopes
preserve-prop-keys
(and keep-provides?
(lambda (b)
(define name (hash-ref (car bulk-shifts) b #f))
(or (not name) ; shouldn't happen
(keep-provides? name))))))
(define mutables (make-hasheq)) ; v -> pos
(define objs (make-hasheq)) ; v -> step
@ -612,29 +638,38 @@
(reap-stream!)))
;; Put it all together:
(define (finish mutable-shell-bindings-expr shared-bindings-expr mutable-fills-expr result-expr)
`(deserialize
,mpi-vector-id
,(if syntax-support? inspector-id #f)
,(if syntax-support? bulk-binding-registry-id #f)
',(hash-count mutables)
,mutable-shell-bindings-expr
',(hash-count shares)
,shared-bindings-expr
,mutable-fills-expr
,result-expr))
(cond
[as-data?
(vector (hash-count mutables)
mutable-shell-bindings
(hash-count shares)
shared-bindings
mutable-fills
result)]
[else
(define (finish mutable-shell-bindings-expr shared-bindings-expr mutable-fills-expr result-expr)
`(deserialize
,mpi-vector-id
,(if syntax-support? inspector-id #f)
,(if syntax-support? bulk-binding-registry-id #f)
',(hash-count mutables)
,mutable-shell-bindings-expr
',(hash-count shares)
,shared-bindings-expr
,mutable-fills-expr
,result-expr))
;; Putting the quoted-data construction into one vector makes
;; it easy to specialize in some back ends to a more compact
;; format.
`(let-values ([(data) ',(vector mutable-shell-bindings
shared-bindings
mutable-fills
result)])
,(finish '(unsafe-vector*-ref data 0)
'(unsafe-vector*-ref data 1)
'(unsafe-vector*-ref data 2)
'(unsafe-vector*-ref data 3))))
;; Putting the quoted-data construction into one vector makes
;; it easy to specialize in some back ends to a more compact
;; format.
`(let-values ([(data) ',(vector mutable-shell-bindings
shared-bindings
mutable-fills
result)])
,(finish '(unsafe-vector*-ref data 0)
'(unsafe-vector*-ref data 1)
'(unsafe-vector*-ref data 2)
'(unsafe-vector*-ref data 3)))]))
(define (sorted-hash-keys ht)
(define ks (hash-keys ht))
@ -688,6 +723,17 @@
(decode result-vec 0 mpis inspector bulk-binding-registry shared))
result)
(define (deserialize-data mpis inspector bulk-binding-registry data)
(unless (and (vector? data) (= 6 (vector-length data)))
(error 'syntax-deserialize "ill-formed serialization"))
(deserialize mpis inspector bulk-binding-registry
(vector-ref data 0)
(vector-ref data 1)
(vector-ref data 2)
(vector-ref data 3)
(vector-ref data 4)
(vector-ref data 5)))
;; Decode the construction of a mutable variable
(define (decode-shell vec pos mpis inspector bulk-binding-registry shared)
(case (vector*-ref vec pos)
@ -825,6 +871,8 @@
(decode* (deserialize-full-local-binding key free=id))]
[(#:bulk-binding)
(decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))]
[(#:bulk-binding+provides)
(decode* (deserialize-bulk-binding+provides provides self prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))]
[(#:provided)
(decode* (deserialize-provided binding protected? syntax?))]
[else
@ -874,13 +922,23 @@
;; ----------------------------------------
;; For pruning unreachable scopes in serialization
(define (find-reachable-scopes v)
(define (find-reachable-scopes v bulk-shifts)
(define seen (make-hasheq))
(define reachable-scopes (seteq))
(define (get-reachable-scopes) reachable-scopes)
(define scope-triggers (make-hasheq))
(let loop ([v v])
;; `bulk-shifts` is used to propagate shifts from a syntax object to
;; binding tables when bulk-binding provides will be preserved, in
;; case scope-specific bindings need to be reified; a `bulk-shifts`
;; list an an `extra-shifts` prefixed by an eq-based table to record
;; resolved module paths; setting it to #f means that bulk-binding
;; provides are not preserved (i.e., they will be shared with the
;; providing module on demand), and no bulk-shifts propagation is
;; needed; for now, we conservatively force all bulk-binding
;; provides to be reified when any will be preserved
(let loop ([v v] [bulk-shifts bulk-shifts])
(cond
[(interned-literal? v) (void)]
[(hash-ref seen v #f) (void)]
@ -890,7 +948,7 @@
[(scope-with-bindings? v)
(set! reachable-scopes (set-add reachable-scopes v))
((reach-scopes-ref v) v loop)
((reach-scopes-ref v) v bulk-shifts loop)
(for ([proc (in-list (hash-ref scope-triggers v null))])
(proc loop))
@ -903,6 +961,7 @@
((scope-with-bindings-ref v)
v
get-reachable-scopes
bulk-shifts
loop
(lambda (sc-unreachable b)
(hash-update! scope-triggers
@ -910,24 +969,24 @@
(lambda (l) (cons b l))
null)))]
[(reach-scopes? v)
((reach-scopes-ref v) v loop)]
((reach-scopes-ref v) v bulk-shifts loop)]
[(pair? v)
(loop (car v))
(loop (cdr v))]
(loop (car v) bulk-shifts)
(loop (cdr v) bulk-shifts)]
[(vector? v)
(for ([e (in-vector v)])
(loop e))]
(loop e bulk-shifts))]
[(box? v)
(loop (unbox v))]
(loop (unbox v) bulk-shifts)]
[(hash? v)
(for ([(k v) (in-hash v)])
(loop k)
(loop v))]
(loop k bulk-shifts)
(loop v bulk-shifts))]
[(prefab-struct-key v)
(for ([e (in-vector (struct->vector v) 1)])
(loop e))]
(loop e bulk-shifts))]
[(srcloc? v)
(loop (srcloc-source v))]
(loop (srcloc-source v) bulk-shifts)]
[else
(void)])]))

14
racket/src/expander/demo.rkt
View File

@ -21,6 +21,10 @@
#:namespace [ns demo-ns]
#:serializable? [serializable? #f])
(define exp-e (expand-expression e #:namespace ns))
(when check-serialize?
(unless (equal? (syntax->datum (syntax-deserialize (syntax-serialize exp-e)))
(syntax->datum exp-e))
(error "serialization problem")))
(define c (compile (if check-reexpand? exp-e e) ns (or serializable?
check-serialize?)))
(define ready-c (if check-serialize?
@ -1452,3 +1456,13 @@
(check-print
(namespace-require ''to-recompile demo-ns)
0)))
;; ----------------------------------------
;; Serialization with otherwise non-preserved properties
(let ([s (syntax-property (datum->syntax #f 'hello)
'keep-me
17)])
(check-value (syntax-property s 'keep-me) 17)
(check-value (syntax-property (syntax-deserialize (syntax-serialize s)) 'keep-me) #f)
(check-value (syntax-property (syntax-deserialize (syntax-serialize s #f '(keep-me))) 'keep-me) 17))

4
racket/src/expander/main.rkt
View File

@ -36,6 +36,7 @@
(only-in "syntax/cache.rkt" cache-place-init!)
(only-in "syntax/syntax.rkt" syntax-place-init!)
(only-in "syntax/scope.rkt" scope-place-init!)
"syntax/serialize.rkt"
(only-in "eval/module-cache.rkt" module-cache-place-init!)
(only-in "common/performance.rkt" performance-place-init!)
(only-in "eval/shadow-directory.rkt" shadow-directory-place-init!))
@ -135,6 +136,9 @@
syntax-shift-phase-level
bound-identifier=?
syntax-serialize
syntax-deserialize
compiled-expression-recompile)
;; ----------------------------------------

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

@ -4,7 +4,8 @@
"../compile/serialize-property.rkt"
"../compile/serialize-state.rkt"
"syntax.rkt"
"module-binding.rkt")
"module-binding.rkt"
"full-binding.rkt")
;; A binding table within a scope maps symbol plus scope set
;; combinations (where the scope binding the binding table is always
@ -65,7 +66,7 @@
(ser-push! (bulk-binding-at-scopes bba))
(ser-push! (bulk-binding-at-bulk bba)))
#:property prop:reach-scopes
(lambda (sms reach)
(lambda (sms extra-scopes reach)
;; bulk bindings are pruned depending on whether all scopes
;; in `scopes` are reachable, and we shouldn't get here
;; when looking for scopes
@ -82,7 +83,8 @@
;; Value of `prop:bulk-binding`
(struct bulk-binding-class (get-symbols ; bulk-binding list-of-shift -> sym -> binding-info
create)) ; bul-binding -> binding-info sym -> binding
create ; bulk-binding -> binding-info sym -> binding
modname)) ; bulk-binding list-of-shift -> resolved-module-path
(define (bulk-binding-symbols b s extra-shifts)
;; Providing the identifier `s` supports its shifts
((bulk-binding-class-get-symbols (bulk-binding-ref b))
@ -91,6 +93,14 @@
(define (bulk-binding-create b)
(bulk-binding-class-create (bulk-binding-ref b)))
(define (force-bulk-bindings b bulk-shifts)
(define modname-ht (car bulk-shifts))
(define extra-shifts (cdr bulk-shifts))
;; record resolved module path
(hash-set! modname-ht b ((bulk-binding-class-modname (bulk-binding-ref b)) b extra-shifts))
;; getting symbols has the effect of forcing:
(bulk-binding-symbols b #f extra-shifts))
;; ----------------------------------------
(define (binding-table-empty? bt)
@ -341,7 +351,7 @@
(hash-set! (serialize-state-bulk-bindings-intern state) bt new-bt)
new-bt)))
(define (binding-table-register-reachable bt get-reachable-scopes reach register-trigger)
(define (binding-table-register-reachable bt get-reachable-scopes bulk-shifts 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)
@ -350,17 +360,19 @@
[(scopes binding) (in-immutable-hash bindings-for-sym)])
(define v (and (binding-reach-scopes? binding)
((binding-reach-scopes-ref binding) binding)))
(scopes-register-reachable scopes v get-reachable-scopes reach register-trigger))
(scopes-register-reachable scopes v get-reachable-scopes bulk-shifts 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))))
(when bulk-shifts ; indicates that bulk bindings will be retained, and maybe they need to be reified
(force-bulk-bindings (bulk-binding-at-bulk bba) bulk-shifts))
(scopes-register-reachable (bulk-binding-at-scopes bba) #f get-reachable-scopes bulk-shifts reach register-trigger))))
(define (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger)
(define (scopes-register-reachable scopes v get-reachable-scopes bulk-shifts reach register-trigger)
(define reachable-scopes (get-reachable-scopes))
(cond
[(subset? scopes reachable-scopes)
(reach v)]
(reach v bulk-shifts)]
[else
;; There may be implicitly reachable scopes (i.e., multi-scope
;; representatives that should only be reachable if they
@ -374,10 +386,10 @@
(when (zero? (hash-count pending-scopes))
;; All scopes became reachable, so make the value reachable,
;; and declare implcitily reachables as explicitly reachable
(reach v)
(reach v bulk-shifts)
(for ([sc (in-set scopes)])
(when (implicitly-reachable? sc)
(reach sc)))))
(reach sc bulk-shifts)))))
(for ([sc (in-set pending-scopes)])
(register-trigger sc (lambda (reach)
(set! pending-scopes (hash-remove pending-scopes sc))

36
racket/src/expander/syntax/bulk-binding.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../compile/serialize-property.rkt"
"../compile/serialize-state.rkt"
"binding-table.rkt" ; defines `prop:bulk-binding`
"binding.rkt"
"../common/module-path.rkt"
@ -14,7 +15,8 @@
bulk-binding
bulk-provides-add-prefix-remove-exceptions
deserialize-bulk-binding)
deserialize-bulk-binding
deserialize-bulk-binding+provides)
;; When a require is something like `(require racket/base)`, then
;; we'd like to import the many bindings from `racket/base` in one
@ -82,13 +84,11 @@
#:authentic
#:property prop:bulk-binding
(bulk-binding-class
;; get-symbols
(lambda (b mpi-shifts)
(or (bulk-binding-provides b)
;; Here's where we find provided bindings for unmarshaled syntax
(let ([mod-name (module-path-index-resolve
(apply-syntax-shifts
(bulk-binding-mpi b)
mpi-shifts))])
(let ([mod-name (bulk-binding-module-name b mpi-shifts)])
(unless (bulk-binding-bulk-binding-registry b)
(error "namespace mismatch: no bulk-binding registry available:"
mod-name))
@ -112,6 +112,7 @@
;; Record the adjusted `provides` table for quick future access:
(set-bulk-binding-provides! b adjusted-provides)
adjusted-provides)))
;; create
(lambda (b binding sym)
;; Convert the provided binding to a required binding on
;; demand during binding resolution
@ -124,11 +125,21 @@
#:self (bulk-binding-self b)
#:mpi (bulk-binding-mpi b)
#:provide-phase-level (bulk-binding-provide-phase-level b)
#:phase-shift (bulk-binding-phase-shift b))))
#:phase-shift (bulk-binding-phase-shift b)))
;; modname
(lambda (b mpi-shifts)
(bulk-binding-module-name b mpi-shifts)))
#:property prop:serialize
;; Serialization drops the `provides` table and the providing module's `self`
(lambda (b ser-push! reachable-scopes)
(ser-push! 'tag '#:bulk-binding)
(lambda (b ser-push! state)
(cond
[(and (serialize-state-keep-provides? state)
((serialize-state-keep-provides? state) b))
(ser-push! 'tag '#:bulk-binding+provides)
(ser-push! (bulk-binding-provides b))
(ser-push! (bulk-binding-self b))]
[else
(ser-push! 'tag '#:bulk-binding)])
(ser-push! (bulk-binding-prefix b))
(ser-push! (bulk-binding-excepts b))
(ser-push! (bulk-binding-mpi b))
@ -139,6 +150,9 @@
(define (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry)
(bulk-binding #f prefix excepts #f mpi provide-phase-level phase-shift bulk-binding-registry))
(define (deserialize-bulk-binding+provides provides self prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry)
(bulk-binding provides prefix excepts self mpi provide-phase-level phase-shift bulk-binding-registry))
(define (bulk-provides-add-prefix-remove-exceptions provides prefix excepts)
(for/hash ([(sym val) (in-hash provides)]
#:unless (hash-ref excepts sym #f)
@ -149,6 +163,12 @@
sym)
val)))
(define (bulk-binding-module-name b mpi-shifts)
(module-path-index-resolve
(apply-syntax-shifts
(bulk-binding-mpi b)
mpi-shifts)))
;; ----------------------------------------
;; A blk binding registry has just the provde part of a module, for

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

@ -108,13 +108,14 @@
(ser-push! 'tag '#:scope-fill!)
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))]))
#:property prop:reach-scopes
(lambda (s reach)
(lambda (s extra-shifts reach)
;; the `bindings` field is handled via `prop:scope-with-bindings`
(void))
#:property prop:scope-with-bindings
(lambda (s get-reachable-scopes reach register-trigger)
(lambda (s get-reachable-scopes extra-shifts reach register-trigger)
(binding-table-register-reachable (scope-binding-table s)
get-reachable-scopes
extra-shifts
reach
register-trigger)))
@ -181,11 +182,11 @@
(hash-set! multi-scope-tables (multi-scope-scopes ms) ht)
ht))))
#:property prop:reach-scopes
(lambda (s reach)
(lambda (s extra-shifts 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)
(lambda (ms get-reachable-scopes bulk-shifts 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
@ -201,7 +202,7 @@
;; them differently, hence `prop:implicitly-reachable`.
(for ([sc (in-hash-values (unbox (multi-scope-scopes ms)))])
(unless (binding-table-empty? (scope-binding-table sc))
(reach sc)))))
(reach sc bulk-shifts)))))
(define (deserialize-multi-scope name scopes)
(multi-scope (new-deserialize-scope-id!) name (box scopes) (box (hasheqv)) (box (hash))))
@ -231,9 +232,9 @@
(ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))
(ser-push! (representative-scope-owner s)))
#:property prop:reach-scopes
(lambda (s reach)
(lambda (s bulk-shifts reach)
;; the inherited `bindings` field is handled via `prop:scope-with-bindings`
(reach (representative-scope-owner s)))
(reach (representative-scope-owner s) bulk-shifts))
;; Used by `binding-table-register-reachable`:
#:property prop:implicitly-reachable #t)
@ -262,8 +263,8 @@
(ser-push! (shifted-multi-scope-phase sms))
(ser-push! (shifted-multi-scope-multi-scope sms)))
#:property prop:reach-scopes
(lambda (sms reach)
(reach (shifted-multi-scope-multi-scope sms))))
(lambda (sms bulk-shifts reach)
(reach (shifted-multi-scope-multi-scope sms) bulk-shifts)))
(define (deserialize-shifted-multi-scope phase multi-scope)
(intern-shifted-multi-scope phase multi-scope))

68
racket/src/expander/syntax/serialize.rkt Normal file
View File

@ -0,0 +1,68 @@
#lang racket/base
(require "../common/contract.rkt"
"../syntax/syntax.rkt"
"../compile/serialize.rkt"
"../common/module-path.rkt"
"../namespace/namespace.rkt"
"../eval/protect.rkt")
(provide syntax-serialize
syntax-deserialize)
(struct serialized-syntax (version mpis base-mpi-pos data need-registry?)
#:prefab)
(define/who (syntax-serialize stx
[base-mpi #f]
[preserve-prop-keys '()]
[provides-namespace (current-namespace)])
(check who syntax? stx)
(check who module-path-index? #:or-false base-mpi)
(check who (lambda (l) (and (list? l) (andmap symbol? l)))
#:contract "(listof symbol?)"
preserve-prop-keys)
(check who namespace? #:or-false provides-namespace)
(define mpis (make-module-path-index-table))
(define base-mpi-pos (and base-mpi
(add-module-path-index!/pos mpis base-mpi)))
(define data (generate-deserialize stx
#:mpis mpis
#:as-data? #t
#:preserve-prop-keys (for/hasheq ([k (in-list preserve-prop-keys)])
(values k #t))
#:keep-provides?
(if provides-namespace
(lambda (modname)
(not (namespace->module provides-namespace modname)))
(lambda (modname) #t))))
(serialized-syntax (version)
(generate-module-path-index-deserialize mpis #:as-data? #t)
base-mpi-pos
data
(and provides-namespace #t)))
(define/who (syntax-deserialize data [base-mpi #f])
(check who module-path-index? #:or-false base-mpi)
(unless (serialized-syntax? data)
(raise-arguments-error who "invalid serialized form" "value" data))
(unless (equal? (version) (serialized-syntax-version data))
(raise-arguments-error who
"version mismatch"
"expected" (version)
"found" (serialized-syntax-version data)))
;; deserialization is unsafe, so only allow it with the original code inspector:
(unless (eq? (current-code-inspector) initial-code-inspector)
(error who "deserialization disallowed by code inspector"))
(define orig-mpis (deserialize-module-path-index-data (serialized-syntax-mpis data)))
(define orig-base-mpi (and base-mpi
(let ([pos (serialized-syntax-base-mpi-pos data)])
(and pos
(vector-ref orig-mpis pos)))))
(define shifted-mpis
(if orig-base-mpi
(for/vector #:length (vector-length orig-mpis) ([mpi (in-vector orig-mpis)])
(module-path-index-shift mpi orig-base-mpi base-mpi))
orig-mpis))
(define bulk-binding-registry (and (serialized-syntax-need-registry? data)
(namespace-bulk-binding-registry (current-namespace))))
(deserialize-data shifted-mpis #f bulk-binding-registry (serialized-syntax-data data)))

19
racket/src/expander/syntax/syntax.rkt
View File

@ -84,8 +84,10 @@
(intern-properties
(syntax-props s)
(lambda ()
(define preserve-keys (serialize-state-preserve-prop-keys state))
(for/hasheq ([(k v) (in-hash (syntax-props s))]
#:when (preserved-property-value? v))
#:when (or (preserved-property-value? v)
(hash-ref preserve-keys k #f)))
(values k (check-value-to-preserve (plain-property-value v) syntax?))))
state))
(define tamper
@ -151,7 +153,7 @@
(equal? (syntax-srcloc s) (syntax-state-srcloc stx-state)))
(set-syntax-state-all-sharing?! stx-state #f)))]))
#:property prop:reach-scopes
(lambda (s reach)
(lambda (s bulk-shifts reach)
(define content* (syntax-content* s))
(reach
(if (modified-content? content*)
@ -159,13 +161,16 @@
(if (propagation? prop)
((propagation-ref prop) s)
(modified-content-content content*)))
content*))
(reach (syntax-scopes s))
(reach (syntax-shifted-multi-scopes s))
content*)
bulk-shifts)
(define shifts (and bulk-shifts
(append bulk-shifts (syntax-mpi-shifts s))))
(reach (syntax-scopes s) shifts)
(reach (syntax-shifted-multi-scopes s) shifts)
(for ([(k v) (in-immutable-hash (syntax-props s))]
#:when (preserved-property-value? v))
(reach (plain-property-value v)))
(reach (syntax-srcloc s))))
(reach (plain-property-value v) bulk-shifts))
(reach (syntax-srcloc s) bulk-shifts)))
;; Property to abstract over handling of propagation for
;; serialization; property value takes a syntax object and

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 12
#define MZSCHEME_VERSION_W 13
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x