Add interned scopes and make-interned-syntax-introducer

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.90.0.27")
+(define version "6.90.0.28")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -1036,6 +1036,27 @@ and different result procedures use distinct scopes.
                                added the optional operation argument
                                in the result procedure.}]}
 
+@defproc[(make-interned-syntax-introducer [key symbol?])
+         ((syntax?) ((or/c 'flip 'add 'remove)) . ->* . syntax?)]{
+
+Like @racket[make-syntax-introducer], but the encapsulated @tech{scope} is interned. Multiple calls to
+@racket[make-interned-syntax-introducer] with the same @racket[key] will produce procedures that flip,
+add, or remove the same scope, even across @tech{phases} and module @tech{instantiations}.
+Furthermore, the scope remains consistent even when embedded in @tech{compiled} code, so a scope
+created with @racket[make-interned-syntax-introducer] will retain its identity in syntax objects
+loaded from compiled code. (In this sense, the relationship between @racket[make-syntax-introducer]
+and @racket[make-interned-syntax-introducer] is analogous to the relationship between
+@racket[gensym] and @racket[quote].)
+
+This function is intended for the implementation of separate binding environments within a single
+phase, for which the scope associated with each environment must be the same across modules.
+
+Unlike @racket[make-syntax-introducer], the scope added by a procedure created with
+@racket[make-interned-syntax-introducer] is always treated like a use-site scope, not a
+macro-introduction scope, so it does not affect originalness as reported by @racket[syntax-original?].
+
+@history[#:added "6.90.0.28"]}
+
 @defproc[(make-syntax-delta-introducer [ext-stx identifier?]
                                        [base-stx (or/c syntax? #f)]
                                        [phase-level (or/c #f exact-integer?)

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

@@ -2487,6 +2487,54 @@ case of module-leve bindings; it doesn't cover local bindings.
     (local-require (for-template racket/base))
     (void)))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; `make-interned-syntax-introducer`
+
+(let ([ns-code '(module ns racket/base
+                  (require (for-syntax racket/base))
+                  (provide (for-syntax ns-introduce) begin-for-ns)
+                  (begin-for-syntax
+                    (define ns-introducer (make-interned-syntax-introducer 'ns))
+                    (define (ns-introduce stx) (ns-introducer stx 'add)))
+                  (define-syntax (begin-for-ns stx)
+                    (syntax-case stx ()
+                      [(_ form ...) (ns-introduce #'(begin form ...))])))]
+      [m-code '(module m racket/base
+                 (require (for-syntax racket/base) 'ns)
+                 (provide get-ns-value)
+                 (define-syntax (get-ns-value stx)
+                   (syntax-case stx ()
+                     [(_ x)
+                      (identifier? #'x)
+                      #`(quote #,(syntax-local-value (ns-introduce #'x)))])))]
+      [p-code '(module p racket/base
+                 (require (for-syntax racket/base) 'ns 'm)
+                 (provide foo)
+                 (begin-for-ns
+                   (define-syntax Foo 'ns-val))
+                 (define-syntax-rule (foo)
+                   (get-ns-value Foo)))]
+      [u-code '(module u racket/base
+                 (require 'p)
+                 (provide v)
+                 (define v (foo)))])
+  (parameterize ([current-namespace (make-base-namespace)])
+    (eval ns-code)
+    (eval m-code)
+    (eval p-code)
+    (eval u-code)
+    (test 'ns-val dynamic-require ''u 'v))
+  (parameterize ([current-namespace (make-base-namespace)])
+    (let ([compile/eval (λ (code) (let ([s (open-output-bytes)])
+                                    (write (compile code) s)
+                                    (eval (parameterize ([read-accept-compiled #t])
+                                            (read (open-input-bytes (get-output-bytes s)))))))])
+      (compile/eval ns-code)
+      (compile/eval m-code)
+      (compile/eval p-code)
+      (compile/eval u-code)
+      (test 'ns-val dynamic-require ''u 'v))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

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

@@ -118,6 +118,7 @@
                       syntax-local-name
 
                       make-syntax-introducer
+                      make-interned-syntax-introducer
                       make-syntax-delta-introducer
                       syntax-local-make-delta-introducer
                       

racket/src/expander/compile/serialize.rkt

@@ -18,7 +18,7 @@
          "built-in-symbol.rkt"
          "reserved-symbol.rkt")
 
-;; Serializaiton is mostly for syntax object and module path indexes.
+;; Serialization is mostly for syntax object and module path indexes.
 ;;
 ;; Serialization is implemented by a combination of direct handling
 ;; for some primitive datatypes, `prop:serialize` handlers attached
@@ -738,6 +738,8 @@
      (decode* (deserialize-scope))]
     [(#:scope+kind)
      (decode* (deserialize-scope kind))]
+    [(#:interned-scope)
+     (decode* (make-interned-scope id))]
     [(#:multi-scope)
      (decode* (deserialize-multi-scope name scopes))]
     [(#:shifted-multi-scope)

racket/src/expander/expand/syntax-local.rkt

@@ -36,6 +36,7 @@
          syntax-local-name
 
          make-syntax-introducer
+         make-interned-syntax-introducer
          make-syntax-delta-introducer
          syntax-local-make-delta-introducer
          
@@ -114,7 +115,13 @@
 ;; ----------------------------------------
 
 (define (make-syntax-introducer [as-use-site? #f])
-  (define sc (new-scope (if as-use-site? 'use-site 'macro)))
+  (do-make-syntax-introducer (new-scope (if as-use-site? 'use-site 'macro))))
+
+(define/who (make-interned-syntax-introducer sym-key)
+  (check who symbol? sym-key)
+  (do-make-syntax-introducer (make-interned-scope sym-key)))
+
+(define (do-make-syntax-introducer sc)
   (lambda (s [mode 'flip])
     (check 'syntax-introducer syntax? s)
     (case mode

racket/src/expander/syntax/debug.rkt

@@ -60,11 +60,17 @@
 (define (scope-set->context scs)
   (sort
    (for/list ([sc (in-set scs)])
-     (if (representative-scope? sc)
+     (cond
-         (vector (scope-id sc)
+       [(interned-scope? sc)
-                 (scope-kind sc)
+        (vector (scope-id sc)
-                 (multi-scope-name (representative-scope-owner sc)))
+                (scope-kind sc)
-         (vector (scope-id sc)
+                (interned-scope-key sc))]
-                 (scope-kind sc))))
+       [(representative-scope? sc)
+        (vector (scope-id sc)
+                (scope-kind sc)
+                (multi-scope-name (representative-scope-owner sc)))]
+       [else
+        (vector (scope-id sc)
+                (scope-kind sc))]))
    <
    #:key (lambda (v) (vector-ref v 0))))

racket/src/expander/syntax/scope.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "../common/set.rkt"
+(require ffi/unsafe/atomic
+         "../common/set.rkt"
          "../compile/serialize-property.rkt"
          "../compile/serialize-state.rkt"
          "../common/memo.rkt"
@@ -14,6 +15,7 @@
          "cache.rkt")
 
 (provide new-scope
+         make-interned-scope
          new-multi-scope
          add-scope
          add-scopes
@@ -61,6 +63,7 @@
 
 (module+ for-debug
   (provide (struct-out scope)
+           (struct-out interned-scope)
            (struct-out multi-scope)
            (struct-out representative-scope)
            scope-set-at-fallback))
@@ -121,6 +124,28 @@
 (define (deserialize-scope-fill! s bt)
   (set-scope-binding-table! s bt))
 
+;; An "interned scope" is a scope identified by an interned symbol that is
+;; consistent across both module instantiations and bytecode unmarshalling.
+;; Creating an interned scope with the same symbol will always produce the
+;; same scope.
+(struct interned-scope scope (key)  ; symbolic key used for interning
+  #:authentic
+  #:property prop:custom-write
+  (lambda (sc port mode)
+    (write-string "#<scope:" port)
+    (display (scope-id sc) port)
+    (write-string ":" port)
+    (display (scope-kind sc) port)
+    (write-string " " port)
+    (display (interned-scope-key sc) port)
+    (write-string ">" port))
+  #:property prop:serialize
+  (lambda (s ser-push! state)
+    (unless (set-member? (serialize-state-reachable-scopes state) s)
+      (error "internal error: found supposedly unreachable scope"))
+    (ser-push! 'tag '#:interned-scope)
+    (ser-push! (interned-scope-key s))))
+
 ;; A "multi-scope" represents a group of scopes, each of which exists
 ;; only at a specific phase, and each in a distinct phase. This
 ;; infinite group of scopes is realized on demand. A multi-scope is
@@ -290,6 +315,24 @@
 (define (new-scope kind)
   (scope (new-scope-id!) kind empty-binding-table))
 
+;; The intern table used for interned scopes. Access to the table must be
+;; atomic so that the table is not left locked if the expansion thread is
+;; killed.
+(define interned-scopes-table (make-weak-hasheq))
+
+(define (make-interned-scope sym)
+  (define (make)
+    ;; since interned scopes are reused by unmarshalled code, and because they’re generally unlikely
+    ;; to be a good target for bindings, always create them with a negative id
+    (make-ephemeron sym (interned-scope (- (new-scope-id!)) 'interned empty-binding-table sym)))
+  (call-as-atomic
+   (lambda ()
+     (or (ephemeron-value
+          (hash-ref! interned-scopes-table sym make))
+         (let ([new (make)])
+           (hash-set! interned-scopes-table sym new)
+           (ephemeron-value new))))))
+
 (define (new-multi-scope [name #f])
   (intern-shifted-multi-scope 0 (multi-scope (new-scope-id!) name (make-hasheqv) (box (hasheqv)) (box (hash)))))
 

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.90.0.27"
+#define MZSCHEME_VERSION "6.90.0.28"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 90
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 27
+#define MZSCHEME_VERSION_W 28
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)