From cbbeef25cfa1a4cf49e2084be07bec15d691336b Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 8 Jul 2015 13:45:06 -0700 Subject: [PATCH] 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 uniprocessor-only Hanson/Lamping state-spaces with Scheme48's multiprocessing-friendly dynamic-points in a new package (runtime wind). Replace the previously fluid-assigned bindings state-space:local and (runtime dynamic)bindings with thread slots dynamic-point and dynamic- environment. Lose the error handling in wait-for-io; it runs when there is no current thread, thus no way to bind-condition-handler. --- doc/ref-manual/misc-datatypes.texi | 8 +- doc/ref-manual/overview.texi | 27 ++- doc/ref-manual/special-forms.texi | 32 ++-- doc/user-manual/user.texinfo | 2 +- src/runtime/conpar.scm | 12 +- src/runtime/dynamic.scm | 28 ++- src/runtime/global.scm | 2 +- src/runtime/make.scm | 3 +- src/runtime/mit-macros.scm | 4 +- src/runtime/runtime.pkg | 22 ++- src/runtime/thread.scm | 75 +++----- src/runtime/wind.scm | 286 +++++++++++------------------ 12 files changed, 211 insertions(+), 290 deletions(-) diff --git a/doc/ref-manual/misc-datatypes.texi b/doc/ref-manual/misc-datatypes.texi index 6e843993b..31745ed94 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..6398f3618 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. +After version 9.2, the behavior of the @code{fluid-let} special form +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 @@ -493,7 +494,7 @@ the last @var{expression} is returned. @findex let The syntax of this special form is similar to that of @code{let}, but -@code{fluid-let} temporarily rebinds existing variables. Unlike +@code{fluid-let} temporarily assigns existing variables. Unlike @code{let}, @code{fluid-let} creates no new bindings; instead it @emph{assigns} the value of each @var{init} to the binding (determined by the rules of lexical scoping) of its corresponding @var{variable}. @@ -507,6 +508,9 @@ any of the @var{variable}s are unbound. However, because @code{fluid-let} operates by means of side effects, it is valid for any @var{variable} to be unassigned when the form is entered. @findex condition-type:unbound-variable + +This special form is @strong{deprecated} as explained at the beginning +of this section. @end deffn @node Definitions, Assignments, Dynamic Binding, Special Forms @@ -524,11 +528,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 +620,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 +1111,6 @@ case cond define @r{;``procedure @code{define}'' only} do -fluid-let lambda let let* @@ -1121,7 +1122,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 1200bf1e5..ce16d5bd4 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -2541,7 +2541,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 52739fc16..9f8b865b2 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -438,16 +438,18 @@ 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 'SET-INTERRUPT-ENABLES!) - (continue (parser-state/dynamic-state state) + ((eq? marker-type 'DYNAMIC-WIND) + (continue (merge-dynamic-point + (parser-state/dynamic-state state) + marker-instance) (parser-state/block-thread-events? state) - marker-instance)) + (parser-state/interrupt-mask state))) ((eq? marker-type 'WITH-THREAD-EVENTS-BLOCKED) (continue (parser-state/dynamic-state state) marker-instance diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 42f598051..839257a8e 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 d8111541a..02dae7738 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 20e3be250..e6c1dbbad 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -373,7 +373,7 @@ USA. '(("syntax-items" . (RUNTIME SYNTAX ITEMS)) ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS)) ("thread" . (RUNTIME THREAD)) - ("wind" . (RUNTIME STATE-SPACE)) + ("wind" . (RUNTIME WIND)) ("prop1d" . (RUNTIME 1D-PROPERTY)) ("events" . (RUNTIME EVENT-DISTRIBUTOR)) ("gdatab" . (RUNTIME GLOBAL-DATABASE)) @@ -395,7 +395,6 @@ USA. (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t) (load-files files2) (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population. - (package-initialize '(RUNTIME STATE-SPACE) #f #t) (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table. (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t) (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 6f0385aaf..10aa1a296 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -636,7 +636,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) @@ -652,7 +652,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 1798fd873..c1f0b0c4e 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4544,24 +4544,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) - (initialization (initialize-package!))) + dynamic-unwind)) (define-package (runtime dynamic) (files "dynamic") @@ -4580,7 +4581,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 44b37dc28..ccac4b395 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -68,9 +68,15 @@ 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. + + (root-dynamic-state #f) + ;; Root dynamic-state of the thread. Used to unwind the thread's + ;; dynamic state when it exits. (floating-point-environment #f) ;; A floating-point environment descriptor, or #T if the thread is @@ -112,8 +118,6 @@ USA. (reset-threads-low!) (let ((first (%make-thread (make-1d-table/unsafe)))) (set-thread/exit-value! first detached-thread-marker) - (set-thread/root-state-point! first - (current-state-point state-space:local)) (add-to-population!/unsafe thread-population first) (%thread-running first))) @@ -160,8 +164,8 @@ USA. (define (make-thread continuation) (let ((thread (%make-thread (make-1d-table)))) (set-thread/continuation! thread continuation) - (set-thread/root-state-point! thread - (current-state-point state-space:local)) + (set-thread/root-dynamic-state! thread + (continuation/dynamic-state continuation)) (add-to-population! thread-population thread) (thread-running thread) thread)) @@ -215,16 +219,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)) @@ -426,7 +429,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 (thread/root-dynamic-state thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%deregister-subprocess-events thread) @@ -511,34 +514,14 @@ 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 () - (set-interrupt-enables! interrupt-mask/all) - (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)))))) + (let ((result (begin + (set-interrupt-enables! interrupt-mask/all) + (test-select-registry io-registry #t)))) + (set-interrupt-enables! interrupt-mask/gc-ok) + (signal-select-result result) + (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 70e113a66..7b61c244c 100644 --- a/src/runtime/wind.scm +++ b/src/runtime/wind.scm @@ -24,196 +24,132 @@ 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. - ((ucode-primitive set-interrupt-enables! 1) 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 +;;; thread-switch? 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 root-state) + (let ((point (dynamic-state/point root-state)) + (env (dynamic-state/environment root-state))) + (travel-to-point! thread (thread/dynamic-point thread) point) + (set-thread/dynamic-environment! thread env) + (set-thread/dynamic-point! thread point))) + +(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))) - -(define (set-dynamic-state! state global-only?) + (let ((thread (current-thread))) + (make-dynamic-state (thread/dynamic-point thread) + (thread/dynamic-environment thread)))) + +(define (set-dynamic-state! state thread-switch?) (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)) + (there (dynamic-state/point state))) + (if (not thread-switch?) + (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 -- 2.25.1