picrin/extlib/benz/cont.c

294 lines
5.5 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
2016-02-20 11:13:16 -05:00
#include "picrin/private/object.h"
#include "picrin/private/state.h"
2014-08-25 00:38:09 -04:00
2016-02-20 09:55:40 -05:00
struct pic_cont {
PIC_JMPBUF *jmp;
int id;
struct pic_checkpoint *cp;
ptrdiff_t sp_offset;
ptrdiff_t ci_offset;
ptrdiff_t xp_offset;
size_t arena_idx;
pic_value ptable;
struct pic_code *ip;
2016-02-20 09:55:40 -05:00
int retc;
pic_value *retv;
struct pic_cont *prev;
};
static const pic_data_type cont_type = { "pic_cont", NULL, NULL };
2016-02-19 03:38:49 -05:00
void
2016-02-20 09:55:40 -05:00
pic_save_point(pic_state *pic, struct pic_cont *cont, PIC_JMPBUF *jmp)
2016-02-19 03:38:49 -05:00
{
2016-02-20 09:55:40 -05:00
cont->jmp = jmp;
2016-02-19 03:38:49 -05:00
/* save runtime context */
cont->cp = pic->cp;
cont->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase;
cont->xp_offset = pic->xp - pic->xpbase;
cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->prev = pic->cc;
2016-02-19 03:58:42 -05:00
cont->retc = 0;
cont->retv = NULL;
2016-02-19 03:38:49 -05:00
cont->id = pic->ccnt++;
pic->cc = cont;
}
void
pic_load_point(pic_state *pic, struct pic_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->xp = pic->xpbase + cont->xp_offset;
pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip;
pic->ptable = cont->ptable;
pic->cc = cont->prev;
}
2016-02-20 05:08:07 -05:00
void
pic_exit_point(pic_state *pic)
{
pic->cc = pic->cc->prev;
}
2014-09-18 09:33:20 -04:00
void
pic_wind(pic_state *pic, struct pic_checkpoint *here, struct pic_checkpoint *there)
2014-09-18 09:33:20 -04:00
{
if (here == there)
return;
if (here->depth < there->depth) {
pic_wind(pic, here, there->prev);
2016-02-19 10:03:16 -05:00
pic_call(pic, pic_obj_value(there->in), 0);
2014-09-18 09:33:20 -04:00
}
else {
2016-02-19 10:03:16 -05:00
pic_call(pic, pic_obj_value(there->out), 0);
2014-09-18 09:33:20 -04:00
pic_wind(pic, here->prev, there);
}
}
2016-02-19 03:38:49 -05:00
static pic_value
2016-02-19 10:03:16 -05:00
pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out)
2014-09-18 09:33:20 -04:00
{
struct pic_checkpoint *here;
2014-09-18 09:33:20 -04:00
pic_value val;
2016-02-19 10:03:16 -05:00
pic_call(pic, in, 0); /* enter */
2014-09-18 09:33:20 -04:00
2015-06-08 08:04:04 -04:00
here = pic->cp;
pic->cp = (struct pic_checkpoint *)pic_obj_alloc(pic, sizeof(struct pic_checkpoint), PIC_TYPE_CP);
2015-06-08 08:04:04 -04:00
pic->cp->prev = here;
pic->cp->depth = here->depth + 1;
2016-02-19 10:03:16 -05:00
pic->cp->in = pic_proc_ptr(pic, in);
pic->cp->out = pic_proc_ptr(pic, out);
2014-09-18 09:33:20 -04:00
2016-02-13 23:46:55 -05:00
val = pic_call(pic, thunk, 0);
2014-09-18 09:33:20 -04:00
2015-06-08 08:04:04 -04:00
pic->cp = here;
2014-09-18 09:33:20 -04:00
2016-02-19 10:03:16 -05:00
pic_call(pic, out, 0); /* exit */
2014-09-18 09:33:20 -04:00
return val;
}
2015-01-07 16:11:48 -05:00
static pic_value
2015-06-01 17:32:43 -04:00
cont_call(pic_state *pic)
2014-09-19 03:41:49 -04:00
{
2015-08-26 06:04:27 -04:00
int argc;
2014-09-19 03:41:49 -04:00
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
2014-09-19 03:41:49 -04:00
pic_get_args(pic, "*", &argc, &argv);
2014-09-19 03:41:49 -04:00
2016-02-20 09:55:40 -05:00
cont = pic_data(pic, pic_closure_ref(pic, 0));
id = cont->id;
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
if (cc->id == id) {
break;
}
}
if (cc == NULL) {
pic_errorf(pic, "calling dead escape continuation");
}
2016-02-19 03:58:42 -05:00
cont->retc = argc;
cont->retv = argv;
2014-09-19 03:41:49 -04:00
pic_load_point(pic, cont);
2016-02-20 09:55:40 -05:00
PIC_LONGJMP(pic, *cont->jmp, 1);
2015-05-27 11:41:55 -04:00
PIC_UNREACHABLE();
2014-09-19 03:41:49 -04:00
}
2016-02-19 10:03:16 -05:00
pic_value
2015-06-01 17:32:43 -04:00
pic_make_cont(pic_state *pic, struct pic_cont *cont)
2014-09-24 01:57:49 -04:00
{
2016-02-20 09:55:40 -05:00
return pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type));
}
2014-09-24 01:57:49 -04:00
2016-02-20 09:55:40 -05:00
struct pic_cont *
pic_alloca_cont(pic_state *pic)
{
return pic_alloca(pic, sizeof(struct pic_cont));
2014-09-24 01:57:49 -04:00
}
2016-02-19 03:38:49 -05:00
static pic_value
2016-02-19 10:03:16 -05:00
pic_callcc(pic_state *pic, pic_value proc)
2014-09-19 03:41:49 -04:00
{
2016-02-20 09:55:40 -05:00
PIC_JMPBUF jmp;
struct pic_cont *cont = pic_alloca_cont(pic);
2014-09-19 03:41:49 -04:00
2016-02-20 09:55:40 -05:00
if (PIC_SETJMP(pic, jmp)) {
return pic_valuesk(pic, cont->retc, cont->retv);
2014-09-19 03:41:49 -04:00
}
else {
pic_value val;
2016-02-20 09:55:40 -05:00
pic_save_point(pic, cont, &jmp);
val = pic_call(pic, proc, 1, pic_make_cont(pic, cont));
2014-09-19 03:41:49 -04:00
2016-02-20 05:08:07 -05:00
pic_exit_point(pic);
2014-09-19 03:41:49 -04:00
return val;
}
}
2016-02-19 03:38:49 -05:00
pic_value
pic_return(pic_state *pic, int n, ...)
2015-06-28 15:25:47 -04:00
{
va_list ap;
2016-02-19 03:38:49 -05:00
pic_value ret;
2015-06-28 15:25:47 -04:00
va_start(ap, n);
2016-02-19 03:38:49 -05:00
ret = pic_vreturn(pic, n, ap);
2015-06-28 15:25:47 -04:00
va_end(ap);
2016-02-19 03:38:49 -05:00
return ret;
2014-08-25 00:38:09 -04:00
}
pic_value
2016-02-19 03:38:49 -05:00
pic_vreturn(pic_state *pic, int n, va_list ap)
2014-08-25 00:38:09 -04:00
{
2016-02-19 03:38:49 -05:00
pic_value *retv = pic_alloca(pic, sizeof(pic_value) * n);
int i;
2014-08-25 00:38:09 -04:00
2016-02-19 03:38:49 -05:00
for (i = 0; i < n; ++i) {
retv[i] = va_arg(ap, pic_value);
}
return pic_valuesk(pic, n, retv);
2014-08-25 00:38:09 -04:00
}
pic_value
2016-02-19 03:38:49 -05:00
pic_valuesk(pic_state *pic, int argc, pic_value *argv)
2014-08-25 00:38:09 -04:00
{
2015-08-26 06:04:27 -04:00
int i;
2014-08-25 00:38:09 -04:00
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
2016-02-19 03:38:49 -05:00
pic->ci->retc = argc;
2014-08-25 00:38:09 -04:00
return argc == 0 ? pic_undef_value(pic) : pic->sp[0];
2014-08-25 00:38:09 -04:00
}
2015-08-26 06:04:27 -04:00
int
pic_receive(pic_state *pic, int n, pic_value *argv)
2014-08-25 00:38:09 -04:00
{
struct pic_callinfo *ci;
2015-08-26 06:04:27 -04:00
int i, retc;
2014-08-25 00:38:09 -04:00
/* take info from discarded frame */
ci = pic->ci + 1;
2015-08-26 06:04:27 -04:00
retc = ci->retc;
2014-08-25 00:38:09 -04:00
for (i = 0; i < retc && i < n; ++i) {
argv[i] = ci->fp[i];
}
return retc;
}
static pic_value
pic_cont_callcc(pic_state *pic)
{
2016-02-19 10:03:16 -05:00
pic_value f;
2014-08-25 00:38:09 -04:00
2016-02-19 10:03:16 -05:00
pic_get_args(pic, "l", &f);
2014-08-25 00:38:09 -04:00
2016-02-19 10:03:16 -05:00
return pic_callcc(pic, f);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_cont_dynamic_wind(pic_state *pic)
{
2016-02-19 10:03:16 -05:00
pic_value in, thunk, out;
2014-08-25 00:38:09 -04:00
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)
{
2015-08-26 06:04:27 -04:00
int argc;
2014-08-25 00:38:09 -04:00
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
2016-02-19 03:38:49 -05:00
return pic_valuesk(pic, argc, argv);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
2016-02-19 10:03:16 -05:00
pic_value producer, consumer, *retv;
2016-02-19 03:58:42 -05:00
int retc;
2014-08-25 00:38:09 -04:00
pic_get_args(pic, "ll", &producer, &consumer);
2016-02-13 23:46:55 -05:00
pic_call(pic, producer, 0);
2014-08-25 00:38:09 -04:00
2016-02-19 03:58:42 -05:00
retc = pic_receive(pic, 0, NULL);
retv = pic_alloca(pic, sizeof(pic_value) * retc);
2015-07-04 05:01:30 -04:00
2016-02-19 03:58:42 -05:00
pic_receive(pic, retc, retv);
2014-08-25 00:38:09 -04:00
2016-02-19 03:58:42 -05:00
return pic_applyk(pic, consumer, retc, retv);
2014-08-25 00:38:09 -04:00
}
void
pic_init_cont(pic_state *pic)
{
pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
2014-09-08 06:38:33 -04:00
pic_defun(pic, "call/cc", pic_cont_callcc);
2015-07-06 01:19:12 -04:00
pic_defun(pic, "escape", pic_cont_callcc);
2014-08-25 00:38:09 -04:00
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
2015-06-04 00:53:41 -04:00
2015-07-01 17:17:27 -04:00
pic_defun(pic, "values", pic_cont_values);
pic_defun(pic, "call-with-values", pic_cont_call_with_values);
2014-08-25 00:38:09 -04:00
}