add shift/reset

lib/ext/cont.c

@@ -8,17 +8,58 @@
 
 #if PIC_USE_CALLCC
 
+/*
+ * [(reset e)]k = k ([e] halt ())
+ * [(shift e)]k = [e] halt (\c x, c (k x))
+ */
+
+static pic_value
+pic_cont_reset(pic_state *pic)
+{
+  pic_value thunk;
+
+  pic_get_args(pic, "l", &thunk);
+
+  return pic_call(pic, thunk, 0);
+}
+
+static pic_value
+shift_call(pic_state *pic)
+{
+  pic_value x;
+  struct context cxt;
+
+  pic_get_args(pic, "o", &x);
+
+  CONTEXT_INIT(pic, &cxt, pic_closure_ref(pic, 0), 1, &x);
+  pic_vm(pic, &cxt);
+  return pic_protect(pic, cxt.fp->regs[1]);
+}
+
+static pic_value
+pic_cont_shift(pic_state *pic)
+{
+  pic_value f, k;
+
+  pic_get_args(pic, "l", &f);
+
+  k = pic_lambda(pic, shift_call, 1, pic->cxt->fp->regs[1]);
+  CONTEXT_INITK(pic, pic->cxt, f, pic->halt, 1, &k);
+  return pic_invalid_value(pic);
+}
+
 static pic_value
 cont_call(pic_state *pic)
 {
   int argc;
   pic_value *argv, k, dyn_env;
   struct context *cxt, *c;
-  int i;
 
   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) {
@@ -30,20 +71,9 @@ cont_call(pic_state *pic)
     pic_error(pic, "calling dead escape continuation", 0);
   }
 
-  k = pic_closure_ref(pic, 1);
+  CONTEXT_INIT(pic, cxt, k, argc, argv);
-  dyn_env = pic_closure_ref(pic, 2);
 
-#define MKCALLK(argc)                                                   \
-  (cxt->tmpcode[0] = OP_CALL, cxt->tmpcode[1] = (argc), cxt->tmpcode)
-
-  cxt->pc = MKCALLK(argc);
-  cxt->sp = pic_make_frame_unsafe(pic, argc + 2);
-  cxt->sp->regs[0] = k;
-  for (i = 0; i < argc; ++i) {
-    cxt->sp->regs[i + 1] = argv[i];
-  }
   pic->cxt = cxt;
-
   pic->dyn_env = dyn_env;
 
   longjmp(cxt->jmp, 1);
@@ -60,12 +90,11 @@ pic_make_cont(pic_state *pic, pic_value k)
 static pic_value
 pic_cont_callcc(pic_state *pic)
 {
-  pic_value f, args[1];
+  pic_value f;
 
   pic_get_args(pic, "l", &f);
 
-  args[0] = pic_make_cont(pic, pic->cxt->fp->regs[1]);
+  return pic_callk(pic, f, 1, pic_make_cont(pic, pic->cxt->fp->regs[1]));
-  return pic_applyk(pic, f, 1, args);
 }
 
 void
@@ -73,6 +102,8 @@ pic_init_cont(pic_state *pic)
 {
   pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
   pic_defun(pic, "call/cc", pic_cont_callcc);
+  pic_defun(pic, "shift", pic_cont_shift);
+  pic_defun(pic, "reset", pic_cont_reset);
 }
 
 #endif  /* PIC_USE_CALCC */

lib/include/picrin.h

@@ -237,7 +237,9 @@ int pic_get_args(pic_state *, const char *fmt, ...);
 pic_value pic_closure_ref(pic_state *, int i);
 void pic_closure_set(pic_state *, int i, pic_value v);
 pic_value pic_call(pic_state *, pic_value proc, int, ...);
+pic_value pic_callk(pic_state *, pic_value proc, int, ...);
 pic_value pic_vcall(pic_state *, pic_value proc, int, va_list);
+pic_value pic_vcallk(pic_state *, pic_value proc, int, va_list);
 pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv);
 pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv);
 

lib/proc.c

@@ -496,66 +496,102 @@ pic_call(pic_state *pic, pic_value proc, int n, ...)
   return r;
 }
 
+pic_value
+pic_callk(pic_state *pic, pic_value proc, int n, ...)
+{
+  va_list ap;
+
+  va_start(ap, n);
+  pic_vcallk(pic, proc, n, ap);
+  va_end(ap);
+  return pic_invalid_value(pic);
+}
+
 pic_value
 pic_vcall(pic_state *pic, pic_value proc, int n, va_list ap)
 {
-  size_t ai = pic_enter(pic);
+  struct context cxt;
-  pic_value *args = pic_alloca(pic, sizeof(pic_value) * n);
+  CONTEXT_VINITK(pic, &cxt, proc, pic->halt, n, ap);
-  pic_value r;
+  pic_vm(pic, &cxt);
-  int i;
+  return pic_protect(pic, cxt.fp->regs[1]);
+}
 
