dynamic_wind: winders stored with thread context

Author: bksaiki

src/alloc.c

@@ -175,14 +175,15 @@ obj Msetb_continuation(obj prev, obj env, obj name) {
     return x;
 }
 
-obj Mcallcc_continuation(obj prev, obj env) {
+obj Mcallcc_continuation(obj prev, obj env, obj winders) {
     obj x = GC_malloc(Mcontinuation_callcc_size);
     obj_type(x) = CONTINUATON_OBJ_TYPE;
     Mcontinuation_type(x) = CALLCC_CONT_TYPE;
     Mcontinuation_immutablep(x) = 0;
     Mcontinuation_capturedp(x) = 0;
     Mcontinuation_prev(x) = prev;
     Mcontinuation_env(x) = env;
+    Mcontinuation_callcc_winders(x) = winders;
     return x;
 }
 
@@ -230,6 +231,7 @@ obj Mthread_context(void) {
     obj x = GC_malloc(Mtc_size);
     obj_type(x) = THREAD_OBJ_TYPE;
     Mtc_cc(x) = Mnull;
+    Mtc_wnd(x) = Mnull;
     Mtc_env(x) = Mnull;
     Mtc_vb(x) = GC_malloc(INIT_VALUES_BUFFER_LEN * sizeof(obj));
     Mtc_va(x) = INIT_VALUES_BUFFER_LEN;

src/continuation.c

@@ -74,7 +74,11 @@ obj continuation_mutable(obj k) {
 
         // call/cc expressions
         case CALLCC_CONT_TYPE:
-            k2 = Mcallcc_continuation(Mcontinuation_prev(k), Mcontinuation_env(k));
+            k2 = Mcallcc_continuation(
+                Mcontinuation_prev(k),
+                Mcontinuation_env(k),
+                Mcontinuation_callcc_winders(k)
+            );
             break;
 
         // dynamic-wind expressions
@@ -101,86 +105,84 @@ obj continuation_mutable(obj k) {
 }
 
 // Length of a continuation chain.
-static uptr continuation_length(obj k) {
-    uptr l = 0;
-    for (; Mcontinuationp(k); k = Mcontinuation_prev(k), ++l);
-    return l;
-}
-
-// Extracts the tail of a continuation chain.
-static obj continuation_tail(obj k, iptr l) {
-    for (uptr i = 0; i < l; ++i, k = Mcontinuation_prev(k));
-    return k;
-}
-
-// Extracts the common tail of two continuation chains.
-static obj common_tail(obj k1, obj k2) {
-    uptr l1, l2;
-
-    // eliminate excess frames
-    l1 = continuation_length(k1);
-    l2 = continuation_length(k2);
+// static uptr continuation_length(obj k) {
+//     uptr l = 0;
+//     for (; Mcontinuationp(k); k = Mcontinuation_prev(k), ++l);
+//     return l;
+// }
+
+// // Extracts the tail of a continuation chain.
+// static obj continuation_tail(obj k, iptr l) {
+//     for (uptr i = 0; i < l; ++i, k = Mcontinuation_prev(k));
+//     return k;
+// }
+
+// Extracts the common tail of two winder lists
+static obj common_tail(obj xs, obj ys) {
+    iptr l1, l2;
+
+    // eliminate excess winders
+    l1 = list_length(xs);
+    l2 = list_length(ys);
     if (l1 > l2) {
-        k1 = continuation_tail(k1, l1 - l2);
+        xs = list_tail(xs, l1 - l2);
     } else if (l2 > l1) {
-        k2 = continuation_tail(k2, l2 - l1);
+        ys = list_tail(ys, l2 - l1);
     }
 
-    // unwind both until a common ancestor is found
-    while (Mcontinuationp(k1)) {
-        if (k1 == k2)
-            return k1;
+    // walk back along tails until a common ancestor
+    while (!Mnullp(xs)) {
+        if (xs == ys)
+            return xs;
 
-        k1 = Mcontinuation_prev(k1);
-        k2 = Mcontinuation_prev(k2);
+        xs = Mcdr(xs);
+        ys = Mcdr(ys);
     }
 
-    return k1;
+    return xs;
 }
 
-// Restores a continuation.
-// The result is a new continuation chain formed by merging
-// the common ancestors of the continuation and current continuation.
-obj continuation_restore(obj cc, obj k) {
-    obj tl, it, cc_winders, k_winders, winders;
+// Restores a continuation. The continuation must have been captured
+// by `call/cc`. May add a continuation frame to handle any winders
+// installed by `dynamic-wind`.
+obj continuation_restore(obj tc, obj k) {
+    obj cc_winders, k_winders, tl, it, unwind, wind, winders;
 
     // check that continuation was captured by call/cc
     if (!Mcontinuation_capturedp(k)) {
         minim_error1("continuation_restore()", "can only restored captured continuations", k);
     }
 
-    
-    tl = common_tail(cc, k);
-    if (tl == k) {
-        // edge case: `tl` is just `k` so nothing to do
-        return tl;
+    // compute common tail of winders
+    cc_winders = Mtc_wnd(tc);
+    k_winders = Mcontinuation_callcc_winders(k);
+    tl = common_tail(cc_winders, k_winders);
+
+    // winders are the same, just restore the continuation
+    if (tl == k_winders) {
+        return k;
     }
-    
-    // unwind `cc` to the tail and restore `k`
-    // need to track winders and possibly create a continuation to execute them
-    cc_winders = Mnull;
-    for (it = cc; it != tl; it = Mcontinuation_prev(it)) {
-        if (Mcontinuation_dynwindp(it) && Mcontinuation_dynwind_state(it) == DYNWIND_VAL) {            
-            // unwinding active dynamic wind => need to execute post thunk
-            cc_winders = Mcons(Mcontinuation_dynwind_post(it), cc_winders);
-        }
+
+    // find all winders in `cc` that need to be unwound
+    unwind = Mnull;
+    for (it = cc_winders; it != tl; it = Mcdr(it)) {
+        // unwinding => need to execute post thunk
+        unwind = Mcons(Mcdar(it), unwind);
     }
 
-    k_winders = Mnull;
-    for (it = k; it != tl; it = Mcontinuation_prev(it)) {
-        if (Mcontinuation_dynwindp(cc) && Mcontinuation_dynwind_state(cc) == DYNWIND_VAL) {            
-            // restoring active dynamic wind => need to execute pre thunk
-            k_winders = Mcons(Mcontinuation_dynwind_pre(it), k_winders);
-        }
+    wind = Mnull;
+    for (it = k_winders; it != tl; it = Mcdr(it)) {
+        // winding => need to execute pre thunk
+        wind = Mcons(Mcaar(it), wind);
     }
 
-    // cc_winders first, in reverse order, then k_winders
-    winders = Mappend(Mreverse(cc_winders), k_winders);
+    // unwind, in reverse order, than wind
+    winders = Mappend(Mreverse(unwind), wind);
     if (!Mnullp(winders)) {
         // any winders => need to execute them before anything else
         k = Mwinders_continuation(k, Mcontinuation_env(k), winders);
     }
-   
+
     return k;
 }
 

src/eval.c

@@ -344,7 +344,7 @@ static obj eval_k(obj e) {
         } else if (hd == Mcallcc_symbol) {
             // call/cc
             continuation_set_immutable(Mtc_cc(tc)); // freeze the continuation chain
-            Mtc_cc(tc) = Mcallcc_continuation(Mtc_cc(tc), Mtc_env(tc));
+            Mtc_cc(tc) = Mcallcc_continuation(Mtc_cc(tc), Mtc_env(tc), Mtc_wnd(tc));
             e = Mcadr(e);
             goto loop;
         } else if (hd == Mcallwv_symbol) {
@@ -403,7 +403,7 @@ static obj eval_k(obj e) {
         Mtc_env(tc) = do_closure(f, args);
         goto loop;
     } else if (Mcontinuationp(f)) {
-        Mtc_cc(tc) = continuation_restore(Mtc_cc(tc), f);
+        Mtc_cc(tc) = continuation_restore(tc, f);
         x = do_values(args);
         goto do_k;
     } else {
@@ -466,6 +466,7 @@ static obj eval_k(obj e) {
     case CALLCC_CONT_TYPE:
         if (Mcontinuation_capturedp(Mtc_cc(tc))) {
             // restoring captured continuation
+            Mtc_wnd(tc) = Mcontinuation_callcc_winders(Mtc_cc(tc));
             Mtc_cc(tc) = Mcontinuation_prev(Mtc_cc(tc));
             goto do_k;
         } else {
@@ -525,6 +526,7 @@ static obj eval_k(obj e) {
 
     // dynamic-wind expressions
     case DYNWIND_CONT_TYPE:
+        Mtc_cc(tc) = continuation_mutable(Mtc_cc(tc));
         switch (Mcontinuation_dynwind_state(Mtc_cc(tc))) {
         // unevaluated dynamic-wind
         case DYNWIND_NEW:
@@ -561,8 +563,15 @@ static obj eval_k(obj e) {
 
         // evaluated pre thunk
         case DYNWIND_PRE:
-            assert_single_value(Mtc_cc(tc), x);
             Mcontinuation_dynwind_state(Mtc_cc(tc)) = DYNWIND_VAL;
+            Mtc_wnd(tc) = Mcons(
+                Mcons(
+                    Mcontinuation_dynwind_pre(Mtc_cc(tc)),
+                    Mcontinuation_dynwind_post(Mtc_cc(tc))
+                ),
+                Mtc_wnd(tc)
+            );
+    
             Mtc_env(tc) = Mcontinuation_env(Mtc_cc(tc));
             f = Mcontinuation_dynwind_val(Mtc_cc(tc));
             args = Mnull;
@@ -577,6 +586,7 @@ static obj eval_k(obj e) {
                 Mcontinuation_dynwind_val(Mtc_cc(tc)) = Mlist1(x);
             }
 
+            Mtc_wnd(tc) = Mcdr(Mtc_wnd(tc));
             Mcontinuation_dynwind_state(Mtc_cc(tc)) = DYNWIND_POST;
             Mtc_env(tc) = Mcontinuation_env(Mtc_cc(tc));
             f = Mcontinuation_dynwind_post(Mtc_cc(tc));

src/list.c

@@ -51,3 +51,8 @@ obj Mappend(obj x, obj y) {
         return hd;
     }
 }
+
+obj list_tail(obj x, iptr i) {
+    for (; i > 0; i--, x = Mcdr(x));
+    return x;
+}

src/minim.h

@@ -279,8 +279,9 @@ typedef enum {
 #define Mcontinuation_setbp(o)          (Mcontinuation_type(o) == SETB_CONT_TYPE)
 #define Mcontinuation_setb_name(o)      (*((obj*) ptr_add(o, 3 * ptr_size)))
 
-#define Mcontinuation_callcc_size           Mcontinuation_size(0)
+#define Mcontinuation_callcc_size           Mcontinuation_size(1)
 #define Mcontinuation_callccp(o)            (Mcontinuation_type(o) == CALLCC_CONT_TYPE)
+#define Mcontinuation_callcc_winders(o)     (*((obj*) ptr_add(o, 3 * ptr_size)))
 
 #define Mcontinuation_callwv_size               Mcontinuation_size(2)
 #define Mcontinuation_callwvp(o)                (Mcontinuation_type(o) == CALLWV_CONT_TYPE)
@@ -308,7 +309,7 @@ obj Mcond_continuation(obj prev, obj env, obj ift, obj iff);
 obj Mseq_continuation(obj prev, obj env, obj seq);
 obj Mlet_continuation(obj prev, obj env, obj bindings, obj body);
 obj Msetb_continuation(obj prev, obj env, obj name);
-obj Mcallcc_continuation(obj prev, obj env);
+obj Mcallcc_continuation(obj prev, obj env, obj winders);
 obj Mcallwv_continuation(obj prev, obj env, obj producer);
 obj Mdynwind_continuation(obj prev, obj env, obj val, obj post);
 obj Mwinders_continuation(obj prev, obj env, obj winders);
@@ -344,18 +345,20 @@ void port_write(int c, obj p);
 // +------------+
 // |    type    | [0, 1)
 // |    cc      | [8, 16)       // current continuation
-// |    env     | [16, 24)
-// |    vb      | [24, 32)      // values buffer
-// |    va      | [24, 32)      // values buffer allocation size
-// |    vc      | [32, 40)      // values buffer count
+// |   winders  | [16, 24)      // current winders
+// |    env     | [24, 32)      // current environment
+// |    vb      | [32, 40)      // values buffer
+// |    va      | [40, 48)      // values buffer allocation size
+// |    vc      | [48, 56)      // values buffer count
 // +------------+
-#define Mtc_size            (6 * ptr_size)
+#define Mtc_size            (7 * ptr_size)
 #define Mtcp(o)             (obj_type(o) == THREAD_OBJ_TYPE)
 #define Mtc_cc(o)           (*((obj*) ptr_add(o, ptr_size)))
-#define Mtc_env(o)          (*((obj*) ptr_add(o, 2 * ptr_size)))
-#define Mtc_vb(o)           (*((obj**) ptr_add(o, 3 * ptr_size)))
-#define Mtc_va(o)           (*((uptr*) ptr_add(o, 4 * ptr_size)))
-#define Mtc_vc(o)           (*((uptr*) ptr_add(o, 5 * ptr_size)))
+#define Mtc_wnd(o)          (*((obj*) ptr_add(o, 2 * ptr_size)))
+#define Mtc_env(o)          (*((obj*) ptr_add(o, 3 * ptr_size)))
+#define Mtc_vb(o)           (*((obj**) ptr_add(o, 4 * ptr_size)))
+#define Mtc_va(o)           (*((uptr*) ptr_add(o, 5 * ptr_size)))
+#define Mtc_vc(o)           (*((uptr*) ptr_add(o, 6 * ptr_size)))
 
 obj Mthread_context(void);
 
@@ -400,6 +403,7 @@ iptr list_length(obj x);
 obj Mlength(obj x);
 obj Mreverse(obj x);
 obj Mappend(obj x, obj y);
+obj list_tail(obj x, iptr i);
 
 // Continuations
 
@@ -413,10 +417,10 @@ void continuation_set_immutable(obj k);
 // Otherwise, the argument is returned.
 obj continuation_mutable(obj k);
 
-// Restores a continuation.
-// The result is a new continuation chain formed by merging
-// the common ancestors of the continuation and current continuation.
-obj continuation_restore(obj cc, obj k);
+// Restores a continuation. The continuation must have been captured
+// by `call/cc`. May add a continuation frame to handle any winders
+// installed by `dynamic-wind`.
+obj continuation_restore(obj tc, obj k);
 
 // For debugging
 void print_continuation(obj cc);