picrin/lib/cont.c

282 lines
5.2 KiB
C

/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/private/object.h"
#include "picrin/private/state.h"
struct cont {
PIC_JMPBUF *jmp;
struct checkpoint *cp;
ptrdiff_t sp_offset;
ptrdiff_t ci_offset;
size_t arena_idx;
const struct code *ip;
int retc;
pic_value *retv;
struct cont *prev;
};
static const pic_data_type cont_type = { "cont", NULL, NULL };
void
pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
{
cont->jmp = jmp;
/* save runtime context */
cont->cp = pic->cp;
cont->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase;
cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip;
cont->prev = pic->cc;
cont->retc = 0;
cont->retv = NULL;
pic->cc = cont;
}
void
pic_load_point(pic_state *pic, struct cont *cont)
{
pic_wind(pic, pic->cp, cont->cp);
/* load runtime context */
pic->cp = cont->cp;
pic->sp = pic->stbase + cont->sp_offset;
pic->ci = pic->cibase + cont->ci_offset;
pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip;
pic->cc = cont->prev;
}
void
pic_exit_point(pic_state *pic)
{
pic->cc = pic->cc->prev;
}
void
pic_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there)
{
if (here == there)
return;
if (here->depth < there->depth) {
pic_wind(pic, here, there->prev);
pic_call(pic, pic_obj_value(there->in), 0);
}
else {
pic_call(pic, pic_obj_value(here->out), 0);
pic_wind(pic, here->prev, there);
}
}
pic_value
pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out)
{
struct checkpoint *here;
pic_value val;
pic_call(pic, in, 0); /* enter */
here = pic->cp;
pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP);
pic->cp->prev = here;
pic->cp->depth = here->depth + 1;
pic->cp->in = pic_proc_ptr(pic, in);
pic->cp->out = pic_proc_ptr(pic, out);
val = pic_call(pic, thunk, 0);
pic->cp = here;
pic_call(pic, out, 0); /* exit */
return val;
}
static pic_value
cont_call(pic_state *pic)
{
int argc;
pic_value *argv;
struct cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv);
cont = pic_data(pic, pic_closure_ref(pic, 0));
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
if (cc == cont) {
break;
}
}
if (cc == NULL) {
pic_error(pic, "calling dead escape continuation", 0);
}
cont->retc = argc;
cont->retv = argv;
pic_load_point(pic, cont);
PIC_LONGJMP(pic, *cont->jmp, 1);
PIC_UNREACHABLE();
}
pic_value
pic_make_cont(pic_state *pic, struct cont *cont)
{
return pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type));
}
struct cont *
pic_alloca_cont(pic_state *pic)
{
return pic_alloca(pic, sizeof(struct cont));
}
static pic_value
pic_callcc(pic_state *pic, pic_value proc)
{
PIC_JMPBUF jmp;
volatile struct cont *cont = pic_alloca_cont(pic);
if (PIC_SETJMP(pic, jmp)) {
return pic_valuesk(pic, cont->retc, cont->retv);
}
else {
pic_value val;
pic_save_point(pic, (struct cont *)cont, &jmp);
val = pic_call(pic, proc, 1, pic_make_cont(pic, (struct cont *)cont));
pic_exit_point(pic);
return val;
}
}
pic_value
pic_return(pic_state *pic, int n, ...)
{
va_list ap;
pic_value ret;
va_start(ap, n);
ret = pic_vreturn(pic, n, ap);
va_end(ap);
return ret;
}
pic_value
pic_vreturn(pic_state *pic, int n, va_list ap)
{
pic_value *retv = pic_alloca(pic, sizeof(pic_value) * n);
int i;
for (i = 0; i < n; ++i) {
retv[i] = va_arg(ap, pic_value);
}
return pic_valuesk(pic, n, retv);
}
pic_value
pic_valuesk(pic_state *pic, int argc, pic_value *argv)
{
int i;
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
pic->ci->retc = argc;
return argc == 0 ? pic_undef_value(pic) : pic->sp[0];
}
int
pic_receive(pic_state *pic, int n, pic_value *argv)
{
struct callinfo *ci;
int i, retc;
/* take info from discarded frame */
ci = pic->ci + 1;
retc = ci->retc;
for (i = 0; i < retc && i < n; ++i) {
argv[i] = ci->fp[i];
}
return retc;
}
static pic_value
pic_cont_callcc(pic_state *pic)
{
pic_value f;
pic_get_args(pic, "l", &f);
return pic_callcc(pic, f);
}
static pic_value
pic_cont_dynamic_wind(pic_state *pic)
{
pic_value in, thunk, out;
pic_get_args(pic, "lll", &in, &thunk, &out);
return pic_dynamic_wind(pic, in, thunk, out);
}
static pic_value
pic_cont_values(pic_state *pic)
{
int argc;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
return pic_valuesk(pic, argc, argv);
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
pic_value producer, consumer, *retv;
int retc;
pic_get_args(pic, "ll", &producer, &consumer);
pic_call(pic, producer, 0);
retc = pic_receive(pic, 0, NULL);
retv = pic_alloca(pic, sizeof(pic_value) * retc);
pic_receive(pic, retc, retv);
return pic_applyk(pic, consumer, retc, retv);
}
void
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, "escape", pic_cont_callcc);
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun(pic, "values", pic_cont_values);
pic_defun(pic, "call-with-values", pic_cont_call_with_values);
}