initial call/cc support

include/picrin.h

@@ -57,6 +57,8 @@ typedef struct {
   struct heap_page *heap;
   struct pic_object *arena[PIC_ARENA_SIZE];
   int arena_idx;
+
+  pic_value *native_stack_start;
 } pic_state;
 
 typedef pic_value (*pic_func_t)(pic_state *);

include/picrin/cont.h

@@ -0,0 +1,23 @@
+#ifndef CONT_H__
+#define CONT_H__
+
+struct pic_cont {
+  PIC_OBJECT_HEADER
+  jmp_buf jmp;
+
+  size_t stk_len;
+  pic_value *stk_pos, *stk_ptr;
+
+  pic_value *sp;
+  pic_value *stbase, *stend;
+
+  pic_callinfo *ci;
+  pic_callinfo *cibase, *ciend;
+
+  struct pic_object **arena;
+  int arena_idx;
+
+  pic_value result;
+};
+
+#endif

include/picrin/value.h

@@ -82,7 +82,8 @@ enum pic_tt {
   PIC_TT_BLOB,
   PIC_TT_PROC,
   PIC_TT_PORT,
-  PIC_TT_ENV
+  PIC_TT_ENV,
+  PIC_TT_CONT
 };
 
 #define PIC_OBJECT_HEADER			\

src/codegen.c

@@ -604,6 +604,7 @@ codegen(codegen_state *state, pic_value obj, bool tailpos)
     irep->clen++;
     break;
   }
+  case PIC_TT_CONT:
   case PIC_TT_ENV:
   case PIC_TT_PROC:
   case PIC_TT_UNDEF:

src/cont.c

@@ -0,0 +1,149 @@
+#include <setjmp.h>
+#include <string.h>
+
+#include "picrin.h"
+#include "picrin/proc.h"
+#include "picrin/cont.h"
+
+static void restore_cont(pic_state *, struct pic_cont *);
+
+static void
+native_stack_extend(pic_state *pic, struct pic_cont *cont)
+{
+  volatile pic_value v[1024];
+
+  ((void)v);
+  restore_cont(pic, cont);
+}
+
+static void
+restore_cont(pic_state *pic, struct pic_cont *cont)
+{
+  pic_value v;
+  struct pic_cont *tmp = cont;
+
+  if (&v < pic->native_stack_start) {
+    if (&v > cont->stk_pos) native_stack_extend(pic, cont);
+  }
+  else {
+    if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
+  }
+
+  pic->sp = cont->sp;
+  pic->stbase = cont->stbase;
+  pic->stend = cont->stend;
+  pic->ci = cont->ci;
+  pic->cibase = cont->cibase;
+  pic->ciend = cont->ciend;
+  memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * PIC_ARENA_SIZE);
+  pic->arena_idx = cont->arena_idx;
+
+  memcpy(cont->stk_pos, cont->stk_ptr, sizeof(pic_value) * cont->stk_len);
+
+  longjmp(tmp->jmp, 1);
+}
+
+static pic_value
+pic_cont_call(pic_state *pic)
+{
+  struct pic_proc *proc;
+  pic_value v;
+  struct pic_cont *cont;
+
+  proc = pic_get_proc(pic);
+  pic_get_args(pic, "o", &v);
+
+  cont = (struct pic_cont *)pic_ptr(proc->env->values[0]);
+  cont->result = v;
+
+  restore_cont(pic, cont);
+
+  /* the function never returns */
+  return pic_undef_value();
+}
+
+static size_t
+native_stack_length(pic_state *pic, pic_value **pos)
+{
+  pic_value t;
+
+  *pos = (pic->native_stack_start > &t)
+    ? &t
+    : pic->native_stack_start;
+
+  return (pic->native_stack_start > &t)
+    ? (size_t)(pic->native_stack_start - &t)
+    : (size_t)(&t - pic->native_stack_start + 1);
+}
+
+static struct pic_cont *
+save_cont(pic_state *pic)
+{
+  struct pic_cont *cont;
+  pic_value *pos;
+
+  cont = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
+
+  cont->stk_len = native_stack_length(pic, &pos);
+  cont->stk_pos = pos;
+  cont->stk_ptr = pic_alloc(pic, sizeof(pic_value) * cont->stk_len);
+  memcpy(cont->stk_ptr, cont->stk_pos, sizeof(pic_value) * cont->stk_len);
+
+  cont->stbase = (pic_value *)pic_alloc(pic, sizeof(pic_value) * (pic->stend - pic->stbase));
+  cont->stend = cont->stbase + (pic->stend - pic->stbase);
+  cont->sp = cont->stbase + (pic->sp - pic->stbase);
+  memcpy(cont->stbase, pic->stbase, sizeof(pic_value) * (pic->stend - pic->stbase));
+
+  cont->cibase = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * (pic->ciend - pic->cibase));
+  cont->ciend = cont->cibase + (pic->ciend - pic->cibase);
+  cont->ci = cont->cibase + (pic->ci - pic->cibase);
+  memcpy(cont->cibase, pic->cibase, sizeof(pic_callinfo) * (pic->ciend - pic->cibase));
+
+  cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * PIC_ARENA_SIZE);
+  cont->arena_idx = pic->arena_idx;
+  memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * PIC_ARENA_SIZE);
+
+  cont->result = pic_undef_value();
+
+  return cont;
+}
+
+static pic_value
+pic_callcc(pic_state *pic)
+{
+  struct pic_cont *cont;
+  pic_value v;
+  struct pic_proc *cb;
+
+  pic_get_args(pic, "o", &v);
+
+  if (! pic_proc_p(v)) {
+    pic_error(pic, "expected procedure");
+  }
+  cb = pic_proc_ptr(v);
+
+  cont = save_cont(pic);
+  if (setjmp(cont->jmp)) {
+    return cont->result;
+  }
+  else {
+    struct pic_proc *c;
+
+    c = pic_proc_new_cfunc(pic, pic_cont_call);
+    /* save the continuation object in proc */
+    c->env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
+    c->env->up = NULL;
+    c->env->valuec = 1;
+    c->env->values = (pic_value *)pic_calloc(pic, 1, sizeof(pic_value));
+    c->env->values[0] = pic_obj_value(cont);
+
+    return pic_apply_argv(pic, cb, 1, pic_obj_value(c));
+  }
+}
+
+void
+pic_init_cont(pic_state *pic)
+{
+  pic_defun(pic, "call-with-current-continuation", pic_callcc);
+  pic_defun(pic, "call/cc", pic_callcc);
+}

