From 16e496b0c54e752b7368a87e5c96cc20de6e6db9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Aug 2018 08:00:26 -0600 Subject: [PATCH] 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 | 2 +- pkgs/racket-test-core/tests/racket/macro.rktl | 15 +++ racket/collects/racket/private/stxparam.rkt | 15 +-- .../collects/racket/private/stxparamkey.rkt | 9 +- racket/collects/racket/splicing.rkt | 29 ++--- racket/collects/racket/unsafe/ops.rkt | 1 + racket/src/cs/primitive/kernel.ss | 2 +- racket/src/cs/primitive/unsafe.ss | 1 + racket/src/cs/rumble.sls | 2 +- racket/src/cs/rumble/control.ss | 2 +- racket/src/cs/thread.sls | 4 +- racket/src/expander/common/parameter-like.rkt | 25 ++++ racket/src/expander/eval/main.rkt | 7 +- racket/src/expander/eval/module.rkt | 12 +- racket/src/expander/eval/top.rkt | 8 +- racket/src/expander/expand/context.rkt | 3 +- racket/src/expander/expand/local-expand.rkt | 1 + racket/src/expander/expand/main.rkt | 39 ++++--- racket/src/expander/expand/module.rkt | 16 +-- racket/src/expander/namespace/inspector.rkt | 3 +- racket/src/expander/read/config.rkt | 3 +- racket/src/expander/read/extension.rkt | 41 ++++--- racket/src/expander/read/readtable.rkt | 15 ++- racket/src/racket/src/fun.c | 76 ++++++++++-- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schpriv.h | 1 + racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.inc | 108 +++++++++--------- racket/src/racket/src/thread.c | 1 - 29 files changed, 285 insertions(+), 162 deletions(-) create mode 100644 racket/src/expander/common/parameter-like.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index d62a46346a..dd47a40e80 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index ab37472c81..6756a38fae 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/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) diff --git a/racket/collects/racket/private/stxparam.rkt b/racket/collects/racket/private/stxparam.rkt index 5553a4f100..cfa9163c1b 100644 --- a/racket/collects/racket/private/stxparam.rkt +++ b/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 - (extend-parameter-environment - (current-parameter-environment) - #'([local-key id] ...))]) - (syntax-local-expand-expression - #'(let-values () body ...) - #t))])]) + (with-continuation-mark + current-parameter-environment + (extend-parameter-environment + (current-parameter-environment) + #'([local-key id] ...)) + (syntax-local-expand-expression + #'(let-values () body ...) + #t))])]) opaque-expr) (with-syntax ([stx stx]) #'(#%expression stx))))) diff --git a/racket/collects/racket/private/stxparamkey.rkt b/racket/collects/racket/private/stxparamkey.rkt index c3d164b347..f629c12dbc 100644 --- a/racket/collects/racket/private/stxparamkey.rkt +++ b/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 diff --git a/racket/collects/racket/splicing.rkt b/racket/collects/racket/splicing.rkt index 5419427767..6df4e57b47 100644 --- a/racket/collects/racket/splicing.rkt +++ b/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 - (extend-parameter-environment (current-parameter-environment) #'binds)]) - (local-expand #'(force-expand body) - (syntax-local-context) - null ;; `force-expand' actually determines stopping places - ctx))]) + (let ([body (with-continuation-mark + current-parameter-environment + (extend-parameter-environment (current-parameter-environment) #'binds) + (local-expand #'(force-expand body) + (syntax-local-context) + 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 - (extend-parameter-environment (current-parameter-environment) - #'new-binds)]) - (let* ([forms (syntax->list #'(body-form ...))] + (with-continuation-mark + current-parameter-environment + (extend-parameter-environment (current-parameter-environment) + #'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 - (extend-parameter-environment (current-parameter-environment) (quote-syntax binds))]) - e))]) + #'(with-continuation-mark + current-parameter-environment + (extend-parameter-environment (current-parameter-environment) (quote-syntax binds)) + e))]) (if (eq? (syntax-local-context) 'expression) (as-expression) (let ([e (local-expand #'e diff --git a/racket/collects/racket/unsafe/ops.rkt b/racket/collects/racket/unsafe/ops.rkt index e632cfc424..69b4789f23 100644 --- a/racket/collects/racket/unsafe/ops.rkt +++ b/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 diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index f4572373e9..50aba401c3 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/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)] diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss index 17807dc5cc..7eb0e6bade 100644 --- a/racket/src/cs/primitive/unsafe.ss +++ b/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)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index a404ebd003..57cfab3195 100644 --- a/racket/src/cs/rumble.sls +++ b/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 diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss index 5badbd9c80..12b3f9d58b 100644 --- a/racket/src/cs/rumble/control.ss +++ b/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 diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index ffe9334d1c..2eb95ff933 100644 --- a/racket/src/cs/thread.sls +++ b/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 diff --git a/racket/src/expander/common/parameter-like.rkt b/racket/src/expander/common/parameter-like.rkt new file mode 100644 index 0000000000..837c1278b5 --- /dev/null +++ b/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 ...))])) diff --git a/racket/src/expander/eval/main.rkt b/racket/src/expander/eval/main.rkt index 99b753a044..14ee0a0825 100644 --- a/racket/src/expander/eval/main.rkt +++ b/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 diff --git a/racket/src/expander/eval/module.rkt b/racket/src/expander/eval/module.rkt index afa1528bb9..1462ffa239 100644 --- a/racket/src/expander/eval/module.rkt +++ b/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))] - [current-namespace ns] - [current-module-code-inspector insp]) - (instantiate-body))])))))) - + (parameterize ([current-namespace ns]) + (parameterize-like + #:with ([current-expand-context (delay (make-expand-context ns-1))] + [current-module-code-inspector insp]) + (instantiate-body)))])))))) + (define declare-name (substitute-module-declare-name default-name)) (when with-submodules? diff --git a/racket/src/expander/eval/top.rkt b/racket/src/expander/eval/top.rkt index bbcdbe3448..7c48a7bb19 100644 --- a/racket/src/expander/eval/top.rkt +++ b/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)] - [current-namespace phase-ns]) - (instantiate tail?)))])] + (parameterize ([current-namespace phase-ns]) + (parameterize-like + #: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?` diff --git a/racket/src/expander/expand/context.rkt b/racket/src/expander/expand/context.rkt index a84be364e9..2953856d52 100644 --- a/racket/src/expander/expand/context.rkt +++ b/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]) diff --git a/racket/src/expander/expand/local-expand.rkt b/racket/src/expander/expand/local-expand.rkt index 136f6a49fd..1865c08051 100644 --- a/racket/src/expander/expand/local-expand.rkt +++ b/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" diff --git a/racket/src/expander/expand/main.rkt b/racket/src/expander/expand/main.rkt index ffee8ef5de..1a7b365deb 100644 --- a/racket/src/expander/expand/main.rkt +++ b/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] - [current-namespace (namespace->namespace-at-phase + (parameterize ([current-namespace (namespace->namespace-at-phase (expand-context-namespace ctx) - (add1 (expand-context-phase ctx)))] - [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))]) - (call-with-continuation-barrier - (lambda () - ;; Call the transformer! - ((transformer->procedure t) cleaned-s))))) + (add1 (expand-context-phase ctx)))]) + (parameterize-like + #:with ([current-expand-context m-ctx] + [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))]) + (call-with-continuation-barrier + (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] - [current-namespace ns] + (parameterize ([current-namespace ns] [eval-jit-enabled #f]) - (if compiled - (eval-single-top compiled ns) - (direct-eval p ns (root-expand-context-self-mpi ctx))))) + (parameterize-like + #:with ([current-expand-context 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]) - (rename-transformer-target t))) + (parameterize-like + #: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]) - (maybe-install-free=id! val id phase)))) + (parameterize-like + #: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 diff --git a/racket/src/expander/expand/module.rkt b/racket/src/expander/expand/module.rkt index 5815552508..69121ce10a 100644 --- a/racket/src/expander/expand/module.rkt +++ b/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] - [current-namespace m-ns]) - (eval-single-top - (compile-single p (make-compile-context - #:namespace m-ns - #:phase phase)) - m-ns))]))) + (parameterize ([current-namespace m-ns]) + (parameterize-like + #:with ([current-expand-context ctx]) + (eval-single-top + (compile-single p (make-compile-context + #:namespace m-ns + #:phase phase)) + m-ns)))]))) ;; ---------------------------------------- diff --git a/racket/src/expander/namespace/inspector.rkt b/racket/src/expander/namespace/inspector.rkt index 29d7af01f4..6a97baac7d 100644 --- a/racket/src/expander/namespace/inspector.rkt +++ b/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) diff --git a/racket/src/expander/read/config.rkt b/racket/src/expander/read/config.rkt index 19b829dee7..35fed0e5c3 100644 --- a/racket/src/expander/read/config.rkt +++ b/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] diff --git a/racket/src/expander/read/extension.rkt b/racket/src/expander/read/extension.rkt index 67a358aa8b..00cd9e8202 100644 --- a/racket/src/expander/read/extension.rkt +++ b/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]) - (extension (read-config-source config) - in - mod-path-wrapped - (read-config-line config) - (read-config-col config) - (read-config-pos config)))] + (parameterize-like + #:with ([current-read-config config]) + (extension (read-config-source config) + in + mod-path-wrapped + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] [(procedure-arity-includes? extension 2) - (parameterize ([current-read-config config]) - (extension (read-config-source config) in))] + (parameterize-like + #: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]) - (extension in - mod-path-wrapped - (read-config-line config) - (read-config-col config) - (read-config-pos config)))] + (parameterize-like + #:with ([current-read-config config]) + (extension in + mod-path-wrapped + (read-config-line 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]) - (extension in))] + (parameterize-like + #:with ([current-read-config config]) + (extension in))] [else (raise-argument-error who "(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))" diff --git a/racket/src/expander/read/readtable.rkt b/racket/src/expander/read/readtable.rkt index 071295c31d..9ff5f5abf5 100644 --- a/racket/src/expander/read/readtable.rkt +++ b/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]) - (if (procedure-arity-includes? handler 2) - (handler c in) - (handler c in #f line col pos)))] + (parameterize-like + #:with ([current-read-config config]) + (if (procedure-arity-includes? handler 2) + (handler c in) + (handler c in #f line col pos)))] [else - (parameterize ([current-read-config config]) - (handler c in (read-config-source config) line col pos))])) + (parameterize-like + #:with ([current-read-config config]) + (handler c in (read-config-source config) line col pos))])) (if (special-comment? v) v (coerce v in config))) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 3cf5226a5d..5240480d85 100644 --- a/racket/src/racket/src/fun.c +++ b/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))) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index f3ed9882f8..ae17c01250 100644 --- a/racket/src/racket/src/schminc.h +++ b/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 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 1ae846478b..9633014b2c 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 62ca731a3c..757745042e 100644 --- a/racket/src/racket/src/schvers.h +++ b/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) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index db15c7da92..9d95aa4b2e 100644 --- a/racket/src/racket/src/startup.inc +++ b/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" -" ns_2" +"(with-continuation-mark" " 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" -"(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))))))" +"(begin(with-continuation-mark 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" -"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_0)" +" current-expand-context" +" 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))))" diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index dee6c278ea..d79f41547a 100644 --- a/racket/src/racket/src/thread.c +++ b/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