Clobber fluid-let and the (runtime state-space) package.
authorMatt Birkholz <puck@birchwood-abbey.net>
Wed, 8 Jul 2015 20:45:06 +0000 (13:45 -0700)
committerMatt Birkholz <puck@birchwood-abbey.net>
Wed, 8 Jul 2015 20:45:06 +0000 (13:45 -0700)
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.

12 files changed:
doc/ref-manual/misc-datatypes.texi
doc/ref-manual/overview.texi
doc/ref-manual/special-forms.texi
doc/user-manual/user.texinfo
src/runtime/conpar.scm
src/runtime/dynamic.scm
src/runtime/global.scm
src/runtime/make.scm
src/runtime/mit-macros.scm
src/runtime/runtime.pkg
src/runtime/thread.scm
src/runtime/wind.scm

index 29b2cf0907c6ee26b2804baad181b5109d94037e..faad58b296a238856b3783413d9acd5f4442ddfe 100644 (file)
@@ -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
index a3adda9523be364b7bcdd9d0e24b3d6aacb6d670..fb6688bb3ec703511698ef6c76606cad1efe116e 100644 (file)
@@ -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
index 974facbb8ab8852d0803e2a742fc7caade5ecea3..6398f3618cf8ab5993120886948b912590983480 100644 (file)
@@ -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*
index 7ddc5f3b8a88eb81c20bad8c54843d68ac9b101f..4f471a62afcbba4ecbe160c97aef640c66274158 100644 (file)
@@ -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
index bf13ae904c3aa5228f0c46b4d54119ce131a615b..6f1cc08d0cc529dd30c75fa9b9fdb92ac11893b1 100644 (file)
@@ -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
index 1bc0ca511743d7f41d8fb81800cc89dc25965395..02859501e34073252a9228fdc159bd3610152384 100644 (file)
@@ -30,9 +30,6 @@ USA.
 (declare (usual-integrations))
 \f
 
-;; 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
index 98435c3279f6a7f7a65f108d861efd72551ac2c1..9fa64956e22ee2da3a5d38257aed78cc4595dfc1 100644 (file)
@@ -131,7 +131,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!))
index 8698ddba6b4e6ca4626f4503f642f4d898b443b4..4fdef37bfc5e0b7c79ddbe0bd702fb49badb65b3 100644 (file)
@@ -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)
index a99db41614cbc5741f97808c42d92210643be178..518d63fe4d9ba7f623554211ea83a5e417bbbf25 100644 (file)
@@ -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
index 1fd7fa244eafa1b680322d0c26118649e83e4e3b..627b2af9d9136b9dfd7c6e8e87e0beeee266b941 100644 (file)
@@ -4515,24 +4515,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")
@@ -4551,7 +4552,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")
index 591819386d999e55a6e904cb3ee2aede02653eb7..46f933411b7f16e5f59a501b706fb34c1fee65f5 100644 (file)
@@ -83,9 +83,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
@@ -126,8 +132,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)))
 
@@ -174,8 +178,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))
@@ -204,16 +208,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))
@@ -414,7 +417,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)
@@ -499,32 +502,11 @@ 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 ()
-             (test-select-registry io-registry #t)))))
-      (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 (test-select-registry io-registry #t)))
+    (signal-select-result result)
+    (if first-running-thread
+       (run-thread first-running-thread)
+       (wait-for-io))))
 \f
 (define (signal-select-result result)
   (cond ((vector? result)
index 9d5a6b40e693bcd11324f9adc341ac8914f0ef76..d3a8ada15a72ed547d2088857252c04d844cb804 100644 (file)
@@ -24,200 +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)))
-\f
-(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)))))
-\f
-(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
-        (set-interrupt-enables! (fix:and (get-interrupt-enables)
-                                         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)))
+\f
 (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
-        (set-interrupt-enables! (fix:and (get-interrupt-enables)
-                                         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