add syntax-serialize and syntax-deserialize

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

pkgs/base/info.rkt

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

pkgs/racket-doc/scribblings/reference/macros.scrbl

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

pkgs/racket-doc/scribblings/reference/stx-serialize.scrbl

@@ -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"]}

pkgs/racket-test-core/tests/racket/stx.rktl

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

racket/collects/racket/private/base.rkt

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

racket/collects/racket/private/kw-syntax-serialize.rkt

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

racket/src/expander/boot/core-primitive.rkt

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

racket/src/expander/compile/header.rkt

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

racket/src/expander/compile/serialize-state.rkt

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

racket/src/expander/compile/serialize.rkt

@@ -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
+  (define reorder-vec
-    ;; Vector of deserialization instructions, where earlier
+    (for/vector ([i (in-range (hash-count rev-positions))])
-    ;; must be constructed first:
+      (hash-ref gen-order (hash-ref rev-positions i))))
-    ',gens
+  (cond
-    ;; Vector of reordering to match reference order:
+    [as-data? (vector gens reorder-vec)]
-    ',(for/vector ([i (in-range (hash-count rev-positions))])
+    [else
-        (hash-ref gen-order (hash-ref rev-positions i)))))
+     `(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 (requires) ,(generate-deserialize requires #:mpis mpis #:syntax-support? #f))
-    (define-values (provides) ,(generate-deserialize provides 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,11 +274,24 @@
 ;; ----------------------------------------
 ;; Serialization for everything else
 
-(define (generate-deserialize v mpis #:syntax-support? [syntax-support? #t])
+(define (generate-deserialize v
-  (define reachable-scopes (find-reachable-scopes v))
+                              #:mpis mpis
-  
+                              #:as-data? [as-data? #f]
-  (define state (make-serialize-state reachable-scopes))
+                              #: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 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
   (define shares (make-hasheq))   ; v -> #t
@@ -612,29 +638,38 @@
       (reap-stream!)))
   
   ;; Put it all together:
-  (define (finish mutable-shell-bindings-expr shared-bindings-expr  mutable-fills-expr result-expr)
+  (cond
-    `(deserialize
+    [as-data?
-      ,mpi-vector-id
+     (vector (hash-count mutables)
-      ,(if syntax-support? inspector-id #f)
+             mutable-shell-bindings
-      ,(if syntax-support? bulk-binding-registry-id #f)
+             (hash-count shares)
-      ',(hash-count mutables)
+             shared-bindings
-      ,mutable-shell-bindings-expr
+             mutable-fills
-      ',(hash-count shares)
+             result)]
-      ,shared-bindings-expr
+    [else
-      ,mutable-fills-expr
+     (define (finish mutable-shell-bindings-expr shared-bindings-expr  mutable-fills-expr result-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
+     ;; Putting the quoted-data construction into one vector makes
-  ;; it easy to specialize in some back ends to a more compact
+     ;; it easy to specialize in some back ends to a more compact
-  ;; format.
+     ;; format.
-  `(let-values ([(data) ',(vector mutable-shell-bindings
+     `(let-values ([(data) ',(vector mutable-shell-bindings
-                                  shared-bindings
+                                     shared-bindings
-                                  mutable-fills
+                                     mutable-fills
-                                  result)])
+                                     result)])
-     ,(finish '(unsafe-vector*-ref data 0)
+        ,(finish '(unsafe-vector*-ref data 0)
-              '(unsafe-vector*-ref data 1)
+                 '(unsafe-vector*-ref data 1)
-              '(unsafe-vector*-ref data 2)
+                 '(unsafe-vector*-ref data 2)
-              '(unsafe-vector*-ref data 3))))
+                 '(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)]
@@ -889,8 +947,8 @@
       (cond
        [(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 (car v) bulk-shifts)
-        (loop (cdr v))]
+        (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 k bulk-shifts)
-          (loop v))]
+          (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)])]))
   

racket/src/expander/demo.rkt

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

racket/src/expander/main.rkt

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

racket/src/expander/syntax/binding-table.rkt

@@ -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,15 +83,24 @@
 
 ;; 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))
-   b 
+   b
    (append extra-shifts (if s (syntax-mpi-shifts s) null))))
 (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))

racket/src/expander/syntax/bulk-binding.rkt

@@ -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
+         (let ([mod-name (bulk-binding-module-name b mpi-shifts)])
-                          (apply-syntax-shifts
-                           (bulk-binding-mpi 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)
+  (lambda (b ser-push! state)
-    (ser-push! 'tag '#:bulk-binding)
+    (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

racket/src/expander/syntax/scope.rkt

@@ -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)
+  (lambda (sms bulk-shifts reach)
-    (reach (shifted-multi-scope-multi-scope sms))))
+    (reach (shifted-multi-scope-multi-scope sms) bulk-shifts)))
 
 (define (deserialize-shifted-multi-scope phase multi-scope)
   (intern-shifted-multi-scope phase multi-scope))

racket/src/expander/syntax/serialize.rkt

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

racket/src/expander/syntax/syntax.rkt

@@ -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*))
+         content*)
-    (reach (syntax-scopes s))
+     bulk-shifts)
-    (reach (syntax-shifted-multi-scopes s))
+    (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 (plain-property-value v) bulk-shifts))
-    (reach (syntax-srcloc s))))
+    (reach (syntax-srcloc s) bulk-shifts)))
 
 ;; Property to abstract over handling of propagation for
 ;; serialization; property value takes a syntax object and

racket/src/version/racket_version.h

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