-  for (i = 0; i < n; ++i) {
+pic_value
-    args[i] = va_arg(ap, pic_value);
+pic_vcallk(pic_state *pic, pic_value proc, int n, va_list ap)
-  }
+{
-  r = pic_apply(pic, proc, n, args);
+  CONTEXT_VINITK(pic, pic->cxt, proc, GET_CONT(pic), n, ap);
-  pic_leave(pic, ai);
+  return pic_invalid_value(pic);
-  return pic_protect(pic, r);
 }
 
 pic_value
 pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
 {
   struct context cxt;
+  CONTEXT_INITK(pic, &cxt, proc, pic->halt, argc, argv);
+  pic_vm(pic, &cxt);
+  return pic_protect(pic, cxt.fp->regs[1]);
+}
 
-#define MKCALL(argc) (cxt.tmpcode[0] = OP_CALL, cxt.tmpcode[1] = (argc), cxt.tmpcode)
+pic_value
+pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *argv)
+{
+  CONTEXT_INITK(pic, pic->cxt, proc, GET_CONT(pic), argc, argv);
+  return pic_invalid_value(pic);
+}
 
-  cxt.pc = MKCALL(argc + 1);
+pic_value
-  cxt.sp = pic_make_frame_unsafe(pic, argc + 3);
+pic_values(pic_state *pic, int n, ...)
-  cxt.sp->regs[0] = proc;
+{
-  cxt.sp->regs[1] = pic->halt;
+  va_list ap;
-  if (argc != 0) {
+  pic_value ret;
-    int i;
+
-    for (i = 0; i < argc; ++i) {
+  va_start(ap, n);
-      cxt.sp->regs[i + 2] = argv[i];
+  ret = pic_vvalues(pic, n, ap);
+  va_end(ap);
+  return ret;
+}
+
+pic_value
+pic_vvalues(pic_state *pic, int n, va_list ap)
+{
+  if (n == 1) {
+    return va_arg(ap, pic_value);
   }
-  }
+  CONTEXT_VINIT(pic, pic->cxt, GET_CONT(pic), n, ap);
-  cxt.fp = NULL;
+  return pic_invalid_value(pic);
-  cxt.irep = NULL;
+}
-  cxt.prev = pic->cxt;
-  pic->cxt = &cxt;
 
-#define SAVE (pic->ai = cxt.ai)
+void
+pic_vm(pic_state *pic, struct context *cxt)
+{
+  assert(cxt->fp == NULL);
+  assert(cxt->irep == NULL);
 
-  if (PIC_SETJMP(cxt.jmp) == 0) {
+  cxt->prev = pic->cxt;
-    cxt.ai = pic->ai;
+  pic->cxt = cxt;
+
+  if (PIC_SETJMP(cxt->jmp) == 0) {
+    cxt->ai = pic->ai;
   }
 
-#define A (cxt.pc[1])
+#define SAVE (pic->ai = cxt->ai)
-#define B (cxt.pc[2])
+
-#define C (cxt.pc[3])
+#define A (cxt->pc[1])
+#define B (cxt->pc[2])
+#define C (cxt->pc[3])
 #define Bx ((C << 8) + B)
-#define REG(i) (cxt.sp->regs[i])
+#define REG(i) (cxt->sp->regs[i])
 
 #if PIC_DIRECT_THREADED_VM
 # define VM_LOOP JUMP;
 # define CASE(x) L_##x:
-# define NEXT(n) (cxt.pc += n); JUMP;
+# define NEXT(n) (cxt->pc += n); JUMP;
-# define JUMP goto *oplabels[*cxt.pc];
+# define JUMP goto *oplabels[*cxt->pc];
 # define VM_LOOP_END
 #else
-# define VM_LOOP for (;;) { switch (*cxt.pc) {
+# define VM_LOOP for (;;) { switch (*cxt->pc) {
 # define CASE(x) case x:
-# define NEXT(n) (cxt.pc += n); break
+# define NEXT(n) (cxt->pc += n); break
 # define JUMP break
 # define VM_LOOP_END } }
 #endif
@@ -572,10 +608,8 @@ pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
 
   VM_LOOP {
     CASE(OP_HALT) {
-      pic_value ret = cxt.fp->regs[1];
       pic->cxt = pic->cxt->prev;
-      pic_protect(pic, ret);
+      return;
-      return ret;
     }
     CASE(OP_CALL) {
       struct proc *proc;
@@ -585,19 +619,19 @@ pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
       proc = proc_ptr(pic, REG(0));
       if (proc->tt == PIC_TYPE_PROC_FUNC) {
         pic_value v;
-        cxt.sp->up = proc->env; /* push static link */
+        cxt->sp->up = proc->env; /* push static link */
-        cxt.fp = cxt.sp;
+        cxt->fp = cxt->sp;
-        cxt.sp = NULL;
+        cxt->sp = NULL;
-        cxt.irep = NULL;
+        cxt->irep = NULL;
         v = proc->u.func(pic);
-        if (cxt.sp != NULL) {   /* tail call */
+        if (cxt->sp != NULL) {   /* tail call */
           SAVE;
           JUMP;
         } else {
-          cxt.sp = pic_make_frame_unsafe(pic, 3);
+          cxt->sp = pic_make_frame_unsafe(pic, 3);
-          cxt.sp->regs[0] = cxt.fp->regs[1]; /* cont. */
+          cxt->sp->regs[0] = cxt->fp->regs[1]; /* cont. */
-          cxt.sp->regs[1] = v;
+          cxt->sp->regs[1] = v;
-          cxt.pc = MKCALL(1);
+          cxt->pc = MKCALL(cxt, 1);
           SAVE;
           JUMP;
         }
@@ -614,34 +648,34 @@ pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
           SAVE;                 /* TODO: get rid of this */
         }
 
-        cxt.sp->up = proc->env; /* push static link */
+        cxt->sp->up = proc->env; /* push static link */
-        cxt.fp = cxt.sp;
+        cxt->fp = cxt->sp;
-        cxt.sp = pic_make_frame_unsafe(pic, irep->frame_size);
+        cxt->sp = pic_make_frame_unsafe(pic, irep->frame_size);
-        cxt.pc = irep->code;
+        cxt->pc = irep->code;
-        cxt.irep = irep;
+        cxt->irep = irep;
         JUMP;
       }
     }
     CASE(OP_LREF) {
       struct frame *f;
       int depth = B;
-      for (f = cxt.fp; depth--; f = f->up);
+      for (f = cxt->fp; depth--; f = f->up);
       REG(A) = f->regs[C];
       NEXT(4);
     }
     CASE(OP_LSET) {
       struct frame *f;
       int depth = B;
-      for (f = cxt.fp; depth--; f = f->up);
+      for (f = cxt->fp; depth--; f = f->up);
       f->regs[C] = REG(A);
       NEXT(4);
     }
     CASE(OP_GREF) {
-      REG(A) = pic_global_ref(pic, cxt.irep->obj[B]);
+      REG(A) = pic_global_ref(pic, cxt->irep->obj[B]);
       NEXT(3);
     }
     CASE(OP_GSET) {
-      pic_global_set(pic, cxt.irep->obj[B], REG(A));
+      pic_global_set(pic, cxt->irep->obj[B], REG(A));
       NEXT(3);
     }
     CASE(OP_COND) {
@@ -652,11 +686,11 @@ pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
       }
     }
     CASE(OP_PROC) {
-      REG(A) = pic_make_proc_irep_unsafe(pic, cxt.irep->irep[B], cxt.fp);
+      REG(A) = pic_make_proc_irep_unsafe(pic, cxt->irep->irep[B], cxt->fp);
       NEXT(3);
     }
     CASE(OP_LOAD) {
-      REG(A) = cxt.irep->obj[B];
+      REG(A) = cxt->irep->obj[B];
       NEXT(3);
     }
     CASE(OP_LOADU) {
@@ -682,72 +716,6 @@ pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
   } VM_LOOP_END
 }
 
-static pic_value
-applyk(pic_state *pic, pic_value proc, pic_value cont, int argc, pic_value *argv)
-{
-  int i;
-
-#define MKCALLK(argc)                                                   \
-  (pic->cxt->tmpcode[0] = OP_CALL, pic->cxt->tmpcode[1] = (argc), pic->cxt->tmpcode)
-
-  pic->cxt->pc = MKCALLK(argc + 1);
-  pic->cxt->sp = pic_make_frame_unsafe(pic, argc + 3);
-  pic->cxt->sp->regs[0] = proc;
-  pic->cxt->sp->regs[1] = cont;
-  for (i = 0; i < argc; ++i) {
-    pic->cxt->sp->regs[i + 2] = argv[i];
-  }
-  return pic_invalid_value(pic);
-}
-
-pic_value
-pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args)
-{
-  return applyk(pic, proc, GET_CONT(pic), argc, args);
-}
-
-static pic_value
-valuesk(pic_state *pic, int argc, pic_value *argv)
-{
-  int i;
-
-  pic->cxt->pc = MKCALLK(argc);
-  pic->cxt->sp = pic_make_frame_unsafe(pic, argc + 2);
-  pic->cxt->sp->regs[0] = pic->cxt->fp->regs[1];
-  for (i = 0; i < argc; ++i) {
-    pic->cxt->sp->regs[i + 1] = argv[i];
-  }
-  return pic_invalid_value(pic);
-}
-
-pic_value
-pic_values(pic_state *pic, int n, ...)
-{
-  va_list ap;
-  pic_value ret;
-
-  va_start(ap, n);
-  ret = pic_vvalues(pic, n, ap);
-  va_end(ap);
-  return ret;
-}
-
-pic_value
-pic_vvalues(pic_state *pic, int n, va_list ap)
-{
-  pic_value *retv;
-  int i;
-
-  if (n == 1) {
-    return va_arg(ap, pic_value);
-  }
-  retv = pic_alloca(pic, sizeof(pic_value) * n);
-  for (i = 0; i < n; ++i) {
-    retv[i] = va_arg(ap, pic_value);
-  }
-  return valuesk(pic, n, retv);
-}
-
 static pic_value
 pic_proc_make_procedure(pic_state *pic)
 {
@@ -811,34 +779,34 @@ pic_proc_values(pic_state *pic)
   if (argc == 1) {
     return argv[0];
   }
-  return valuesk(pic, argc, argv);
+  CONTEXT_INIT(pic, pic->cxt, GET_CONT(pic), argc, argv);
+  return pic_invalid_value(pic);
 }
 
 static pic_value
 receive_call(pic_state *pic)
 {
   int argc = pic->cxt->pc[1];
-  pic_value *args = &pic->cxt->fp->regs[1], consumer, cont;
+  pic_value *args = &pic->cxt->fp->regs[1];
 
   /* receive_call is an inhabitant in the continuation side.
      You can not use pic_get_args since it implicitly consumes the first argument. */
 
-  consumer = pic_closure_ref(pic, 0);
+  CONTEXT_INITK(pic, pic->cxt, pic_closure_ref(pic, 0), pic_closure_ref(pic, 1), argc, args);
-  cont = pic_closure_ref(pic, 1);
 
-  return applyk(pic, consumer, cont, argc, args);
+  return pic_invalid_value(pic);
 }
 
 static pic_value
 pic_proc_call_with_values(pic_state *pic)
 {
-  pic_value producer, consumer, k;
+  pic_value producer, consumer;
 
   pic_get_args(pic, "ll", &producer, &consumer);
 
-  k = pic_lambda(pic, receive_call, 2, consumer, pic->cxt->fp->regs[1]);
+  CONTEXT_INITK(pic, pic->cxt, producer, pic_lambda(pic, receive_call, 2, consumer, GET_CONT(pic)), 0, (pic_value *) NULL);
 
-  return applyk(pic, producer, k, 0, NULL);
+  return pic_invalid_value(pic);
 }
 
 void

lib/state.h

@@ -58,7 +58,60 @@ void pic_heap_close(pic_state *, struct heap *);
 pic_value pic_global_ref(pic_state *pic, pic_value uid);
 void pic_global_set(pic_state *pic, pic_value uid, pic_value value);
 
-void pic_vm_tear_off(pic_state *pic);
+#define MKCALL(cxt,argc)                                                \
+  ((cxt)->tmpcode[0] = OP_CALL, (cxt)->tmpcode[1] = (argc), (cxt)->tmpcode)
+
+#define CONTEXT_VINITK(pic,cxt,proc,k,n,ap) do {        \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n) + 1);                 \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 3);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    (cxt)->sp->regs[1] = k;                             \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 2] = va_arg(ap, pic_value);   \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_INITK(pic,cxt,proc,k,n,argv) do {       \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n) + 1);                 \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 3);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    (cxt)->sp->regs[1] = k;                             \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 2] = (argv)[i];               \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_VINIT(pic,cxt,proc,n,ap) do {           \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n));                     \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 2);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 1] = va_arg(ap, pic_value);   \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+#define CONTEXT_INIT(pic,cxt,proc,n,argv) do {          \
+    int i;                                              \
+    (cxt)->pc = MKCALL((cxt), (n));                     \
+    (cxt)->sp = pic_make_frame_unsafe(pic, (n) + 2);    \
+    (cxt)->sp->regs[0] = (proc);                        \
+    for (i = 0; i < (n); ++i) {                         \
+      (cxt)->sp->regs[i + 1] = (argv)[i];               \
+    }                                                   \
+    (cxt)->fp = NULL;                                   \
+    (cxt)->irep = NULL;                                 \
+  } while (0)
+
+void pic_vm(pic_state *pic, struct context *cxt);
 
 #if defined(__cplusplus)
 }