diff --git a/include/picrin.h b/include/picrin.h index f0f1d172..5a12c92d 100644 --- a/include/picrin.h +++ b/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 *); diff --git a/include/picrin/cont.h b/include/picrin/cont.h new file mode 100644 index 00000000..6fb5dd68 --- /dev/null +++ b/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 diff --git a/include/picrin/value.h b/include/picrin/value.h index bcb9118b..6807177a 100644 --- a/include/picrin/value.h +++ b/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 \ diff --git a/src/codegen.c b/src/codegen.c index cd687889..5468d713 100644 --- a/src/codegen.c +++ b/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: diff --git a/src/cont.c b/src/cont.c new file mode 100644 index 00000000..5b4d8f70 --- /dev/null +++ b/src/cont.c @@ -0,0 +1,149 @@ +#include +#include + +#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); +} diff --git a/src/expand.c b/src/expand.c index 24cdaac0..b7795d6a 100644 --- a/src/expand.c +++ b/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 */ diff --git a/src/gc.c b/src/gc.c index e0689e96..56da0721 100644 --- a/src/gc.c +++ b/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 @@ -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: diff --git a/src/init.c b/src/init.c index 59d1f6cd..24b83265 100644 --- a/src/init.c +++ b/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; } diff --git a/src/port.c b/src/port.c index 5740c9e9..9271b51b 100644 --- a/src/port.c +++ b/src/port.c @@ -81,6 +81,9 @@ write(pic_state *pic, pic_value obj) case PIC_TT_ENV: printf("#", pic_env_ptr(obj)); break; + case PIC_TT_CONT: + printf("#", pic_ptr(obj)); + break; } } diff --git a/src/state.c b/src/state.c index 2717b0f8..c7d2681c 100644 --- a/src/state.c +++ b/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");