Using non-mutating tree of dynamic-wind state for thread safety.

eval.c

@@ -499,7 +499,9 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
       sexp_context_dk(res) = sexp_context_dk(ctx);
       sexp_gc_release1(ctx);
     } else {
-      sexp_context_dk(res) = sexp_list1(res, SEXP_FALSE);
+      /* TODO: make the root a global (with friendly error in/out) */
+      sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE);
+      sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO);
     }
   }
   return res;

lib/init-7.scm

@@ -579,36 +579,60 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; dynamic-wind
 
+(define make-point vector)
+(define (point-depth point) (vector-ref point 0))
+(define (point-in point) (vector-ref point 1))
+(define (point-out point) (vector-ref point 2))
+(define (point-parent point) (vector-ref point 3))
+
+(define root-point			; Shared among all state spaces
+  (make-point 0
+	      (lambda () (error "winding in to root!"))
+	      (lambda () (error "winding out of root!"))
+	      #f))
+
 (cond-expand
  (threads)
  (else
   (define %dk
-    (let ((dk (list #f)))
+    (let ((dk root-point))
       (lambda o (if (pair? o) (set! dk (car o)) dk))))))
 
-(define (dynamic-wind before thunk after)
+(%dk root-point)
-  (let ((dk (%dk)))
-    (set-dk! (cons (cons before after) dk))
-    (let ((res (thunk))) (set-dk! dk) res)))
 
-;; TODO: Implement a non-mutating tree oriented stack so we don't need
+(define (dynamic-wind in body out)
-;; to reset the stack in child threads.
+  (in)
-(define (set-dk! new-dk)
+  (let ((here (%dk)))
-  (if (not (eq? new-dk (%dk)))
+    (%dk (make-point (+ (point-depth here) 1)
-      (begin
+                     in
-        (set-dk! (cdr new-dk))
+                     out
-        (let ((before (car (car new-dk)))
+                     here))
-	      (old-dk (%dk)))
+    (let ((res (body)))
-          (set-car! old-dk (cons (cdr (car new-dk)) before))
+      (%dk here)
-          (set-cdr! old-dk new-dk)
+      (out)
-          (set-car! new-dk #f)
+      res)))
-          (set-cdr! new-dk '())
+
-          (%dk new-dk)
+(define (travel-to-point! here target)
-          (before)))))
+  (cond
+   ((eq? here target)
+    'done)
+   ((< (point-depth here) (point-depth target))
+    (travel-to-point! here (point-parent target))
+    ((point-in target)))
+   (else
+    ((point-out here))
+    (travel-to-point! (point-parent here) target))))
+
+(define (continuation->procedure cont point)
+  (lambda res
+    (travel-to-point! (%dk) point)
+    (%dk point)
+    (cont (%values res))))
 
 (define (call-with-current-continuation proc)
-  (let ((dk (%dk)))
+  (%call/cc
-    (%call/cc (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
+   (lambda (cont)
+     (proc (continuation->procedure cont (%dk))))))
 
 (define (with-input-from-file file thunk)
   (let ((old-in (current-input-port))
@@ -932,13 +956,10 @@
                 (lambda (handler-k)
                   (let* ((var condition)            ; clauses may set! var
                          (res
-                          (with-exception-handler
-                           orig-handler
-                           (lambda ()
                           (guard-aux
                            (handler-k (lambda ()
                                         (raise-continuable condition)))
-                              clause ...)))))
+                           clause ...)))
                     (guard-k (lambda () res)))))))
             (lambda ()
               (let ((res (begin e1 e2 ...)))