From: Matt Birkholz Date: Wed, 5 Nov 2014 20:27:11 +0000 (-0700) Subject: smp: Clobber fluid-let and the (runtime state-space) package. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fca7e9c65c944dcc2873d0acebaadf974fc24834;p=mit-scheme.git smp: Clobber fluid-let and the (runtime state-space) package. UNimplement fluid-let using dynamic-wind as a backward compatibility kludge. Subsystems still using fluid-let, e.g. LIAR, must not be run in multiple threads simultaneously. Fluid-let no longer provides thread-local storage. Replace the previously fluid-assigned bindings state-space:local and (runtime dynamic)bindings with thread slots dynamic-point and dynamic-environment. Split the initialization of (runtime thread) into "low" and "high" procedures. The "low" procedure is applied early in the bootstrap to create the initial thread, whose dynamic state is needed later. Lose the error handling in wait-for-io; it runs when there is no current thread, thus no way to bind-condition- handler. Replace the uniprocessor-only Hanson/Lamping state-spaces with Scheme48's multiprocessing-friendly dynamic-points in a new package (runtime wind). --- diff --git a/doc/ref-manual/misc-datatypes.texi b/doc/ref-manual/misc-datatypes.texi index 29b2cf090..faad58b29 100644 --- a/doc/ref-manual/misc-datatypes.texi +++ b/doc/ref-manual/misc-datatypes.texi @@ -493,8 +493,12 @@ unspecified value. Alters the contents of @var{cell} to be @var{object}, calls @var{thunk} with no arguments, then restores the original contents of @var{cell} and returns the value returned by @var{thunk}. This is completely -equivalent to dynamic binding of a variable, including the behavior when -continuations are used (@pxref{Dynamic Binding}). +equivalent to a dynamic winding that saves and restores the value of +the cell, including the behavior when +continuations are used. (@xref{Dynamic Binding}.) + +Note that the behavior of this procedure has changed. The new +behavior allows other threads to see the value bound to @var{cell}. @end deffn @node Records, Promises, Parameters, Miscellaneous Datatypes diff --git a/doc/ref-manual/overview.texi b/doc/ref-manual/overview.texi index a3adda952..fb6688bb3 100644 --- a/doc/ref-manual/overview.texi +++ b/doc/ref-manual/overview.texi @@ -1004,26 +1004,25 @@ defined when MIT/GNU Scheme is initialized: @item delay @tab do @tab er-macro-transformer -@item fluid-let -@tab if +@item if @tab lambda -@item let -@tab let* +@tab let +@item let* @tab let*-syntax -@item let-syntax -@tab letrec +@tab let-syntax +@item letrec @tab letrec-syntax -@item local-declare -@tab named-lambda +@tab local-declare +@item named-lambda @tab non-hygienic-macro-transformer -@item or -@tab quasiquote +@tab or +@item quasiquote @tab quote -@item rsc-macro-transformer -@tab sc-macro-transformer +@tab rsc-macro-transformer +@item sc-macro-transformer @tab set! -@item syntax-rules -@tab the-environment +@tab syntax-rules +@item the-environment @end multitable @node Procedure Call Syntax, , Special Form Syntax, Expressions diff --git a/doc/ref-manual/special-forms.texi b/doc/ref-manual/special-forms.texi index 974facbb8..c9c1f94f8 100644 --- a/doc/ref-manual/special-forms.texi +++ b/doc/ref-manual/special-forms.texi @@ -340,7 +340,8 @@ parameter object. A @code{parameterize} expression is used to change the values of specified parameter objects during the evaluation of the body -@var{expression}s. +@var{expression}s. These values are not visible to other threads +executing outside the dynamic extent of the body. The @var{parameter} and @var{value} expressions are evaluated in an unspecified order. The body is evaluated in a dynamic @@ -391,6 +392,7 @@ bindings at a given time is called the @dfn{dynamic environment}. The new values are only accessible to the thread that constructed the dynamic environment, and any threads created within that environment. +@cindex dynamic extent @cindex extent, of dynamic binding (defn) The @dfn{extent} of a dynamic binding is defined to be the time period during which calling the parameter returns the new value. Normally @@ -473,14 +475,13 @@ modified outside of the thunk was also preserved. @subsection Fluid-Let -The @code{fluid-let} special form can change the value of @emph{any} -variable for a dynamic extent, but it is difficult to implement in a -multi-processing (SMP) world. It and the cell object type -(@pxref{Cells}) are now @strong{deprecated}. They are still available -and functional in a uni-processing (non-SMP) world, but will signal an -error when used in an SMP world. The @code{parameterize} special form -(@pxref{parameterize}) or @code{let-fluids} procedure -(@pxref{let-fluids}) should be used instead. +As of version 9.3, the behavior of the @code{fluid-let} special form +has changed, allowing other threads to see the dynamic values of its +variables. It is now implemented by @code{dynamic-wind} and will +restore its variables' original values when its body is exited, and +re-instate the dynamic values when its body is re-entered. +Thread-local values are implemented now only by @code{parameter} or +@code{fluid} objects. (@xref{Dynamic Binding}.) @deffn {special form} fluid-let ((@var{variable} @var{init}) @dots{}) expression expression @dots{} @cindex variable binding, fluid-let @@ -524,11 +525,10 @@ any of the @var{variable}s are unbound. However, because @findex let @findex let* @findex letrec -@findex fluid-let Definitions are valid in some but not all contexts where expressions are allowed. Definitions may only occur at the top level of a program and at the beginning of a lambda body (that is, the body of a @code{lambda}, -@code{let}, @code{let*}, @code{letrec}, @code{fluid-let}, or ``procedure +@code{let}, @code{let*}, @code{letrec} or ``procedure @code{define}'' expression). A definition that occurs at the top level of a program is called a @dfn{top-level definition}, and a definition that occurs at the beginning of a body is called an @dfn{internal @@ -617,11 +617,10 @@ bar @error{} Unassigned variable @findex let @findex let* @findex letrec -@findex fluid-let @findex define An @dfn{internal definition} is a definition that occurs at the beginning of a @var{body} (that is, the body of a @code{lambda}, -@code{let}, @code{let*}, @code{letrec}, @code{fluid-let}, or ``procedure +@code{let}, @code{let*}, @code{letrec} or ``procedure @code{define}'' expression), rather than at the top level of a program. The variable defined by an internal definition is local to the @var{body}. That is, @var{variable} is bound rather than assigned, and @@ -1109,7 +1108,6 @@ case cond define @r{;``procedure @code{define}'' only} do -fluid-let lambda let let* @@ -1121,7 +1119,6 @@ named-lambda @findex cond @findex define @findex do -@findex fluid-let @findex lambda @findex let @findex let* diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index 919dd9cc2..b9a590327 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -2603,7 +2603,7 @@ coherent) or must signal an error. For example, the assignment will cause the system to go to each compiled procedure that calls @code{newline} and update its execute cache to call the new procedure. Obviously you want to avoid updating hundreds of execute caches in a -critical loop. Using @code{fluid-let} to temporarily redefine a +critical loop. Using @code{dynamic-wind} to temporarily redefine a procedure has the same inefficiency (but twice!). To behave correctly in all situations, each variable reference or diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index 505264ab1..3131cd9e1 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -438,8 +438,14 @@ USA. (lambda (dynamic-state block-thread-events? interrupt-mask) (parser/%stack-marker dynamic-state block-thread-events? interrupt-mask type elements state)))) - (cond ((eq? marker-type %translate-to-state-point) - (continue (merge-dynamic-state + (cond ((eq? marker-type 'EXTEND-DYNAMIC-ENVIRONMENT) + (continue (merge-dynamic-environment + (parser-state/dynamic-state state) + marker-instance) + (parser-state/block-thread-events? state) + (parser-state/interrupt-mask state))) + ((eq? marker-type 'DYNAMIC-WIND) + (continue (merge-dynamic-point (parser-state/dynamic-state state) marker-instance) (parser-state/block-thread-events? state) diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 1bc0ca511..02859501e 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -30,9 +30,6 @@ USA. (declare (usual-integrations)) -;; The current thread's fluid and parameter bindings. -(define bindings '()) - ;;;; Fluids (define-structure fluid @@ -44,19 +41,18 @@ USA. (define (fluid f) (guarantee-fluid f 'FLUID) - (let ((entry (assq f bindings))) + (let ((entry (assq f (the-dynamic-environment)))) (if entry (cdr entry) (fluid-value f)))) (define (set-fluid! f val) (guarantee-fluid f 'SET-FLUID!) - (let ((entry (assq f bindings))) + (let ((entry (assq f (the-dynamic-environment)))) (if entry (set-cdr! entry val) (set-fluid-value! f val)))) (define (let-fluid fluid value thunk) (guarantee-fluid fluid 'LET-FLUID) (guarantee-thunk thunk 'LET-FLUID) - (fluid-let ((bindings (cons (cons fluid value) bindings))) - (thunk))) + (with-extended-dynamic-environment (list (cons fluid value)) thunk)) (define (let-fluids . args) (let loop ((args args) @@ -64,8 +60,7 @@ USA. (if (null? (cdr args)) (begin (guarantee-thunk (car args) 'LET-FLUIDS) - (fluid-let ((bindings (append! new-bindings bindings))) - ((car args)))) + (with-extended-dynamic-environment new-bindings (car args))) (begin (guarantee-fluid (car args) 'LET-FLUIDS) (loop (cddr args) @@ -87,7 +82,7 @@ USA. (if (not (default-object? converter)) (guarantee-procedure-of-arity converter 1 'MAKE-PARAMETER)) (make-entity (lambda (self) - (let ((entry (assq self bindings))) + (let ((entry (assq self (the-dynamic-environment)))) (if entry (cdr entry) (%parameter-value (entity-extra self))))) @@ -102,7 +97,7 @@ USA. (guarantee-parameter p 'PARAMETER-SET!) (let ((%p (entity-extra p))) (let ((%v ((%parameter-converter %p) v)) - (entry (assq p bindings))) + (entry (assq p (the-dynamic-environment)))) (if entry (set-cdr! entry %v) (set-%parameter-value! %p %v))))) @@ -125,11 +120,10 @@ USA. (parameterize* (list EXTENSION ...) (lambda () BODY ...))))) (define (parameterize* new-bindings thunk) - (fluid-let - ((bindings - (let loop ((new new-bindings)) + (with-extended-dynamic-environment + (let loop ((new new-bindings)) (if (null? new) - bindings + '() (if (and (pair? new) (pair? (car new))) (let ((p (caar new)) @@ -141,5 +135,5 @@ USA. (cons p* ((parameter-converter p*) v)))) (loop (cdr new)))) (error:wrong-type-argument - new-bindings "alist" 'parameterize*)))))) - (thunk))) \ No newline at end of file + new-bindings "alist" 'parameterize*)))) + thunk)) \ No newline at end of file diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 5790243a0..5a4823df8 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -134,7 +134,7 @@ USA. (let ((value* value)) (set! value (get-component object)) (set-component! object value*))) - (shallow-fluid-bind swap! thunk swap!))) + (dynamic-wind swap! thunk swap!))) (define bind-cell-contents! (object-component-binder cell-contents set-cell-contents!)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 32191c2c3..2fc1282a7 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -431,7 +431,8 @@ USA. '( ;; Microcode interface ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!) - (RUNTIME STATE-SPACE) + ((RUNTIME THREAD) INITIALIZE-LOW!) + (RUNTIME WIND) (RUNTIME APPLY) (RUNTIME HASH) ; First GC daemon! (RUNTIME PRIMITIVE-IO) @@ -477,8 +478,7 @@ USA. ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!) ;; Floating-point environment -- needed by threads. (RUNTIME FLOATING-POINT-ENVIRONMENT) - ;; Threads - (RUNTIME THREAD) + ((RUNTIME THREAD) INITIALIZE-HIGH!) ;; I/O (RUNTIME PORT) (RUNTIME OUTPUT-PORT) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index a99db4161..518d63fe4 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -613,7 +613,7 @@ USA. (r-lambda (rename 'LAMBDA)) (r-let (rename 'LET)) (r-set! (rename 'SET!)) - (r-shallow-fluid-bind (rename 'SHALLOW-FLUID-BIND)) + (r-dynamic-wind (rename 'DYNAMIC-WIND)) (r-unspecific (rename 'UNSPECIFIC))) (let ((temporaries (map (lambda (lhs) @@ -629,7 +629,7 @@ USA. left-hand-sides temporaries) ,r-unspecific) - (,r-shallow-fluid-bind ,swap! ,body ,swap!))))))) + (,r-dynamic-wind ,swap! ,body ,swap!))))))) (define-syntax :local-declare (er-macro-transformer diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 500cb5d2f..c18b6067c 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4488,23 +4488,25 @@ USA. )) )) -(define-package (runtime state-space) +(define-package (runtime wind) (files "wind") (parent (runtime)) (export () dynamic-wind shallow-fluid-bind) + (import (runtime thread) + thread/dynamic-environment + thread/dynamic-point + set-thread/dynamic-environment! + set-thread/dynamic-point!) (export (runtime continuation) get-dynamic-state set-dynamic-state!) (export (runtime continuation-parser) - %translate-to-state-point - merge-dynamic-state) + merge-dynamic-environment + merge-dynamic-point) (export (runtime thread) - current-state-point - make-state-space - state-space:local - translate-to-state-point) + dynamic-unwind) (initialization (initialize-package!))) (define-package (runtime dynamic) @@ -4524,7 +4526,10 @@ USA. set-parameter! parameterize parameter-converter - parameterize*)) + parameterize*) + (import (runtime wind) + the-dynamic-environment + with-extended-dynamic-environment)) (define-package (runtime stream) (files "stream") diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 902bbcf1d..a550f98ae 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -65,9 +65,11 @@ USA. ;; joined threads can get it. If the thread has been detached, ;; this field holds a condition of type THREAD-DETACHED. - (root-state-point #f) - ;; Root state-point of the local state space of the thread. Used to - ;; unwind the thread's state space when it is exited. + (dynamic-point #f) + ;; The dynamic-wind point of the thread. + + (dynamic-environment '()) + ;; The bindings of fluids and parameters. (floating-point-environment #f) ;; A floating-point environment descriptor, or #T if the thread is @@ -97,25 +99,31 @@ USA. (define next-scheduled-timeout) (define root-continuation-default) -(define (initialize-package!) +(define (initialize-low!) + ;; Called early in the cold load to create the first thread. (set! root-continuation-default (make-fluid #f)) - (initialize-error-conditions!) (set! thread-population (make-population)) (set! first-running-thread #f) (set! last-running-thread #f) (set! next-scheduled-timeout #f) (set! timer-records #f) (set! timer-interval 100) + (let ((first (%make-thread))) + (set-thread/exit-value! first detached-thread-marker) + (add-to-population!/unsafe thread-population first) + (set! first-running-thread first) + (set! last-running-thread first))) + +(define (initialize-high!) + ;; Called later in the cold load, when more of the runtime is initialized. + (initialize-error-conditions!) (initialize-io-blocking) (add-event-receiver! event:after-restore initialize-io-blocking) - (detach-thread (make-thread #f)) (add-event-receiver! event:before-exit stop-thread-timer)) (define (make-thread continuation) (let ((thread (%make-thread))) (set-thread/continuation! thread continuation) - (set-thread/root-state-point! thread - (current-state-point state-space:local)) (add-to-population!/unsafe thread-population thread) (thread-running thread) thread)) @@ -144,16 +152,15 @@ USA. (lambda (return) (%within-continuation root-continuation #t (lambda () - (fluid-let ((state-space:local (make-state-space))) - (call-with-current-continuation - (lambda (continuation) - (let ((thread (make-thread continuation))) - (%within-continuation (let ((k return)) (set! return #f) k) - #t - (lambda () thread))))) - (set-interrupt-enables! interrupt-mask/all) - (exit-current-thread - (with-create-thread-continuation root-continuation thunk))))))))) + (call-with-current-continuation + (lambda (continuation) + (let ((thread (make-thread continuation))) + (%within-continuation (let ((k return)) (set! return #f) k) + #t + (lambda () thread))))) + (set-interrupt-enables! interrupt-mask/all) + (exit-current-thread + (with-create-thread-continuation root-continuation thunk)))))))) (define (create-thread-continuation) (fluid root-continuation-default)) @@ -354,7 +361,7 @@ USA. (set-interrupt-enables! interrupt-mask/gc-ok) (set-thread/block-events?! thread #t) (ring/discard-all (thread/pending-events thread)) - (translate-to-state-point (thread/root-state-point thread)) + (dynamic-unwind thread) (%deregister-io-thread-events thread #t) (%discard-thread-timer-records thread) (%disassociate-joined-threads thread) @@ -444,34 +451,15 @@ USA. (define (wait-for-io) (%maybe-toggle-thread-timer #f) - (let ((catch-errors - (lambda (thunk) - (let ((thread (console-thread))) - (if thread - (bind-condition-handler '() - (lambda (condition) - (error:derived-thread thread condition)) - thunk) - (call-with-current-continuation - (lambda (k) - (bind-condition-handler '() - (lambda (condition) - condition - (within-continuation k thunk)) - thunk)))))))) (let ((result - (catch-errors - (lambda () + (begin (set-interrupt-enables! interrupt-mask/all) - (test-select-registry io-registry #t))))) + (test-select-registry io-registry #t)))) (set-interrupt-enables! interrupt-mask/gc-ok) (signal-select-result result) - (let ((thread first-running-thread)) - (if thread - (if (thread/continuation thread) - (run-thread thread) - (%maybe-toggle-thread-timer)) - (wait-for-io)))))) + (if first-running-thread + (run-thread first-running-thread) + (wait-for-io)))) (define (signal-select-result result) (cond ((vector? result) diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm index 30dbafac1..8d53aa839 100644 --- a/src/runtime/wind.scm +++ b/src/runtime/wind.scm @@ -24,196 +24,130 @@ USA. |# -;;;; State Space Model -;;; package: (runtime state-space) +;;;; Dynamic Windings +;;; package: (runtime wind) (declare (usual-integrations)) -;;; A STATE-SPACE is a tree of STATE-POINTs, except that the pointers -;;; in the tree point towards the root of the tree rather than its -;;; leaves. These pointers are the NEARER-POINT of each point. - -;;; Each point in the space has two procedures, TO-NEARER and -;;; FROM-NEARER. To move the root of the space to an adjacent point, -;;; one executes the FROM-NEARER of that point, then makes the -;;; TO-NEARER and FROM-NEARER of the old root be the FROM-NEARER and -;;; TO-NEARER of the new root, respectively. - -(define-integrable with-stack-marker - (ucode-primitive with-stack-marker 3)) - -(define-structure (state-space - (conc-name state-space/) - (constructor %make-state-space)) - nearest-point) - -(define (make-state-space) - (let ((space (%make-state-space '()))) - ;; Save the state space in the TO-NEARER field of the root point, - ;; because it is needed by %%TRANSLATE-TO-STATE-POINT. - (set-state-space/nearest-point! space (make-state-point #f space #f)) - space)) - -(define-integrable (guarantee-state-space space caller) - (if (not (state-space? space)) - (error:wrong-type-argument space "state space" caller))) - -(define-structure (state-point (conc-name state-point/)) - nearer-point - to-nearer - from-nearer) - -(define-integrable (guarantee-state-point point caller) - (if (not (state-point? point)) - (error:wrong-type-argument point "state point" caller))) - -(define (%execute-at-new-state-point space before during after) - (let ((old-root - (%without-interrupts - (lambda (interrupt-mask) - (let ((old-root (state-space/nearest-point space))) - (before) - ;; Don't trust BEFORE not to change the root; move back - ;; if it did. - (if (not (eq? old-root (state-space/nearest-point space))) - (%%translate-to-state-point old-root interrupt-mask)) - (let ((new-point (make-state-point #f space #f))) - (set-state-point/nearer-point! old-root new-point) - (set-state-point/to-nearer! old-root before) - (set-state-point/from-nearer! old-root after) - (set-state-space/nearest-point! space new-point)) - old-root))))) - (let ((value - (with-stack-marker during %translate-to-state-point old-root))) - (%translate-to-state-point old-root) - value))) - -(define (%translate-to-state-point point) - (%without-interrupts - (lambda (interrupt-mask) - (%%translate-to-state-point point interrupt-mask)))) - -(define (%%translate-to-state-point point interrupt-mask) - (let find-nearest ((point point) (chain '())) - (let ((nearer-point (state-point/nearer-point point))) - (if nearer-point - (find-nearest nearer-point (cons point chain)) - (let ((space (state-point/to-nearer point))) - (let traverse-chain ((old-root point) (chain chain)) - (if (not (null? chain)) - (let ((new-root (car chain))) - ;; Move to NEW-ROOT. - (let ((to-nearer (state-point/to-nearer new-root)) - (from-nearer (state-point/from-nearer new-root))) - (set-state-point/nearer-point! old-root new-root) - (set-state-point/to-nearer! old-root from-nearer) - (set-state-point/from-nearer! old-root to-nearer) - (set-state-point/nearer-point! new-root #f) - (set-state-point/to-nearer! new-root space) - (set-state-point/from-nearer! new-root #f) - (set-state-space/nearest-point! space new-root) - (with-stack-marker from-nearer - set-interrupt-enables! interrupt-mask)) - ;; Disable interrupts again in case FROM-NEARER - ;; re-enabled them. - (set-interrupt-enables! interrupt-mask) - ;; Make sure that NEW-ROOT is still the root, - ;; because FROM-NEARER might have moved it. If - ;; it has been moved, find the new root, and - ;; adjust CHAIN as needed. - (let find-root ((chain chain)) - (let ((nearer-point - (state-point/nearer-point (car chain)))) - (cond ((not nearer-point) - ;; (CAR CHAIN) is the root. - (traverse-chain (car chain) (cdr chain))) - ((and (not (null? (cdr chain))) - (eq? nearer-point (cadr chain))) - ;; The root has moved along CHAIN. - (find-root (cdr chain))) - (else - ;; The root has moved elsewhere. - (find-nearest nearer-point - chain))))))))))))) - -(define (%without-interrupts procedure) - (with-limited-interrupts interrupt-mask/gc-ok - (lambda (interrupt-mask) - (procedure (fix:and interrupt-mask interrupt-mask/gc-ok))))) - -(define (current-state-point space) - (guarantee-state-space space 'CURRENT-STATE-POINT) - (state-space/nearest-point space)) - -(define (execute-at-new-state-point space before during after) - (guarantee-state-space space 'EXECUTE-AT-NEW-STATE-POINT) - (%execute-at-new-state-point space before during after)) - -(define (translate-to-state-point point) - (guarantee-state-point point 'TRANSLATE-TO-STATE-POINT) - (%translate-to-state-point point)) - -(define (state-point/space point) - (guarantee-state-point point 'STATE-POINT/SPACE) - (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok))) - (let loop ((point point)) - (let ((nearer-point (state-point/nearer-point point))) - (if nearer-point - (loop nearer-point) - (begin - (set-interrupt-enables! interrupt-mask) - point)))))) - -(define state-space:global) -(define state-space:local) - -(define (shallow-fluid-bind before during after) - (%execute-at-new-state-point state-space:global before during after)) +;;; This dynamic-wind follows the example of Scheme48's +;;; multiprocessing-friendly implementation, which credits Pavel +;;; Curtis and Scheme Xerox as its inspiration. The earlier, +;;; uniprocessor-only implementation (of the Hanson/Lamping algorithm) +;;; can be found on the release-9.2 branch. + +;;; A continuation's dynamic state is two part: the stack of +;;; dynamic-wind points, and the dynamic environment (a stack of +;;; dynamic bindings). These stacks become trees when continuations +;;; are invoked multiple times. Both trees are read-only. The trees +;;; are separate so that the debugger can set-dynamic-state! with +;;; global-only? true. This allows fluid values to be inspected +;;; without unwinding dynamic-wind points. Otherwise with-extended- +;;; dynamic-environment might have been implemented in terms of +;;; dynamic-wind. (define (dynamic-wind before during after) - (let ((fluid-bindings (state-space/nearest-point state-space:global))) + (let ((fluid-bindings (thread/dynamic-environment (current-thread)))) (%execute-at-new-state-point - state-space:local (lambda () - (%translate-to-state-point fluid-bindings) + (set-thread/dynamic-environment! (current-thread) fluid-bindings) (before)) during (lambda () - (%translate-to-state-point fluid-bindings) + (set-thread/dynamic-environment! (current-thread) fluid-bindings) (after))))) -(define (initialize-package!) - (set! state-space:global (make-state-space)) - (set! state-space:local (make-state-space)) - unspecific) +(define (shallow-fluid-bind before thunk after) + ;; This is just temporary, to avoid hacking the fluid-let macro on + ;; your host, which probably expands fluid-lets into applications of + ;; shallow-fluid-bind (a free variable). + (dynamic-wind before thunk after)) + +(define-integrable with-stack-marker + (ucode-primitive with-stack-marker 3)) +(define-structure (state-point (conc-name state-point/)) + depth + before + after + env + parent) + +(define (%execute-at-new-state-point before during after) + (let ((thread (current-thread))) + (let ((here (thread/dynamic-point thread)) + (env (thread/dynamic-environment thread))) + (before) + ;; Don't trust BEFORE not to change the root; move back if it did. + (travel-to-point! thread (thread/dynamic-point thread) here) + (set-thread/dynamic-environment! thread env) + (set-thread/dynamic-point! thread + (make-state-point + (if here + (1+ (state-point/depth here)) + 1) + before after env here)) + (let ((value + (with-stack-marker during 'DYNAMIC-WIND here))) + (travel-to-point! thread (thread/dynamic-point thread) here) + (set-thread/dynamic-environment! thread env) + (set-thread/dynamic-point! thread here) + value)))) + +(define (dynamic-unwind thread) + (travel-to-point! thread (thread/dynamic-point thread) #f) + (set-thread/dynamic-point! thread #f) + (set-thread/dynamic-environment! thread '())) + +(define (travel-to-point! thread here target) + (cond ((eq? here target) 'done) + ((or (not here) ; HERE has reached the root. + (and target + (< (state-point/depth here) + (state-point/depth target)))) + (travel-to-point! thread here (state-point/parent target)) + ((state-point/before target)) + (set-thread/dynamic-environment! thread (state-point/env target)) + (set-thread/dynamic-point! thread target)) + (else + (set-thread/dynamic-environment! thread (state-point/env here)) + (set-thread/dynamic-point! thread here) + ((state-point/after here)) + (travel-to-point! thread (state-point/parent here) target)))) + +(define (the-dynamic-environment) + (thread/dynamic-environment (current-thread))) + +(define (with-extended-dynamic-environment extension thunk) + (let* ((thread (current-thread)) + (env (thread/dynamic-environment thread))) + (set-thread/dynamic-environment! + thread + (append! extension (thread/dynamic-environment thread))) + (let ((val (with-stack-marker thunk 'EXTEND-DYNAMIC-ENVIRONMENT env))) + (set-thread/dynamic-environment! thread env) + val))) + (define-structure (dynamic-state (conc-name dynamic-state/)) - (global #f read-only #t) - (local #f read-only #t)) + (point #f read-only #t) + (environment #f read-only #t)) (define (get-dynamic-state) - (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok))) - (let ((state - (make-dynamic-state - (state-space/nearest-point state-space:global) - (state-space/nearest-point state-space:local)))) - (set-interrupt-enables! interrupt-mask) - state))) + (let ((thread (current-thread))) + (make-dynamic-state (thread/dynamic-point thread) + (thread/dynamic-environment thread)))) (define (set-dynamic-state! state global-only?) (if (not (dynamic-state? state)) (error:wrong-type-argument state "dynamic state" 'SET-DYNAMIC-STATE!)) - (if (not global-only?) - (%translate-to-state-point (dynamic-state/local state))) - (%translate-to-state-point (dynamic-state/global state))) - -(define (merge-dynamic-state state point) - (let ((space (state-point/space point)) - (global (dynamic-state/global state)) - (local (dynamic-state/local state))) - (cond ((eq? space (state-point/space global)) - (make-dynamic-state point local)) - ((eq? space (state-point/space local)) - (make-dynamic-state global point)) - (else - state)))) \ No newline at end of file + (let ((thread (current-thread))) + (if (not global-only?) + (let ((there (dynamic-state/point state))) + (travel-to-point! thread (thread/dynamic-point thread) there) + (set-thread/dynamic-point! thread there))) + (set-thread/dynamic-environment! thread (dynamic-state/environment state)))) + +(define (merge-dynamic-environment state env) + (make-dynamic-state (dynamic-state/point state) env)) + +(define (merge-dynamic-point state point) + (make-dynamic-state point (dynamic-state/environment state))) \ No newline at end of file