proper check for dead continuations

lib/error.c

@@ -43,7 +43,7 @@ pic_prepare_try(pic_state *pic)
   cxt->fp = NULL;
   cxt->sp = NULL;
   cxt->irep = NULL;
-
+  cxt->conts = pic_nil_value(pic);
   cxt->prev = pic->cxt;
   pic->cxt = cxt;
   return &cxt->jmp;
@@ -84,7 +84,11 @@ void
 pic_exit_try(pic_state *pic)
 {
   struct context *cxt = pic->cxt;
+  pic_value c, it;
   pic->dyn_env = pic_cdr(pic, pic->dyn_env);
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
   pic->cxt = cxt->prev;
   pic_free(pic, cxt);
   /* don't rewind ai here */
@@ -94,7 +98,11 @@ pic_value
 pic_abort_try(pic_state *pic)
 {
   struct context *cxt = pic->cxt;
+  pic_value c, it;
   pic_value err = cxt->sp->regs[1];
+  pic_for_each (c, cxt->conts, it) {
+    proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+  }
   pic->cxt = cxt->prev;
   pic_free(pic, cxt);
   pic_protect(pic, err);

lib/ext/cont.c

@@ -53,27 +53,27 @@ cont_call(pic_state *pic)
 {
   int argc;
   pic_value *argv, k, dyn_env;
-  struct context *cxt, *c;
+  struct context *cxt;
 
   pic_get_args(pic, "*", &argc, &argv);
 
-  cxt = pic_data(pic, pic_closure_ref(pic, 0));
-  k = pic_closure_ref(pic, 1);
-  dyn_env = pic_closure_ref(pic, 2);
-
-  /* check if continuation is alive */
-  for (c = pic->cxt; c != NULL; c = c->prev) {
-    if (c == cxt) {
-      break;
-    }
-  }
-  if (c == NULL) {
+  if (! pic_bool(pic, pic_closure_ref(pic, 0))) {
     pic_error(pic, "calling dead escape continuation", 0);
   }
 
+  cxt = pic_data(pic, pic_closure_ref(pic, 1));
+  k = pic_closure_ref(pic, 2);
+  dyn_env = pic_closure_ref(pic, 3);
+
   CONTEXT_INIT(pic, cxt, k, argc, argv);
 
-  pic->cxt = cxt;
+  while (pic->cxt != cxt) {
+    pic_value c, it;
+    pic_for_each (c, pic->cxt->conts, it) {
+      proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+    }
+    pic->cxt = pic->cxt->prev;
+  }
   pic->dyn_env = dyn_env;
 
   longjmp(cxt->jmp, 1);
@@ -84,7 +84,10 @@ pic_value
 pic_make_cont(pic_state *pic, pic_value k)
 {
   static const pic_data_type cxt_type = { "cxt", NULL };
-  return pic_lambda(pic, cont_call, 3, pic_data_value(pic, pic->cxt, &cxt_type), k, pic->dyn_env);
+  pic_value c;
+  c = pic_lambda(pic, cont_call, 4, pic_true_value(pic), pic_data_value(pic, pic->cxt, &cxt_type), k, pic->dyn_env);
+  pic->cxt->conts = pic_cons(pic, c, pic->cxt->conts);
+  return c;
 }
 
 static pic_value

lib/gc.c

@@ -329,6 +329,7 @@ gc_mark_phase(pic_state *pic)
     if (cxt->fp) gc_mark_object(pic, (struct object *)cxt->fp);
     if (cxt->sp) gc_mark_object(pic, (struct object *)cxt->sp);
     if (cxt->irep) gc_mark_object(pic, (struct object *)cxt->irep);
+    gc_mark(pic, cxt->conts);
   }
 
   /* arena */

lib/proc.c

@@ -567,6 +567,7 @@ pic_vm(pic_state *pic, struct context *cxt)
   assert(cxt->fp == NULL);
   assert(cxt->irep == NULL);
 
+  cxt->conts = pic_nil_value(pic);
   cxt->prev = pic->cxt;
   pic->cxt = cxt;
 
@@ -608,6 +609,10 @@ pic_vm(pic_state *pic, struct context *cxt)
 
   VM_LOOP {
     CASE(OP_HALT) {
+      pic_value c, it;
+      pic_for_each (c, pic->cxt->conts, it) {
+        proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
+      }
       pic->cxt = pic->cxt->prev;
       return;
     }

lib/state.c

@@ -177,6 +177,7 @@ pic_open(pic_allocf allocf, void *userdata)
   pic->default_cxt.sp = NULL;
   pic->default_cxt.irep = NULL;
   pic->default_cxt.prev = NULL;
+  pic->default_cxt.conts = pic_nil_value(pic);
   pic->cxt = &pic->default_cxt;
 
   /* arena */

lib/state.h

@@ -25,6 +25,7 @@ struct context {
   struct irep *irep;
 
   code_t tmpcode[2];
+  pic_value conts;
 
   struct context *prev;
 };