expander: avoid parameters for dynamic-extent indicators

Using a parameter for the current expansion context means that if a
macro spawns a thread, the thread thinks that it's in an expansion
context. Switching to a raw continuation mark avoids that problem.

Along the way, bring Racket and RacketCS more in line by making both
have an internal notion of "root" prompt tag that can be used to get
all continuation marks independent of any prompts. That's not structly
necessary, since a continuation mark could be combined with a distinct
tag to make the mark always accessible, but it's simpler and more
lightweight to use a root prompt tag.

pkgs/base/info.rkt

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

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

@@ -2293,6 +2293,21 @@
                          (define-syntax (f a)
                            (complain-about-this-one (not-about-this-one)))))
 
+;; ----------------------------------------
+;; Make sure "currently expanding" is not propagated to threads
+
+(let ()
+  (define-syntax (m stx)
+    (syntax-case stx ()
+      [(_ e)
+       (let ([ok? #t])
+         (sync (thread (lambda ()
+                         (local-expand #'e 'expression null)
+                         (set! ok? #f))))
+         (if ok? #''ok #''oops))]))
+  
+  (test 'ok values (m 1)))
+  
 ;; ----------------------------------------
 
 (report-errs)

racket/collects/racket/private/stxparam.rkt

@@ -64,13 +64,14 @@
         (let-values ([(expr opaque-expr)
                       (syntax-case stx ()
                         [(_ ([local-key id] ...) body ...)
-                         (parameterize ([current-parameter-environment
+                         (with-continuation-mark
-                                          (extend-parameter-environment
+                          current-parameter-environment
-                                            (current-parameter-environment)
+                          (extend-parameter-environment
-                                            #'([local-key id] ...))])
+                           (current-parameter-environment)
-                           (syntax-local-expand-expression
+                           #'([local-key id] ...))
-                            #'(let-values () body ...)
+                          (syntax-local-expand-expression
-                            #t))])])
+                           #'(let-values () body ...)
+                           #t))])])
           opaque-expr)
         (with-syntax ([stx stx])
           #'(#%expression stx)))))

racket/collects/racket/private/stxparamkey.rkt

@@ -1,11 +1,16 @@
 
 (module stxparamkey '#%kernel
   (#%require "small-scheme.rkt" "define.rkt" 
-             "stxcase.rkt" "stxloc.rkt" "with-stx.rkt")
+             "stxcase.rkt" "stxloc.rkt" "with-stx.rkt"
+             (only '#%unsafe unsafe-root-continuation-prompt-tag))
   
   ;; Consulted before the expander's table, for use by compile-time
   ;; code wrapped by a run-time-phased `syntax-parameterize`:
-  (define current-parameter-environment (make-parameter #hasheq()))
+  (define (current-parameter-environment)
+    ;; Implemented with continuation marks, not parameters, so that the
+    ;; "state" is not inherited by new threads
+    (continuation-mark-set-first #f current-parameter-environment #hasheq()
+                                 (unsafe-root-continuation-prompt-tag)))
 
   ;; Wrap the value for a syntax parameter in a `parameter-value` struct,
   ;; so that we can distinguish it from rename transformers that arrive

racket/collects/racket/splicing.rkt

@@ -306,12 +306,13 @@
   (syntax-case stx ()
     [(_ binds orig-ids body)
      (let ([ctx (syntax-local-make-definition-context #f #f)])
-       (let ([body (parameterize ([current-parameter-environment
+       (let ([body (with-continuation-mark
-                                   (extend-parameter-environment (current-parameter-environment) #'binds)])
+                    current-parameter-environment
-                     (local-expand #'(force-expand body)
+                    (extend-parameter-environment (current-parameter-environment) #'binds)
-                                   (syntax-local-context)
+                    (local-expand #'(force-expand body)
-                                   null ;; `force-expand' actually determines stopping places
+                                  (syntax-local-context)
-                                   ctx))])
+                                  null ;; `force-expand' actually determines stopping places
+                                  ctx))])
          (let ([body
                 ;; Extract expanded body out of `body':
                 (syntax-case body (quote)
@@ -359,10 +360,11 @@
      (unless (eq? (syntax-local-context) 'module-begin)
        (raise-syntax-error #f "only allowed in module-begin context" stx))
      (with-syntax ([new-binds (update-parameter-keys #'orig-ids #'binds)])
-       (parameterize ([current-parameter-environment
+       (with-continuation-mark
-                       (extend-parameter-environment (current-parameter-environment)
+        current-parameter-environment
-                                                     #'new-binds)])
+        (extend-parameter-environment (current-parameter-environment)
-         (let* ([forms (syntax->list #'(body-form ...))]
+                                      #'new-binds)
+        (let* ([forms (syntax->list #'(body-form ...))]
                 ;; emulate how the macroexpander expands module bodies and introduces #%module-begin
                 [body (if (= (length forms) 1)
                           (let ([body (local-expand (car forms) 'module-begin #f)])
@@ -407,9 +409,10 @@
      [(_ e binds)
       (let ([as-expression
              (lambda ()
-               #'(parameterize ([current-parameter-environment
+               #'(with-continuation-mark
-                                 (extend-parameter-environment (current-parameter-environment) (quote-syntax binds))])
+                  current-parameter-environment
-                   e))])
+                  (extend-parameter-environment (current-parameter-environment) (quote-syntax binds))
+                  e))])
         (if (eq? (syntax-local-context) 'expression)
             (as-expression)
             (let ([e (local-expand #'e

racket/collects/racket/unsafe/ops.rkt

@@ -37,6 +37,7 @@
                      unsafe-set-on-atomic-timeout!
                      unsafe-abort-current-continuation/no-wind
                      unsafe-call-with-composable-continuation/no-wind
+                     unsafe-root-continuation-prompt-tag
                      unsafe-os-thread-enabled?
                      unsafe-call-in-os-thread
                      unsafe-make-os-semaphore

racket/src/cs/primitive/kernel.ss

@@ -267,7 +267,7 @@
   [date? (known-procedure/succeeds 2)]
   [datum->syntax (known-procedure 60)]
   [datum-intern-literal (known-procedure 2)]
-  [default-continuation-prompt-tag (known-procedure 1)]
+  [default-continuation-prompt-tag (known-procedure/succeeds 1)]
   [delete-directory (known-procedure 2)]
   [delete-file (known-procedure 2)]
   [denominator (known-procedure 2)]

racket/src/cs/primitive/unsafe.ss

@@ -125,6 +125,7 @@
   [unsafe-port->socket (known-procedure 2)]
   [unsafe-register-process-global (known-procedure 4)]
   [unsafe-remove-collect-callbacks (known-procedure 2)]
+  [unsafe-root-continuation-prompt-tag (known-procedure/succeeds 1)]
   [unsafe-s16vector-ref (known-procedure 4)]
   [unsafe-s16vector-set! (known-procedure 8)]
   [unsafe-set-box! (known-procedure 4)]

racket/src/cs/rumble.sls

@@ -15,7 +15,7 @@
           make-continuation-prompt-tag
           continuation-prompt-tag?
           default-continuation-prompt-tag
-          root-continuation-prompt-tag
+          unsafe-root-continuation-prompt-tag
           call-with-continuation-prompt
           call-with-continuation-barrier
           abort-current-continuation

racket/src/cs/rumble/control.ss

@@ -134,7 +134,7 @@
      (create-continuation-prompt-tag name)]))
 
 (define (default-continuation-prompt-tag) the-default-continuation-prompt-tag)
-(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag)
+(define (unsafe-root-continuation-prompt-tag) the-root-continuation-prompt-tag)
 
 ;; To support special treatment of break parameterizations, and also
 ;; to initialize disabled breaks for `dynamic-wind` pre and post

racket/src/cs/thread.sls

@@ -26,7 +26,7 @@
                   [threaded? rumble:threaded?]
                   [get-thread-id rumble:get-thread-id]
                   [set-ctl-c-handler! rumble:set-ctl-c-handler!]
-                  [root-continuation-prompt-tag rumble:root-continuation-prompt-tag]
+                  [unsafe-root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag]
                   [set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!]))
 
   ;; Special handling of `current-atomic`: use the last virtual register.
@@ -69,7 +69,7 @@
         'engine-return rumble:engine-return
         'current-engine-state (lambda (v) (rumble:current-engine-state v))
         'set-ctl-c-handler! rumble:set-ctl-c-handler!
-        'root-continuation-prompt-tag rumble:root-continuation-prompt-tag
+        'root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag
         'poll-will-executors poll-will-executors
         'make-will-executor rumble:make-will-executor
         'make-stubborn-will-executor rumble:make-stubborn-will-executor

racket/src/expander/common/parameter-like.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+(require (only-in '#%unsafe
+                  unsafe-root-continuation-prompt-tag))
+
+(provide define-parameter-like
+         parameterize-like)
+
+;; A parameter-like function differs from a parameter by not being
+;; mutable and not being propagated to a new thread. It's just a
+;; continuation mark.
+
+(define root-tag (unsafe-root-continuation-prompt-tag))
+
+(define-syntax-rule (define-parameter-like id val)
+  (begin
+    (define default-val val)
+    (define (id)
+      (continuation-mark-set-first #f id default-val root-tag))))
+
+(define-syntax parameterize-like
+  (syntax-rules ()
+    [(_ #:with () body0 body ...)
+     (let () body0 body ...)]
+    [(_ #:with ([key0 val0] [key val] ...) body0 body ...)
+     (with-continuation-mark key0 val0 (parameterize-like #:with ([key val] ...) body0 body ...))]))

racket/src/expander/eval/main.rkt

@@ -11,7 +11,8 @@
          "../common/phase.rkt"
          "../syntax/match.rkt"
          "../expand/context.rkt"
-         (rename-in "../expand/main.rkt" [expand expand-in-context])
+         (rename-in "../expand/main.rkt"
+                    [expand expand-in-context])
          "../compile/main.rkt"
          "../compile/compiled-in-memory.rkt"
          "top.rkt"
@@ -134,7 +135,7 @@
 (define (expand s [ns (current-namespace)] [observable? #f] [to-parsed? #f] [serializable? #f])
   (define observer (and observable? (current-expand-observe)))
   (when observer (...log-expand observer ['start-top]))
-  (parameterize ((current-expand-observe #f))
+  (parameterize ([current-expand-observe #f])
     (per-top-level s ns
                    #:single (lambda (s ns as-tail?) (expand-single s ns observer to-parsed? serializable?))
                    #:combine cons
@@ -201,7 +202,7 @@
   ;; but `#:single #f` makes it return immediately
   (define observer (current-expand-observe))
   (when observer (...log-expand observer ['start-top]))
-  (parameterize ((current-expand-observe #f))
+  (parameterize ([current-expand-observe #f])
     (per-top-level s ns
                    #:single #f
                    #:quick-immediate? #f

racket/src/expander/eval/module.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "../common/promise.rkt"
          "../common/performance.rkt"
+         "../common/parameter-like.rkt"
          "../namespace/namespace.rkt"
          "../namespace/module.rkt"
          "../namespace/inspector.rkt"
@@ -211,11 +212,12 @@
                                      ;; For phase level 1 and up, set the expansion context
                                      ;; to point back to the module's info:
                                      (define ns-1 (namespace->namespace-at-phase ns (phase+ phase-shift (sub1 phase-level))))
-                                     (parameterize ([current-expand-context (delay (make-expand-context ns-1))]
+                                     (parameterize ([current-namespace ns])
-                                                    [current-namespace ns]
+                                       (parameterize-like
-                                                    [current-module-code-inspector insp])
+                                        #:with ([current-expand-context (delay (make-expand-context ns-1))]
-                                       (instantiate-body))]))))))
+                                                [current-module-code-inspector insp])
-       
+                                        (instantiate-body)))]))))))
+
        (define declare-name (substitute-module-declare-name default-name))
        
        (when with-submodules?

racket/src/expander/eval/top.rkt

@@ -2,6 +2,7 @@
 (require "../common/set.rkt"
          "../common/phase.rkt"
          "../common/performance.rkt"
+         "../common/parameter-like.rkt"
          "../namespace/namespace.rkt"
          "../namespace/module.rkt"
          "../compile/module-use.rkt"
@@ -167,9 +168,10 @@
           [else
            (define ns-1 (namespace->namespace-at-phase phase-ns (sub1 phase)))
            (lambda (tail?)
-             (parameterize ([current-expand-context (make-expand-context ns-1)]
+             (parameterize ([current-namespace phase-ns])
-                            [current-namespace phase-ns])
+               (parameterize-like
-               (instantiate tail?)))])]
+                #:with ([current-expand-context (make-expand-context ns-1)])
+                (instantiate tail?))))])]
         [else void])))
    
    ;; Call last thunk tail position --- maybe, since using a prompt if not `as-tail?`

racket/src/expander/expand/context.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "../common/promise.rkt"
          "../common/struct-star.rkt"
+         "../common/parameter-like.rkt"
          "../syntax/syntax.rkt"
          "../syntax/scope.rkt"
          "../syntax/binding.rkt"
@@ -130,7 +131,7 @@
                 [binding-layer (root-expand-context-frame-id root-ctx)]))
 
 ;; An expand-context or a delayed expand context (so use `force`):
-(define current-expand-context (make-parameter #f))
+(define-parameter-like current-expand-context #f)
 
 (define (get-current-expand-context [who 'unexpected]
                                      #:fail-ok? [fail-ok? #f])

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

@@ -7,6 +7,7 @@
          "../syntax/binding.rkt"
          "../namespace/core.rkt"
          "../namespace/module.rkt"
+         "../namespace/namespace.rkt"
          "context.rkt"
          "main.rkt"
          "syntax-local.rkt"

racket/src/expander/expand/main.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "../common/set.rkt"
          "../common/struct-star.rkt"
+         "../common/parameter-like.rkt"
          "../syntax/syntax.rkt"
          "../syntax/property.rkt"
          "../syntax/scope.rkt"
@@ -427,15 +428,16 @@
                                     ;; lose them at the point where expansion stops
                                     (expand-context-def-ctx-scopes ctx))]))
   (define transformed-s
-    (parameterize ([current-expand-context m-ctx]
+    (parameterize ([current-namespace (namespace->namespace-at-phase
-                   [current-namespace (namespace->namespace-at-phase
                                        (expand-context-namespace ctx)
-                                       (add1 (expand-context-phase ctx)))]
+                                       (add1 (expand-context-phase ctx)))])
-                   [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))])
+      (parameterize-like
-      (call-with-continuation-barrier
+       #:with ([current-expand-context m-ctx]
-       (lambda ()
+               [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))])
-         ;; Call the transformer!
+       (call-with-continuation-barrier
-         ((transformer->procedure t) cleaned-s)))))
+        (lambda ()
+          ;; Call the transformer!
+          ((transformer->procedure t) cleaned-s))))))
   (log-expand ctx 'macro-post-x transformed-s cleaned-s)
   (unless (syntax? transformed-s)
     (raise-arguments-error (syntax-e id)
@@ -671,12 +673,13 @@
                                           #:phase phase))))
   (define vals
     (call-with-values (lambda ()
-                        (parameterize ([current-expand-context ctx]
+                        (parameterize ([current-namespace ns]
-                                       [current-namespace ns]
                                        [eval-jit-enabled #f])
-                          (if compiled
+                          (parameterize-like
-                              (eval-single-top compiled ns)
+                           #:with ([current-expand-context ctx])
-                              (direct-eval p ns (root-expand-context-self-mpi ctx)))))
+                           (if compiled
+                               (eval-single-top compiled ns)
+                               (direct-eval p ns (root-expand-context-self-mpi ctx))))))
       list))
   (unless (= (length vals) (length ids))
     (apply raise-result-arity-error
@@ -772,16 +775,18 @@
 ;; as a function, and that fnuction might want to use
 ;; `syntax-local-value`, etc.
 (define (rename-transformer-target-in-context t ctx)
-  (parameterize ([current-expand-context ctx])
+  (parameterize-like
-    (rename-transformer-target t)))
+   #:with ([current-expand-context ctx])
+   (rename-transformer-target t)))
 
 ;; In case the rename-transformer has a callback, ensure that the
 ;; current expansion context is available while installing a
 ;; `free-identifier=?` equivalence
 (define (maybe-install-free=id-in-context! val id phase ctx)
   (when (rename-transformer? val)
-    (parameterize ([current-expand-context ctx])
+    (parameterize-like
-      (maybe-install-free=id! val id phase))))
+     #:with ([current-expand-context ctx])
+     (maybe-install-free=id! val id phase))))
 
 ;; Transfer the original ID's source location, if any, when expanding
 ;; a reference to a rename transformer

racket/src/expander/expand/module.rkt

@@ -2,6 +2,7 @@
 (require "../common/promise.rkt"
          "../common/struct-star.rkt"
          "../common/performance.rkt"
+         "../common/parameter-like.rkt"
          "../syntax/syntax.rkt"
          "../syntax/debug.rkt"
          "../syntax/property.rkt"
@@ -1300,13 +1301,14 @@
       (void)]
      [else
       ;; an expression
-      (parameterize ([current-expand-context ctx]
+      (parameterize ([current-namespace m-ns])
-                     [current-namespace m-ns])
+        (parameterize-like
-        (eval-single-top
+         #:with ([current-expand-context ctx])
-         (compile-single p (make-compile-context
+         (eval-single-top
-                            #:namespace m-ns
+          (compile-single p (make-compile-context
-                            #:phase phase))
+                             #:namespace m-ns
-         m-ns))])))
+                             #:phase phase))
+          m-ns)))])))
 
 ;; ----------------------------------------
 

racket/src/expander/namespace/inspector.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
+(require "../common/parameter-like.rkt")
 
 (provide current-module-code-inspector)
 
 ;; Parameter to select inspector for functions like `syntax-arm`
-(define current-module-code-inspector (make-parameter #f))
+(define-parameter-like current-module-code-inspector #f)

racket/src/expander/read/config.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require "../common/struct-star.rkt"
+         "../common/parameter-like.rkt"
          "readtable-parameter.rkt")
 
 (provide (struct*-out read-config)
@@ -36,7 +37,7 @@
 (struct read-config-state ([accum-str #:mutable] ; string-buffer cache
                            [graph #:mutable]))   ; #f or hash of number -> value
 
-(define current-read-config (make-parameter #f)) ; for `read/recursive`
+(define-parameter-like current-read-config #f) ; for `read/recursive`
 
 (define (make-read-config
          #:source [source #f]

racket/src/expander/read/extension.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "config.rkt"
+(require "../common/parameter-like.rkt"
+         "config.rkt"
          "special.rkt"
          "consume.rkt"
          "error.rkt"
@@ -195,16 +196,18 @@
        [(and for-syntax? (not get-info?))
         (cond
          [(procedure-arity-includes? extension 6)
-          (parameterize ([current-read-config config])
+          (parameterize-like
-            (extension (read-config-source config)
+           #:with ([current-read-config config])
-                       in
+           (extension (read-config-source config)
-                       mod-path-wrapped
+                      in
-                       (read-config-line config)
+                      mod-path-wrapped
-                       (read-config-col config)
+                      (read-config-line config)
-                       (read-config-pos config)))]
+                      (read-config-col config)
+                      (read-config-pos config)))]
          [(procedure-arity-includes? extension 2)
-          (parameterize ([current-read-config config])
+          (parameterize-like
-            (extension (read-config-source config) in))]
+           #:with ([current-read-config config])
+           (extension (read-config-source config) in))]
          [else
           (raise-argument-error who
                                 "(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))"
@@ -212,19 +215,21 @@
        [else
         (cond
          [(procedure-arity-includes? extension 5)
-          (parameterize ([current-read-config config])
+          (parameterize-like
-            (extension in
+           #:with ([current-read-config config])
-                       mod-path-wrapped
+           (extension in
-                       (read-config-line config)
+                      mod-path-wrapped
-                       (read-config-col config)
+                      (read-config-line config)
-                       (read-config-pos config)))]
+                      (read-config-col config)
+                      (read-config-pos config)))]
          [get-info?
           (raise-argument-error who
                                 "(procedure-arity-includes?/c 5)"
                                 extension)]
          [(procedure-arity-includes? extension 1)
-          (parameterize ([current-read-config config])
+          (parameterize-like
-            (extension in))]
+           #:with ([current-read-config config])
+           (extension in))]
          [else
           (raise-argument-error who
                                 "(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))"

racket/src/expander/read/readtable.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require "../common/inline.rkt"
+         "../common/parameter-like.rkt"
          "config.rkt"
          "coerce.rkt"
          "parameter.rkt"
@@ -159,13 +160,15 @@
   (define v
     (cond
      [(not for-syntax?)
-      (parameterize ([current-read-config config])
+      (parameterize-like
-        (if (procedure-arity-includes? handler 2)
+       #:with ([current-read-config config])
-            (handler c in)
+       (if (procedure-arity-includes? handler 2)
-            (handler c in #f line col pos)))]
+           (handler c in)
+           (handler c in #f line col pos)))]
      [else
-      (parameterize ([current-read-config config])
+      (parameterize-like
-        (handler c in (read-config-source config) line col pos))]))
+       #:with ([current-read-config config])
+       (handler c in (read-config-source config) line col pos))]))
   (if (special-comment? v)
       v
       (coerce v in config)))

racket/src/racket/src/fun.c

@@ -60,6 +60,7 @@ READ_ONLY Scheme_Object *scheme_call_with_immed_mark_proc;
 READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
 READ_ONLY Scheme_Object *scheme_tail_call_waiting;
 READ_ONLY Scheme_Object *scheme_default_prompt_tag;
+READ_ONLY Scheme_Object *scheme_root_prompt_tag;
 READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;
 
 /* READ ONLY SHARABLE GLOBALS */
@@ -177,6 +178,7 @@ static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv)
 
 static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *
 scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, 
@@ -689,6 +691,14 @@ scheme_init_fun (Scheme_Startup_Env *env)
     (void)scheme_hash_key(SCHEME_PTR_VAL(scheme_default_prompt_tag));
   }
 
+  REGISTER_SO(scheme_root_prompt_tag);
+  {
+    Scheme_Object *a[1];
+    a[0] = scheme_intern_symbol("root");
+    scheme_root_prompt_tag = make_prompt_tag(1, a);
+    (void)scheme_hash_key(SCHEME_PTR_VAL(scheme_root_prompt_tag));
+  }
+
   REGISTER_SO(original_default_prompt);
   original_default_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
   original_default_prompt->so.type = scheme_prompt_type;
@@ -736,6 +746,8 @@ scheme_init_unsafe_fun (Scheme_Startup_Env *env)
 
   ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env);
   ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env);
+
+  ADD_PRIM_W_ARITY("unsafe-root-continuation-prompt-tag", unsafe_root_continuation_prompt_tag, 0, 0, env);
 }
 
 void
@@ -5314,6 +5326,11 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
   return copied_cms;
 }
 
+static void root_prompt_tag_misuse(const char *who)
+{
+  scheme_signal_error("%s: misuse of root prompt tag", who);
+}
+
 static Scheme_Object *
 call_cc (int argc, Scheme_Object *argv[])
 {
@@ -5924,6 +5941,13 @@ internal_call_cc (int argc, Scheme_Object *argv[])
 
   composable = (argc > 2);
 
+  if (SAME_OBJ(pt, scheme_root_prompt_tag)) {
+    root_prompt_tag_misuse(composable
+                           ? "call-with-composable-continuation"
+                           : "call-with-current-continuation");
+    return NULL;
+  }
+
   prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &prompt_cont, &prompt_pos);
   if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, pt)) {
     scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
@@ -6974,11 +6998,15 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
         prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
       } else {
         scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
-                          1, in_argc, in_argv);
+                              1, in_argc, in_argv);
         return NULL;
       }
     } else
       prompt_tag = in_argv[1];
+    if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
+      root_prompt_tag_misuse("call-with-continuation-prompt");
+      return NULL;
+    }
   } else
     prompt_tag = scheme_default_prompt_tag;
 
@@ -7426,12 +7454,17 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
       prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
     } else {
       scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
-                        0, argc, argv);
+                            0, argc, argv);
       return NULL;
     }
   } else
     prompt_tag = argv[0];
 
+  if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
+    root_prompt_tag_misuse("abort-current-continuation");
+    return NULL;
+  }
+
   prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
   if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
     prompt = original_default_prompt;
@@ -7518,10 +7551,14 @@ static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int
         prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
       else {
         scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?",
-                          1, argc, argv);
+                              1, argc, argv);
         return NULL;
       }
-    } 
+    }
+    if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
+      root_prompt_tag_misuse("abort-current-continuation");
+      return NULL;
+    }
   } else
     prompt_tag = scheme_default_prompt_tag;
 
@@ -7556,6 +7593,11 @@ static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *a
   return do_call_with_control(argc, argv, 1);
 }
 
+static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[])
+{
+  return scheme_root_prompt_tag;
+}
+
 static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc)
 {
   Scheme_Cont_Mark *cp;
@@ -7585,6 +7627,9 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
   intptr_t cmpos, first_cmpos = 0, cdelta = 0;
   int found_tag = 0, at_mc_boundary = 0;
 
+  if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag))
+    prompt_tag = NULL;
+
   if (cont && SAME_OBJ(cont->prompt_tag, prompt_tag))
     found_tag = 1;
   if (!prompt_tag)
@@ -7903,10 +7948,11 @@ cc_marks(int argc, Scheme_Object *argv[])
         prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
       else
         scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?",
-                          0, argc, argv);
+                              0, argc, argv);
     }
 
-    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
+    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
+        && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
       if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
         scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                          "current-continuation-marks: no corresponding prompt in the continuation\n"
@@ -8023,7 +8069,7 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
         prompt_tag = SCHEME_CHAPERONE_VAL(argv[2]);
       else {
         scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?",
-                          2, argc, argv);
+                              2, argc, argv);
         return NULL;
       }
     } else
@@ -8274,6 +8320,9 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key
 {
   Scheme_Object *key = key_arg;
 
+  if (prompt_tag && SAME_OBJ(prompt_tag, SCHEME_PTR_VAL(scheme_root_prompt_tag)))
+    prompt_tag = NULL;
+
   if (SCHEME_NP_CHAPERONEP(key)
       && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
     key = SCHEME_CHAPERONE_VAL(key);
@@ -8470,7 +8519,7 @@ extract_one_cc_mark_fast(Scheme_Object *key, int *_conclusive)
   Scheme_Cont_Mark *seg;
   Scheme_Thread *p = scheme_current_thread;
   Scheme_Meta_Continuation *mc = NULL;
- 
+
   do {
     if (mc) {
       startpos = mc->cont_mark_total;
@@ -8612,7 +8661,7 @@ Scheme_Object *
 scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
 {
   Scheme_Object *v;
-  
+
   if (!mark_set) {
     int conclusive = 0;
     v = extract_one_cc_mark_fast(key, &conclusive);
@@ -8661,7 +8710,8 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[])
     } else
       prompt_tag = argv[3];
 
-    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
+    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
+        && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag)) {
       if (SCHEME_FALSEP(argv[0])) {
         if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
           scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
@@ -8723,7 +8773,8 @@ static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *arg
       } else {
         Scheme_Meta_Continuation *mc;
 
-        if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
+        if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
+            || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
           return scheme_true;
 
         mc = scheme_get_meta_continuation(argv[1]);
@@ -8740,7 +8791,8 @@ static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *arg
                         1, argc, argv);
     }
   } else {
-    if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
+    if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
+        || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
       return scheme_true;
 
     if (scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1440
+#define EXPECTED_PRIM_COUNT 1441
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schpriv.h

@@ -676,6 +676,7 @@ extern Scheme_Hash_Tree *scheme_source_stx_props;
 
 extern Scheme_Object *scheme_stack_dump_key;
 
+extern Scheme_Object *scheme_root_prompt_tag;
 extern Scheme_Object *scheme_default_prompt_tag;
 
 THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "7.0.0.13"
+#define MZSCHEME_VERSION "7.0.0.14"
 
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 13
+#define MZSCHEME_VERSION_W 14
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/startup.inc

@@ -15392,6 +15392,7 @@ static const char *startup_source =
 "(if(syntax-tainted?$1 id_0)"
 "        (let-values () (raise-syntax-error$1 #f \"cannot use identifier tainted by macro transformation\" id_0))"
 "(void)))))"
+"(define-values(root-tag)(unsafe-root-continuation-prompt-tag))"
 "(define-values(cons-ish)(lambda(a_0 b_0)(begin(if(null? b_0) a_0(cons a_0 b_0)))))"
 "(define-values"
 "(to-syntax-list.1)"
@@ -16184,7 +16185,10 @@ static const char *startup_source =
 "(expand-context/outer-current-use-scopes the-struct_0)"
 "(expand-context/outer-name the-struct_0)))"
 "            (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_0)))))))"
-"(define-values(current-expand-context)(make-parameter #f))"
+"(define-values(default-val.1$2) #f)"
+"(define-values"
+"(current-expand-context)"
+"(lambda()(begin(continuation-mark-set-first #f current-expand-context default-val.1$2 root-tag))))"
 "(define-values"
 "(get-current-expand-context16.1)"
 "(lambda(fail-ok?13_0 who15_0)"
@@ -16644,7 +16648,10 @@ static const char *startup_source =
 "(define-values"
 "(syntax-remove-taint-dispatch-properties)"
 "(lambda(s_0)(begin(1/syntax-property-remove(1/syntax-property-remove s_0 'taint-mode) 'certify-mode))))"
-"(define-values(current-module-code-inspector)(make-parameter #f))"
+"(define-values(default-val.1$1) #f)"
+"(define-values"
+"(current-module-code-inspector)"
+"(lambda()(begin(continuation-mark-set-first #f current-module-code-inspector default-val.1$1 root-tag))))"
 "(define-values"
 "(syntax-debug-info$1)"
 "(lambda(s_0 phase_0 all-bindings?_0)"
@@ -34824,6 +34831,10 @@ static const char *startup_source =
 "(continuation-mark-set-first"
 " #f"
 " parameterization-key)"
+" 1/current-namespace"
+" ns_2)"
+"(let-values()"
+"(with-continuation-mark"
 " current-expand-context"
 "(promise1.1"
 "(lambda()"
@@ -34835,12 +34846,11 @@ static const char *startup_source =
 " #f"
 " ns-153_0)))"
 " #f)"
-" 1/current-namespace"
+"(with-continuation-mark"
-" ns_2"
 " current-module-code-inspector"
-" insp_0)"
+" insp_0"
 "(let-values()"
-"(instantiate-body_0))))))))))))"
+"(instantiate-body_0)))))))))))))))"
 "(void)))))"
 "(if log-performance?"
 "(let-values()"
@@ -37868,6 +37878,10 @@ static const char *startup_source =
 "(continuation-mark-set-first"
 " #f"
 " parameterization-key)"
+" 1/current-namespace"
+" phase-ns_0)"
+"(let-values()"
+"(with-continuation-mark"
 " current-expand-context"
 "(let-values(((ns-144_0)"
 " ns-1_0))"
@@ -37876,11 +37890,9 @@ static const char *startup_source =
 " #f"
 " #f"
 " ns-144_0))"
-" 1/current-namespace"
-" phase-ns_0)"
 "(let-values()"
 "(instantiate_0"
-" tail?_0))))))))))))"
+" tail?_0))))))))))))))"
 "(let-values()"
 " void)))))))))))"
 "(values"
@@ -39918,17 +39930,20 @@ static const char *startup_source =
 " parameterization-key"
 "(extend-parameterization"
 "(continuation-mark-set-first #f parameterization-key)"
-" current-expand-context"
-" m-ctx_0"
 " 1/current-namespace"
 "(namespace->namespace-at-phase"
 "(expand-context-namespace ctx_0)"
-"(add1(expand-context-phase ctx_0)))"
+"(add1(expand-context-phase ctx_0))))"
+"(let-values()"
+"(with-continuation-mark"
+" current-expand-context"
+" m-ctx_0"
+"(with-continuation-mark"
 " current-module-code-inspector"
-" insp-of-t_0)"
+" insp-of-t_0"
 "(let-values()"
 "(call-with-continuation-barrier"
-"(lambda()((transformer->procedure t_0) cleaned-s_0)))))))"
+"(lambda()((transformer->procedure t_0) cleaned-s_0))))))))))"
 "(begin"
 "(let-values(((obs_0)(expand-context-observer ctx_0)))"
 "(if obs_0"
@@ -40454,16 +40469,18 @@ static const char *startup_source =
 " parameterization-key"
 "(extend-parameterization"
 "(continuation-mark-set-first #f parameterization-key)"
-" current-expand-context"
-" ctx_0"
 " 1/current-namespace"
 " ns_0"
 " eval-jit-enabled"
 " #f)"
 "(let-values()"
+"(with-continuation-mark"
+" current-expand-context"
+" ctx_0"
+"(let-values()"
 "(if compiled_0"
 "(eval-single-top compiled_0 ns_0)"
-"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))"
+"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))))"
 " list)))"
 "(begin"
 "(if(=(length vals_0)(length ids_0))"
@@ -40645,11 +40662,7 @@ static const char *startup_source =
 "(define-values"
 "(rename-transformer-target-in-context)"
 "(lambda(t_0 ctx_0)"
-"(begin"
+"(begin(with-continuation-mark current-expand-context ctx_0(let-values()(1/rename-transformer-target t_0))))))"
-"(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_0)"
-"(let-values()(1/rename-transformer-target t_0))))))"
 "(define-values"
 "(maybe-install-free=id-in-context!)"
 "(lambda(val_0 id_0 phase_0 ctx_0)"
@@ -40657,8 +40670,8 @@ static const char *startup_source =
 "(if(1/rename-transformer? val_0)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
+" current-expand-context"
-"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_0)"
+" ctx_0"
 "(let-values()(maybe-install-free=id! val_0 id_0 phase_0))))"
 "(void)))))"
 "(define-values"
@@ -48176,7 +48189,10 @@ static const char *startup_source =
 "(make-struct-field-accessor -ref_0 1 'graph)"
 "(make-struct-field-mutator -set!_0 0 'accum-str)"
 "(make-struct-field-mutator -set!_0 1 'graph))))"
-"(define-values(current-read-config)(make-parameter #f))"
+"(define-values(default-val.1) #f)"
+"(define-values"
+"(current-read-config)"
+"(lambda()(begin(continuation-mark-set-first #f current-read-config default-val.1 root-tag))))"
 "(define-values"
 "(make-read-config26.1)"
 "(lambda(coerce12_0"
@@ -48826,22 +48842,16 @@ static const char *startup_source =
 "(if(not for-syntax?_0)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first #f parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()"
 "(if(procedure-arity-includes? handler_0 2)"
 "(handler_0 c_0 in_0)"
 "(handler_0 c_0 in_0 #f line_0 col_0 pos_0)))))"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first #f parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()(handler_0 c_0 in_0(read-config-source config_0) line_0 col_0 pos_0)))))))"
 "(if(1/special-comment? v_0) v_0(coerce v_0 in_0 config_0)))))))"
 "(define-values"
@@ -55456,11 +55466,8 @@ static const char *startup_source =
 "(if(procedure-arity-includes? extension_0 6)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first #f parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()"
 "(extension_0"
 "(read-config-source config_0)"
@@ -55472,13 +55479,8 @@ static const char *startup_source =
 "(if(procedure-arity-includes? extension_0 2)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first"
-" #f"
-" parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()"
 "(extension_0(read-config-source config_0) in_0))))"
 "(let-values()"
@@ -55490,11 +55492,8 @@ static const char *startup_source =
 "(if(procedure-arity-includes? extension_0 5)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first #f parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()"
 "(extension_0"
 " in_0"
@@ -55511,13 +55510,8 @@ static const char *startup_source =
 "(if(procedure-arity-includes? extension_0 1)"
 "(let-values()"
 "(with-continuation-mark"
-" parameterization-key"
-"(extend-parameterization"
-"(continuation-mark-set-first"
-" #f"
-" parameterization-key)"
 " current-read-config"
-" config_0)"
+" config_0"
 "(let-values()(extension_0 in_0))))"
 "(let-values()"
 "(raise-argument-error"
@@ -77134,11 +77128,13 @@ static const char *startup_source =
 "(continuation-mark-set-first"
 " #f"
 " parameterization-key)"
-" current-expand-context"
-" ctx_0"
 " 1/current-namespace"
 " m-ns_0)"
 "(let-values()"
+"(with-continuation-mark"
+" current-expand-context"
+" ctx_0"
+"(let-values()"
 "(eval-single-top"
 "(compile-single"
 " p_0"
@@ -77153,7 +77149,7 @@ static const char *startup_source =
 " m-ns672_0"
 " phase673_0"
 " unsafe-undefined)))"
-" m-ns_0)))))))))"
+" m-ns_0)))))))))))"
 "(values)))))"
 "(values)))))"
 "(if(not #f)(for-loop_0 rest_0)(values))))"

racket/src/racket/src/thread.c

@@ -8766,7 +8766,6 @@ static Scheme_Object *unsafe_remove_collect_callbacks(int argc, Scheme_Object *a
   return scheme_void;
 }
 
-
 #if defined(_MSC_VER) || defined(__MINGW32__)
 # define mzOSAPI WINAPI
 #else