src/expand.c

@@ -141,6 +141,7 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
   case PIC_TT_PROC:
   case PIC_TT_PORT:
   case PIC_TT_ENV:
+  case PIC_TT_CONT:
   case PIC_TT_UNDEF:
     pic_error(pic, "unexpected value type");
     return pic_undef_value();	/* unreachable */

src/gc.c

@@ -6,6 +6,7 @@
 #include "picrin/proc.h"
 #include "picrin/port.h"
 #include "picrin/blob.h"
+#include "picrin/cont.h"
 
 #if GC_DEBUG
 # include <stdio.h>
@@ -191,6 +192,32 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_BLOB: {
     break;
   }
+  case PIC_TT_CONT: {
+    struct pic_cont *cont = (struct pic_cont *)obj;
+    pic_value *stack;
+    pic_callinfo *ci;
+    int i;
+
+    /* stack */
+    for (stack = cont->stbase; stack != cont->sp; ++stack) {
+      gc_mark(pic, *stack);
+    }
+
+    /* callinfo */
+    for (ci = cont->ci; ci != cont->cibase; --ci) {
+      if (ci->env) {
+	gc_mark_object(pic, (struct pic_object *)ci->env);
+      }
+    }
+
+    /* arena */
+    for (i = 0; i < cont->arena_idx; ++i) {
+      gc_mark_object(pic, cont->arena[i]);
+    }
+
+    gc_mark(pic, cont->result);
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
@@ -304,6 +331,14 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
+  case PIC_TT_CONT: {
+    struct pic_cont *cont = (struct pic_cont *)obj;
+    pic_free(pic, cont->stk_ptr);
+    pic_free(pic, cont->stbase);
+    pic_free(pic, cont->cibase);
+    pic_free(pic, cont->arena);
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:

src/init.c

@@ -15,6 +15,7 @@ void pic_init_proc(pic_state *);
 void pic_init_symbol(pic_state *);
 void pic_init_vector(pic_state *);
 void pic_init_blob(pic_state *);
+void pic_init_cont(pic_state *);
 
 void
 pic_load_stdlib(pic_state *pic)
@@ -79,6 +80,7 @@ pic_init_core(pic_state *pic)
   pic_init_symbol(pic); DONE;
   pic_init_vector(pic); DONE;
   pic_init_blob(pic); DONE;
+  pic_init_cont(pic); DONE;
 
   pic_load_stdlib(pic); DONE;
 }

src/port.c

@@ -81,6 +81,9 @@ write(pic_state *pic, pic_value obj)
   case PIC_TT_ENV:
     printf("#<env %p>", pic_env_ptr(obj));
     break;
+  case PIC_TT_CONT:
+    printf("#<cont %p>", pic_ptr(obj));
+    break;
   }
 }
 

src/state.c

@@ -10,6 +10,8 @@ void pic_init_core(pic_state *);
 pic_state *
 pic_open(int argc, char *argv[], char **envp)
 {
+  pic_value t;
+
   pic_state *pic;
   int ai;
 
@@ -64,6 +66,9 @@ pic_open(int argc, char *argv[], char **envp)
   /* GC arena */
   pic->arena_idx = 0;
 
+  /* native stack marker */
+  pic->native_stack_start = &t;
+
   ai = pic_gc_arena_preserve(pic);
   pic->sDEFINE = pic_intern_cstr(pic, "define");
   pic->sLAMBDA = pic_intern_cstr(pic, "lambda");