static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
int argc;
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv);
id = pic_int(pic_proc_env_ref(pic, self, "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");
}
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
cont->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, cont);
PIC_LONGJMP(pic, cont->jmp, 1);
PIC_UNREACHABLE();
}
pic_sym *
pic_proc_name(struct pic_proc *proc)
{
switch (proc->kind) {
case PIC_PROC_KIND_FUNC:
return proc->u.func.name;
case PIC_PROC_KIND_IREP:
return proc->u.irep->name;
}
PIC_UNREACHABLE();
}
pic_sym *
pic_proc_name(struct pic_proc *proc)
{
switch (proc->tag) {
case PIC_PROC_TAG_FUNC:
return proc->u.f.name;
case PIC_PROC_TAG_IREP:
return proc->u.i.irep->name;
}
PIC_UNREACHABLE();
}
static pic_value
native_exception_handler(pic_state *pic)
{
pic_value err;
pic_get_args(pic, "o", &err);
pic->err = err;
pic_call(pic, pic_closure_ref(pic, 0), 1, pic_false_value(pic));
PIC_UNREACHABLE();
}
void
pic_panic(pic_state *pic, const char *msg)
{
if (pic->panicf) {
pic->panicf(pic, msg);
}
#if PIC_USE_STDIO
fprintf(stderr, "picrin panic!: %s\n", msg);
#endif
PIC_ABORT(pic);
PIC_UNREACHABLE();
}
void
pic_raise(pic_state *pic, pic_value err)
{
pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
stack = pic_call(pic, exc, 0);
if (pic_nil_p(pic, stack)) {
pic_panic(pic, "no exception handler");
}
pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise, 2, pic_car(pic, stack), err));
PIC_UNREACHABLE();
}
pic_value
pic_native_exception_handler(pic_state *pic)
{
pic_value err;
struct pic_proc *cont;
pic_get_args(pic, "o", &err);
pic->err = err;
cont = pic_proc_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "cont"));
pic_apply1(pic, cont, pic_false_value());
PIC_UNREACHABLE();
}
static pic_value
native_exception_handler(pic_state *pic)
{
pic_value err;
struct pic_proc *cont;
pic_get_args(pic, "o", &err);
pic->err = err;
cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
pic_apply1(pic, cont, pic_false_value());
PIC_UNREACHABLE();
}
static pic_value
cont_call(pic_state *pic)
{
size_t argc;
pic_value *argv;
struct pic_data *e;
pic_get_args(pic, "*", &argc, &argv);
e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape"));
((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, e->data);
PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1);
PIC_UNREACHABLE();
}
static size_t
type2size(int type)
{
switch (type) {
case PIC_TYPE_VECTOR: return sizeof(struct vector);
case PIC_TYPE_BLOB: return sizeof(struct blob);
case PIC_TYPE_STRING: return sizeof(struct string);
case PIC_TYPE_DATA: return sizeof(struct data);
case PIC_TYPE_DICT: return sizeof(struct dict);
case PIC_TYPE_SYMBOL: return sizeof(struct symbol);
case PIC_TYPE_WEAK: return sizeof(struct weak);
case PIC_TYPE_IREP: return sizeof(struct irep);
case PIC_TYPE_PORT: return sizeof(struct port);
case PIC_TYPE_PAIR: return sizeof(struct pair);
case PIC_TYPE_FRAME: return sizeof(struct frame);
case PIC_TYPE_ERROR: return sizeof(struct error);
case PIC_TYPE_RECORD: return sizeof(struct record);
case PIC_TYPE_PROC_FUNC: return sizeof(struct proc);
case PIC_TYPE_PROC_IREP: return sizeof(struct proc);
default: PIC_UNREACHABLE();
}
}
static size_t
type2size(int type)
{
switch (type) {
case PIC_TYPE_VECTOR: return sizeof(struct vector);
case PIC_TYPE_BLOB: return sizeof(struct blob);
case PIC_TYPE_STRING: return sizeof(struct string);
case PIC_TYPE_DATA: return sizeof(struct data);
case PIC_TYPE_DICT: return sizeof(struct dict);
case PIC_TYPE_SYMBOL: return sizeof(struct symbol);
case PIC_TYPE_ATTR: return sizeof(struct attr);
case PIC_TYPE_IREP: return sizeof(struct irep);
case PIC_TYPE_PAIR: return sizeof(struct pair);
case PIC_TYPE_FRAME: return sizeof(struct frame);
case PIC_TYPE_RECORD: return sizeof(struct record);
case PIC_TYPE_PROC_FUNC: return sizeof(struct proc);
case PIC_TYPE_PROC_IREP: return sizeof(struct proc);
case PIC_TYPE_ROPE_LEAF: return sizeof(struct rope_leaf);
case PIC_TYPE_ROPE_NODE: return sizeof(struct rope_node);
default: PIC_UNREACHABLE();
}
}
static void
gc_finalize_object(pic_state *pic, struct object *obj)
{
switch (obj_type(pic, obj)) {
case PIC_TYPE_VECTOR: {
pic_free(pic, obj->u.vec.data);
break;
}
case PIC_TYPE_BLOB: {
pic_free(pic, obj->u.blob.data);
break;
}
case PIC_TYPE_STRING: {
pic_rope_decref(pic, obj->u.str.rope);
break;
}
case PIC_TYPE_DATA: {
if (obj->u.data.type->dtor) {
obj->u.data.type->dtor(pic, obj->u.data.data);
}
break;
}
case PIC_TYPE_DICT: {
kh_destroy(dict, &obj->u.dict.hash);
break;
}
case PIC_TYPE_SYMBOL: {
/* TODO: remove this symbol's entry from pic->syms immediately */
break;
}
case PIC_TYPE_WEAK: {
kh_destroy(weak, &obj->u.weak.hash);
break;
}
case PIC_TYPE_IREP: {
struct irep *irep = &obj->u.irep;
if ((irep->flags & IREP_CODE_STATIC) == 0) {
pic_free(pic, (code_t *) irep->code);
}
pic_free(pic, irep->obj);
pic_free(pic, irep->irep);
break;
}
case PIC_TYPE_PORT: {
pic_fclose(pic, obj_value(pic, obj)); /* FIXME */
break;
}
case PIC_TYPE_FRAME: {
pic_free(pic, obj->u.frame.regs);
break;
}
case PIC_TYPE_PAIR:
case PIC_TYPE_ERROR:
case PIC_TYPE_RECORD:
case PIC_TYPE_PROC_FUNC:
case PIC_TYPE_PROC_IREP:
break;
default:
PIC_UNREACHABLE();
}
}
static void
gc_mark_object(pic_state *pic, struct object *obj)
{
loop:
if (is_alive(obj))
return;
mark(obj);
#define LOOP(o) obj = (struct object *)(o); goto loop
switch (obj_type(pic, obj)) {
case PIC_TYPE_PAIR: {
gc_mark(pic, obj->u.pair.car);
if (obj_p(pic, obj->u.pair.cdr)) {
LOOP(obj_ptr(pic, obj->u.pair.cdr));
}
break;
}
case PIC_TYPE_FRAME: {
int i;
for (i = 0; i < obj->u.frame.regc; ++i) {
gc_mark(pic, obj->u.frame.regs[i]);
}
if (obj->u.frame.up) {
LOOP(obj->u.frame.up);
}
break;
}
case PIC_TYPE_PROC_FUNC: {
if (obj->u.proc.env) {
LOOP(obj->u.proc.env);
}
break;
}
case PIC_TYPE_PROC_IREP: {
if (obj->u.proc.env) {
gc_mark_object(pic, (struct object *)obj->u.proc.env);
}
LOOP(obj->u.proc.u.irep);
break;
}
case PIC_TYPE_IREP: {
size_t i;
for (i = 0; i < obj->u.irep.objc; ++i) {
gc_mark(pic, obj->u.irep.obj[i]);
}
for (i = 0; i < obj->u.irep.irepc; ++i) {
gc_mark_object(pic, (struct object *)obj->u.irep.irep[i]);
}
break;
}
case PIC_TYPE_PORT: {
break;
}
case PIC_TYPE_ERROR: {
gc_mark_object(pic, (struct object *)obj->u.err.type);
gc_mark(pic, obj->u.err.irrs);
LOOP(obj->u.err.msg);
break;
}
case PIC_TYPE_STRING: {
break;
}
case PIC_TYPE_VECTOR: {
int i;
for (i = 0; i < obj->u.vec.len; ++i) {
gc_mark(pic, obj->u.vec.data[i]);
}
break;
}
case PIC_TYPE_BLOB: {
break;
}
case PIC_TYPE_DATA: {
break;
}
case PIC_TYPE_DICT: {
pic_value key, val;
int it = 0;
while (pic_dict_next(pic, obj_value(pic, &obj->u.dict), &it, &key, &val)) {
gc_mark(pic, key);
gc_mark(pic, val);
}
break;
}
case PIC_TYPE_RECORD: {
gc_mark(pic, obj->u.rec.datum);
LOOP(obj->u.rec.type);
break;
}
case PIC_TYPE_SYMBOL: {
LOOP(obj->u.sym.str);
break;
}
case PIC_TYPE_WEAK: {
struct weak *weak = (struct weak *)obj;
weak->prev = pic->heap->weaks;
pic->heap->weaks = weak;
break;
}
default:
PIC_UNREACHABLE();
}
}
static void
gc_finalize_object(pic_state *pic, struct object *obj)
{
switch (obj_type(obj)) {
case PIC_TYPE_VECTOR: {
struct vector *vec = (struct vector *) obj;
pic_free(pic, vec->data);
break;
}
case PIC_TYPE_BLOB: {
struct blob *blob = (struct blob *) obj;
pic_free(pic, blob->data);
break;
}
case PIC_TYPE_DATA: {
struct data *data = (struct data *) obj;
if (data->type->dtor) {
data->type->dtor(pic, data->data);
}
break;
}
case PIC_TYPE_DICT: {
struct dict *dict = (struct dict *) obj;
kh_destroy(dict, &dict->hash);
break;
}
case PIC_TYPE_SYMBOL: {
/* TODO: remove this symbol's entry from pic->syms immediately */
break;
}
case PIC_TYPE_ATTR: {
struct attr *attr = (struct attr *) obj;
kh_destroy(attr, &attr->hash);
break;
}
case PIC_TYPE_IREP: {
struct irep *irep = (struct irep *) obj;
if ((irep->flags & IREP_CODE_STATIC) == 0) {
pic_free(pic, (code_t *) irep->code);
}
pic_free(pic, irep->obj);
pic_free(pic, irep->irep);
break;
}
case PIC_TYPE_FRAME: {
struct frame *frame = (struct frame *) obj;
pic_free(pic, frame->regs);
break;
}
case PIC_TYPE_ROPE_LEAF: {
struct rope_leaf *leaf = (struct rope_leaf *) obj;
pic_free(pic, (char *) leaf->str);
break;
}
case PIC_TYPE_STRING:
case PIC_TYPE_ROPE_NODE:
case PIC_TYPE_PAIR:
case PIC_TYPE_RECORD:
case PIC_TYPE_PROC_FUNC:
case PIC_TYPE_PROC_IREP:
break;
default:
PIC_UNREACHABLE();
}
}
static void
gc_mark_object(pic_state *pic, struct object *obj)
{
loop:
if (is_alive(obj))
return;
mark(obj);
#define LOOP(o) obj = (struct object *)(o); goto loop
switch (obj_type(obj)) {
case PIC_TYPE_PAIR: {
struct pair *pair = (struct pair *) obj;
gc_mark(pic, pair->car);
if (pic_obj_p(pic, pair->cdr)) {
LOOP(pic_ptr(pic, pair->cdr));
}
break;
}
case PIC_TYPE_FRAME: {
struct frame *frame = (struct frame *) obj;
int i;
for (i = 0; i < frame->regc; ++i) {
gc_mark(pic, frame->regs[i]);
}
if (frame->up) {
LOOP(frame->up);
}
break;
}
case PIC_TYPE_PROC_FUNC: {
struct proc *proc = (struct proc *) obj;
if (proc->env) {
LOOP(proc->env);
}
break;
}
case PIC_TYPE_PROC_IREP: {
struct proc *proc = (struct proc *) obj;
if (proc->env) {
gc_mark_object(pic, (struct object *) proc->env);
}
LOOP(proc->u.irep);
break;
}
case PIC_TYPE_IREP: {
struct irep *irep = (struct irep *) obj;
size_t i;
for (i = 0; i < irep->objc; ++i) {
gc_mark(pic, irep->obj[i]);
}
for (i = 0; i < irep->irepc; ++i) {
gc_mark_object(pic, (struct object *) irep->irep[i]);
}
break;
}
case PIC_TYPE_VECTOR: {
struct vector *vec = (struct vector *) obj;
int i;
for (i = 0; i < vec->len; ++i) {
gc_mark(pic, vec->data[i]);
}
break;
}
case PIC_TYPE_DICT: {
struct dict *dict = (struct dict *) obj;
khash_t(dict) *h = &dict->hash;
int it;
for (it = 0; it != kh_end(h); ++it) {
if (kh_exist(h, it)) {
gc_mark_object(pic, (struct object *) kh_key(h, it));
gc_mark(pic, kh_val(h, it));
}
}
break;
}
case PIC_TYPE_RECORD: {
struct record *rec = (struct record *) obj;
gc_mark(pic, rec->datum);
LOOP(rec->type);
break;
}
case PIC_TYPE_SYMBOL: {
struct symbol *sym = (struct symbol *) obj;
LOOP(sym->str);
break;
}
case PIC_TYPE_ATTR: {
struct attr *attr = (struct attr *) obj;
attr->prev = pic->gc_attrs;
pic->gc_attrs = attr;
break;
}
case PIC_TYPE_STRING: {
struct string *str = (struct string *) obj;
LOOP(str->rope);
break;
}
case PIC_TYPE_ROPE_NODE: {
struct rope_node *node = (struct rope_node *) obj;
gc_mark_object(pic, (struct object *) node->s1);
LOOP(node->s2);
break;
}
case PIC_TYPE_ROPE_LEAF:
case PIC_TYPE_BLOB:
case PIC_TYPE_DATA:
break;
default:
PIC_UNREACHABLE();
}
}