From 2e63b2be004e125e0df635af028fb272a0efde81 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 7 Apr 2013 23:59:41 +0900
Subject: [PATCH] Using non-mutating tree of dynamic-wind state for thread
 safety.

---
 eval.c         |  4 ++-
 lib/init-7.scm | 77 ++++++++++++++++++++++++++++++++------------------
 2 files changed, 52 insertions(+), 29 deletions(-)

diff --git a/eval.c b/eval.c
index 8705578c..188df9a5 100644
--- a/eval.c
+++ b/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;
diff --git a/lib/init-7.scm b/lib/init-7.scm
index 9150f93f..26a81dff 100644
--- a/lib/init-7.scm
+++ b/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)
-  (let ((dk (%dk)))
-    (set-dk! (cons (cons before after) dk))
-    (let ((res (thunk))) (set-dk! dk) res)))
+(%dk root-point)
 
-;; TODO: Implement a non-mutating tree oriented stack so we don't need
-;; to reset the stack in child threads.
-(define (set-dk! new-dk)
-  (if (not (eq? new-dk (%dk)))
-      (begin
-        (set-dk! (cdr new-dk))
-        (let ((before (car (car new-dk)))
-	      (old-dk (%dk)))
-          (set-car! old-dk (cons (cdr (car new-dk)) before))
-          (set-cdr! old-dk new-dk)
-          (set-car! new-dk #f)
-          (set-cdr! new-dk '())
-          (%dk new-dk)
-          (before)))))
+(define (dynamic-wind in body out)
+  (in)
+  (let ((here (%dk)))
+    (%dk (make-point (+ (point-depth here) 1)
+                     in
+                     out
+                     here))
+    (let ((res (body)))
+      (%dk here)
+      (out)
+      res)))
+
+(define (travel-to-point! here target)
+  (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 (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
+  (%call/cc
+   (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 ...)))))
+                          (guard-aux
+                           (handler-k (lambda ()
+                                        (raise-continuable condition)))
+                           clause ...)))
                     (guard-k (lambda () res)))))))
             (lambda ()
               (let ((res (begin e1 e2 ...)))