conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

bootstrap

This commit is contained in:
Yuichi Nishiwaki 2017-04-14 23:40:07 +09:00
parent 70600fec3e
commit d99c460451
16 changed files with 1828 additions and 2957 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -78,7 +78,7 @@ src/init_contrib.c:
lib/ext/boot.c: piclib/compile.scm piclib/library.scm lib/ext/boot.c: piclib/compile.scm piclib/library.scm
cat piclib/compile.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c cat piclib/compile.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h $(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h
doc: docs/*.rst docs/contrib.rst doc: docs/*.rst docs/contrib.rst
$(MAKE) -C docs html $(MAKE) -C docs html

212
lib/cont.c
View File

@ -6,101 +6,22 @@
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
struct cont {
PIC_JMPBUF *jmp;
ptrdiff_t sp_offset;
ptrdiff_t ci_offset;
size_t arena_idx;
const struct code *ip;
pic_value dyn_env;
int retc;
pic_value *retv;
struct cont *prev;
};
static const pic_data_type cont_type = { "cont", NULL };
void
pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
{
cont->jmp = jmp;
/* save runtime context */
cont->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase;
cont->arena_idx = pic->arena_idx;
cont->dyn_env = pic->dyn_env;
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_vm_tear_off(pic);
/* load runtime context */
pic->sp = pic->stbase + cont->sp_offset;
pic->ci = pic->cibase + cont->ci_offset;
pic->arena_idx = cont->arena_idx;
pic->dyn_env = cont->dyn_env;
pic->ip = cont->ip;
pic->cc = cont->prev;
}
void
pic_exit_point(pic_state *pic)
{
pic->cc = pic->cc->prev;
}
static pic_value static pic_value
cont_call(pic_state *pic) applyk(pic_state *pic, pic_value proc, pic_value cont, int argc, pic_value *argv)
{ {
int argc; int i;
pic_value *argv;
struct cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv); #define MKCALL(argc) \
(pic->cxt->tmpcode[0] = OP_CALL, pic->cxt->tmpcode[1] = (argc), pic->cxt->tmpcode)
cont = pic_data(pic, pic_closure_ref(pic, 0)); pic->cxt->pc = MKCALL(argc + 1);
pic->cxt->sp = pic_make_frame_unsafe(pic, argc + 3);
/* check if continuation is alive */ pic->cxt->sp->regs[0] = proc;
for (cc = pic->cc; cc != NULL; cc = cc->prev) { pic->cxt->sp->regs[1] = cont;
if (cc == cont) { for (i = 0; i < argc; ++i) {
break; pic->cxt->sp->regs[i + 2] = argv[i];
}
} }
if (cc == NULL) { return pic_invalid_value(pic);
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 static pic_value
@ -108,34 +29,13 @@ valuesk(pic_state *pic, int argc, pic_value *argv)
{ {
int i; int i;
pic->cxt->pc = MKCALL(argc);
pic->cxt->sp = pic_make_frame_unsafe(pic, argc + 2);
pic->cxt->sp->regs[0] = pic->cxt->fp->regs[1];
for (i = 0; i < argc; ++i) { for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i]; pic->cxt->sp->regs[i + 1] = argv[i];
}
pic->ci->retc = argc;
return argc == 0 ? pic_undef_value(pic) : pic->sp[0];
}
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 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;
} }
return pic_invalid_value(pic);
} }
pic_value pic_value
@ -162,30 +62,59 @@ pic_vvalues(pic_state *pic, int n, va_list ap)
return valuesk(pic, n, retv); return valuesk(pic, n, retv);
} }
int static pic_value
pic_receive(pic_state *pic, int n, pic_value *argv) cont_call(pic_state *pic)
{ {
struct callinfo *ci; int argc;
int i, retc; pic_value *argv;
struct context *cxt, *c;
int i;
/* take info from discarded frame */ pic_get_args(pic, "*", &argc, &argv);
ci = pic->ci + 1;
retc = ci->retc;
for (i = 0; i < retc && i < n; ++i) { cxt = pic_data(pic, pic_closure_ref(pic, 0));
argv[i] = ci->fp[i];
/* check if continuation is alive */
for (c = pic->cxt; c != NULL; c = c->prev) {
if (c == cxt) {
break;
}
} }
return retc; if (c == NULL) {
pic_error(pic, "calling dead escape continuation", 0);
}
#define MKCALLK(argc) \
(cxt->tmpcode[0] = OP_CALL, cxt->tmpcode[1] = (argc), cxt->tmpcode)
cxt->pc = MKCALLK(argc);
cxt->sp = pic_make_frame_unsafe(pic, argc + 2);
cxt->sp->regs[0] = pic_closure_ref(pic, 1); /* cont. */
for (i = 0; i < argc; ++i) {
cxt->sp->regs[i + 1] = argv[i];
}
pic->cxt = cxt;
PIC_LONGJMP(pic, cxt->jmp, 1);
PIC_UNREACHABLE();
}
pic_value
pic_make_cont(pic_state *pic, struct context *cxt, pic_value k)
{
static const pic_data_type cxt_type = { "cxt", NULL };
return pic_lambda(pic, cont_call, 2, pic_data_value(pic, cxt, &cxt_type), k);
} }
static pic_value static pic_value
pic_cont_callcc(pic_state *pic) pic_cont_callcc(pic_state *pic)
{ {
pic_value f; pic_value f, args[1];
pic_get_args(pic, "l", &f); pic_get_args(pic, "l", &f);
return pic_callcc(pic, f); args[0] = pic_make_cont(pic, pic->cxt, pic->cxt->fp->regs[1]);
return pic_applyk(pic, f, 1, args);
} }
static pic_value static pic_value
@ -199,22 +128,31 @@ pic_cont_values(pic_state *pic)
return valuesk(pic, argc, argv); return valuesk(pic, argc, argv);
} }
static pic_value
receive_call(pic_state *pic)
{
int argc = pic->cxt->pc[1];
pic_value *args = &pic->cxt->fp->regs[1], consumer, cont;
/* receive_call is an inhabitant in the continuation side.
You can not use pic_get_args since it implicitly consumes the first argument. */
consumer = pic_closure_ref(pic, 0);
cont = pic_closure_ref(pic, 1);
return applyk(pic, consumer, cont, argc, args);
}
static pic_value static pic_value
pic_cont_call_with_values(pic_state *pic) pic_cont_call_with_values(pic_state *pic)
{ {
pic_value producer, consumer, retv[256]; pic_value producer, consumer, k;
int retc;
pic_get_args(pic, "ll", &producer, &consumer); pic_get_args(pic, "ll", &producer, &consumer);
pic_call(pic, producer, 0); k = pic_lambda(pic, receive_call, 2, consumer, pic->cxt->fp->regs[1]);
retc = pic_receive(pic, 256, retv); return applyk(pic, producer, k, 0, NULL);
if (retc > 256) {
pic_error(pic, "call-with-values: too many arguments", 1, pic_int_value(pic, retc));
}
return pic_applyk(pic, consumer, retc, retv);
} }
void void

48
lib/error.c
View File

@ -30,6 +30,23 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
#define pic_exc(pic) pic_ref(pic, "current-exception-handlers") #define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
PIC_JMPBUF *
pic_prepare_try(pic_state *pic)
{
struct context *cxt = pic_alloca(pic, sizeof(struct context));
cxt->ai = pic->cxt->ai;
pic->cxt->ai--; /* cxt should be freed after this try ends */
cxt->pc = NULL;
cxt->fp = NULL;
cxt->sp = NULL;
cxt->irep = NULL;
cxt->prev = pic->cxt;
pic->cxt = cxt;
return &cxt->jmp;
}
static pic_value static pic_value
native_exception_handler(pic_state *pic) native_exception_handler(pic_state *pic)
{ {
@ -37,28 +54,20 @@ native_exception_handler(pic_state *pic)
pic_get_args(pic, "o", &err); pic_get_args(pic, "o", &err);
pic->err = err; pic_call(pic, pic_closure_ref(pic, 0), 1, err);
pic_call(pic, pic_closure_ref(pic, 0), 1, pic_false_value(pic));
PIC_UNREACHABLE(); PIC_UNREACHABLE();
} }
void void
pic_start_try(pic_state *pic, PIC_JMPBUF *jmp) pic_enter_try(pic_state *pic)
{ {
struct cont *cont; pic_value cont, handler;
pic_value handler;
pic_value var, env; pic_value var, env;
/* call/cc */ /* call/cc */
cont = pic_make_cont(pic, pic->cxt, pic_invalid_value(pic));
cont = pic_alloca_cont(pic); handler = pic_lambda(pic, native_exception_handler, 1, cont);
pic_save_point(pic, cont, jmp);
handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont));
/* with-exception-handler */ /* with-exception-handler */
var = pic_exc(pic); var = pic_exc(pic);
env = pic_make_weak(pic); env = pic_make_weak(pic);
pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0))); pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
@ -66,17 +75,20 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
} }
void void
pic_end_try(pic_state *pic) pic_exit_try(pic_state *pic)
{ {
pic->dyn_env = pic_cdr(pic, pic->dyn_env); pic->dyn_env = pic_cdr(pic, pic->dyn_env);
pic->cxt = pic->cxt->prev;
pic_exit_point(pic);
} }
pic_value pic_value
pic_err(pic_state *pic) pic_abort_try(pic_state *pic)
{ {
return pic->err; pic_value err = pic->cxt->sp->regs[1];
pic->dyn_env = pic_cdr(pic, pic->dyn_env);
pic->cxt = pic->cxt->prev;
pic_protect(pic, err);
return err;
} }
pic_value pic_value

2492
lib/ext/boot.c
View File

File diff suppressed because it is too large Load Diff

974
lib/ext/load.c
View File

File diff suppressed because it is too large Load Diff

58
lib/gc.c
View File

@ -144,11 +144,11 @@ pic_free(pic_state *pic, void *ptr)
static void static void
gc_protect(pic_state *pic, struct object *obj) gc_protect(pic_state *pic, struct object *obj)
{ {
if (pic->arena_idx >= pic->arena_size) { if (pic->cxt->ai >= pic->arena_size) {
pic->arena_size = pic->arena_size * 2 + 1; pic->arena_size = pic->arena_size * 2 + 1;
pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size); pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
} }
pic->arena[pic->arena_idx++] = obj; pic->arena[pic->cxt->ai++] = obj;
} }
pic_value pic_value
@ -165,13 +165,13 @@ pic_protect(pic_state *pic, pic_value v)
size_t size_t
pic_enter(pic_state *pic) pic_enter(pic_state *pic)
{ {
return pic->arena_idx; return pic->cxt->ai;
} }
void void
pic_leave(pic_state *pic, size_t state) pic_leave(pic_state *pic, size_t state)
{ {
pic->arena_idx = state; pic->cxt->ai = state;
} }
void * void *
@ -238,24 +238,24 @@ gc_mark_object(pic_state *pic, struct object *obj)
break; break;
} }
case PIC_TYPE_PROC_FUNC: { case PIC_TYPE_PROC_FUNC: {
if (obj->u.proc.fp) { if (obj->u.proc.env) {
LOOP(obj->u.proc.fp); LOOP(obj->u.proc.env);
} }
break; break;
} }
case PIC_TYPE_PROC_IREP: { case PIC_TYPE_PROC_IREP: {
if (obj->u.proc.fp) { if (obj->u.proc.env) {
gc_mark_object(pic, (struct object *)obj->u.proc.fp); gc_mark_object(pic, (struct object *)obj->u.proc.env);
} }
LOOP(obj->u.proc.u.irep); LOOP(obj->u.proc.u.irep);
break; break;
} }
case PIC_TYPE_IREP: { case PIC_TYPE_IREP: {
size_t i; size_t i;
for (i = 0; i < obj->u.irep.npool; ++i) { for (i = 0; i < obj->u.irep.objc; ++i) {
gc_mark_object(pic, obj->u.irep.pool[i]); gc_mark(pic, obj->u.irep.obj[i]);
} }
for (i = 0; i < obj->u.irep.nirep; ++i) { for (i = 0; i < obj->u.irep.irepc; ++i) {
gc_mark_object(pic, (struct object *)obj->u.irep.irep[i]); gc_mark_object(pic, (struct object *)obj->u.irep.irep[i]);
} }
break; break;
@ -319,38 +319,32 @@ gc_mark_object(pic_state *pic, struct object *obj)
static void static void
gc_mark_phase(pic_state *pic) gc_mark_phase(pic_state *pic)
{ {
pic_value *stack; struct context *cxt;
struct callinfo *ci;
size_t j; size_t j;
assert(pic->heap->weaks == NULL); assert(pic->heap->weaks == NULL);
/* stack */ /* context */
for (stack = pic->stbase; stack != pic->sp; ++stack) { for (cxt = pic->cxt; cxt != NULL; cxt = cxt->prev) {
gc_mark(pic, *stack); if (cxt->fp) gc_mark_object(pic, (struct object *)cxt->fp);
} if (cxt->sp) gc_mark_object(pic, (struct object *)cxt->sp);
if (cxt->irep) gc_mark_object(pic, (struct object *)cxt->irep);
/* callinfo */
for (ci = pic->ci; ci != pic->cibase; --ci) {
if (ci->cxt) {
gc_mark_object(pic, (struct object *)ci->cxt);
}
} }
/* arena */ /* arena */
for (j = 0; j < pic->arena_idx; ++j) { for (j = 0; j < pic->cxt->ai; ++j) {
gc_mark_object(pic, (struct object *)pic->arena[j]); gc_mark_object(pic, (struct object *)pic->arena[j]);
} }
/* global variables */ /* global variables */
gc_mark(pic, pic->globals); gc_mark(pic, pic->globals);
/* error object */
gc_mark(pic, pic->err);
/* dynamic environment */ /* dynamic environment */
gc_mark(pic, pic->dyn_env); gc_mark(pic, pic->dyn_env);
/* top continuation */
gc_mark(pic, pic->halt);
/* features */ /* features */
gc_mark(pic, pic->features); gc_mark(pic, pic->features);
@ -422,10 +416,10 @@ gc_finalize_object(pic_state *pic, struct object *obj)
} }
case PIC_TYPE_IREP: { case PIC_TYPE_IREP: {
struct irep *irep = &obj->u.irep; struct irep *irep = &obj->u.irep;
pic_free(pic, irep->code); if ((irep->flags & IREP_CODE_STATIC) == 0) {
pic_free(pic, irep->ints); pic_free(pic, irep->code);
pic_free(pic, irep->nums); }
pic_free(pic, irep->pool); pic_free(pic, irep->obj);
pic_free(pic, irep->irep); pic_free(pic, irep->irep);
break; break;
} }
@ -434,7 +428,7 @@ gc_finalize_object(pic_state *pic, struct object *obj)
break; break;
} }
case PIC_TYPE_FRAME: { case PIC_TYPE_FRAME: {
pic_free(pic, obj->u.frame.storage); pic_free(pic, obj->u.frame.regs);
break; break;
} }

19
lib/include/picrin.h
View File

@ -297,20 +297,22 @@ pic_value pic_raise_continuable(pic_state *pic, pic_value err);
PIC_NORETURN void pic_raise(pic_state *, pic_value v); PIC_NORETURN void pic_raise(pic_state *, pic_value v);
PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...); PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...);
pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs);
#define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp)) #define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp))
#define pic_try_(cont, jmp) \ #define pic_try_(cont, jmp) \
do { \ do { \
extern void pic_start_try(pic_state *, PIC_JMPBUF *); \ extern PIC_JMPBUF *pic_prepare_try(pic_state *); \
extern void pic_end_try(pic_state *); \ extern void pic_enter_try(pic_state *); \
extern pic_value pic_err(pic_state *); \ extern void pic_exit_try(pic_state *); \
PIC_JMPBUF jmp; \ extern pic_value pic_abort_try(pic_state *); \
if (PIC_SETJMP(pic, jmp) == 0) { \ PIC_JMPBUF *jmp = pic_prepare_try(pic); \
pic_start_try(pic, &jmp); if (PIC_SETJMP(pic, *jmp) == 0) { \
pic_enter_try(pic);
#define pic_catch(e) pic_catch_(e, PIC_GENSYM(label)) #define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
#define pic_catch_(e, label) \ #define pic_catch_(e, label) \
pic_end_try(pic); \ pic_exit_try(pic); \
} else { \ } else { \
e = pic_err(pic); \ e = pic_abort_try(pic); \
goto label; \ goto label; \
} \ } \
} while (0); \ } while (0); \
@ -332,7 +334,6 @@ void pic_defvar(pic_state *, const char *name, pic_value v);
pic_value pic_funcall(pic_state *, const char *name, int n, ...); pic_value pic_funcall(pic_state *, const char *name, int n, ...);
pic_value pic_values(pic_state *, int n, ...); pic_value pic_values(pic_state *, int n, ...);
pic_value pic_vvalues(pic_state *, int n, va_list); pic_value pic_vvalues(pic_state *, int n, va_list);
int pic_receive(pic_state *, int n, pic_value *retv);
/* /*

28
lib/include/picrin/setup.h
View File

@ -60,34 +60,6 @@ void abort(void);
# define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100) # define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100)
#endif #endif
#ifndef PIC_STACK_SIZE
# define PIC_STACK_SIZE 8192
#endif
#ifndef PIC_RESCUE_SIZE
# define PIC_RESCUE_SIZE 30
#endif
#ifndef PIC_SYM_POOL_SIZE
# define PIC_SYM_POOL_SIZE (2 * 1024)
#endif
#ifndef PIC_IREP_SIZE
# define PIC_IREP_SIZE 8
#endif
#ifndef PIC_POOL_SIZE
# define PIC_POOL_SIZE 8
#endif
#ifndef PIC_SYMS_SIZE
# define PIC_SYMS_SIZE 32
#endif
#ifndef PIC_ISEQ_SIZE
# define PIC_ISEQ_SIZE 1024
#endif
/* check compatibility */ /* check compatibility */
#if __STDC_VERSION__ >= 199901L #if __STDC_VERSION__ >= 199901L

4
lib/number.c
View File

@ -72,7 +72,7 @@ pic_number_exact(pic_state *pic)
} else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \ } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \
return pic_float_value(pic, pic_float(pic, a) op pic_int(pic, b)); \ return pic_float_value(pic, pic_float(pic, a) op pic_int(pic, b)); \
} else { \ } else { \
pic_error(pic, #name ": non-number operand given", 0); \ pic_error(pic, #name ": non-number operand given", 2, a, b); \
} \ } \
PIC_UNREACHABLE(); \ PIC_UNREACHABLE(); \
} }
@ -95,7 +95,7 @@ pic_define_aop(pic_div, /, f == (int)f)
} else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \ } else if (pic_float_p(pic, a) && pic_int_p(pic, b)) { \
return pic_float(pic, a) op pic_int(pic, b); \ return pic_float(pic, a) op pic_int(pic, b); \
} else { \ } else { \
pic_error(pic, #name ": non-number operand given", 0); \ pic_error(pic, #name ": non-number operand given", 2, a, b); \
} \ } \
PIC_UNREACHABLE(); \ PIC_UNREACHABLE(); \
} }

52
lib/object.h
View File

@ -78,24 +78,44 @@ struct record {
pic_value datum; pic_value datum;
}; };
enum {
OP_HALT = 0x00, /* 0x00 OP_HALT */
OP_CALL = 0x01, /* 0x01 0x** OP_CALL argc */
OP_PROC = 0x02, /* 0x02 0x** 0x** OP_PROC dest irep */
OP_LOAD = 0x03, /* 0x03 0x** 0x** OP_LOAD dest i */
OP_LREF = 0x04, /* 0x04 0x** 0x** 0x** OP_LREF dest n i */
OP_LSET = 0x05, /* 0x05 0x** 0x** 0x** OP_LSET src n i */
OP_GREF = 0x06, /* 0x06 0x** 0x** OP_GREF dest i */
OP_GSET = 0x07, /* 0x07 0x** 0x** OP_GSET src i */
OP_COND = 0x08, /* 0x08 0x** 0x** 0x** OP_COND c offset */
OP_LOADT = 0x09, /* 0x09 0x** OP_LOADT dest */
OP_LOADF = 0x0A, /* 0x0A 0x** OP_LOADF dest */
OP_LOADN = 0x0B, /* 0x0B 0x** OP_LOADN dest */
OP_LOADU = 0x0C, /* 0x0C 0x** OP_LOADU dest */
OP_LOADI = 0x0D, /* 0x0D 0x** 0x** OP_LOADI dest i */
};
typedef unsigned char code_t;
#define IREP_VARG 1
#define IREP_CODE_STATIC 2
struct irep { struct irep {
OBJECT_HEADER OBJECT_HEADER
int argc, localc, capturec; unsigned char argc;
bool varg; unsigned char flags;
struct code *code; unsigned char frame_size;
unsigned char irepc, objc;
struct irep **irep; struct irep **irep;
int *ints; pic_value *obj;
double *nums; const code_t *code;
struct object **pool;
size_t ncode, nirep, nints, nnums, npool;
}; };
struct frame { struct frame {
OBJECT_HEADER OBJECT_HEADER
int regc; unsigned char regc;
pic_value *regs; pic_value *regs;
struct frame *up; struct frame *up;
pic_value *storage;
}; };
struct proc { struct proc {
@ -104,7 +124,7 @@ struct proc {
pic_func_t func; pic_func_t func;
struct irep *irep; struct irep *irep;
} u; } u;
struct frame *fp; struct frame *env;
}; };
enum { enum {
@ -243,20 +263,20 @@ DEFPTR(irep, struct irep)
#undef pic_port_p #undef pic_port_p
struct object *pic_obj_alloc(pic_state *, int type); struct object *pic_obj_alloc(pic_state *, int type);
struct object *pic_obj_alloc_unsafe(pic_state *, int type);
pic_value pic_make_proc_func(pic_state *, pic_func_t, int, pic_value *); struct frame *pic_make_frame_unsafe(pic_state *, int n);
pic_value pic_make_proc_irep(pic_state *, struct irep *, struct frame *); pic_value pic_make_proc_irep_unsafe(pic_state *, struct irep *, struct frame *);
pic_value pic_make_proc_func(pic_state *, pic_func_t);
pic_value pic_make_record(pic_state *, pic_value type, pic_value datum); pic_value pic_make_record(pic_state *, pic_value type, pic_value datum);
pic_value pic_record_type(pic_state *pic, pic_value record); pic_value pic_record_type(pic_state *pic, pic_value record);
pic_value pic_record_datum(pic_state *pic, pic_value record); pic_value pic_record_datum(pic_state *pic, pic_value record);
struct context;
pic_value pic_make_cont(pic_state *pic, struct context *cxt, pic_value k);
struct rope *pic_rope_incref(struct rope *); struct rope *pic_rope_incref(struct rope *);
void pic_rope_decref(pic_state *, struct rope *); void pic_rope_decref(pic_state *, struct rope *);
struct cont *pic_alloca_cont(pic_state *);
pic_value pic_make_cont(pic_state *, struct cont *);
void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
void pic_exit_point(pic_state *);
void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */ void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */

689
lib/proc.c
View File

@ -5,7 +5,22 @@
#include "picrin.h" #include "picrin.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
#include "vm.h"
struct frame *
pic_make_frame_unsafe(pic_state *pic, int n)
{
struct frame *fp;
int i;
fp = (struct frame *)pic_obj_alloc_unsafe(pic, PIC_TYPE_FRAME);
fp->regs = n ? pic_malloc(pic, sizeof(pic_value) * n) : NULL;
fp->regc = n;
fp->up = NULL;
for (i = 0; i < n; ++i) {
fp->regs[i] = pic_invalid_value(pic);
}
return fp;
}
pic_value pic_value
pic_lambda(pic_state *pic, pic_func_t f, int n, ...) pic_lambda(pic_state *pic, pic_func_t f, int n, ...)
@ -22,47 +37,42 @@ pic_lambda(pic_state *pic, pic_func_t f, int n, ...)
pic_value pic_value
pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap) pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap)
{ {
pic_value *env = pic_alloca(pic, sizeof(pic_value) * n); struct proc *proc;
int i; int i;
for (i = 0; i < n; ++i) { assert(n >= 0);
env[i] = va_arg(ap, pic_value);
}
return pic_make_proc_func(pic, f, n, env);
}
pic_value
pic_make_proc_func(pic_state *pic, pic_func_t func, int n, pic_value *env)
{
struct proc *proc;
struct frame *fp = NULL;
if (n > 0) {
int i;
fp = (struct frame *)pic_obj_alloc(pic, PIC_TYPE_FRAME);
fp->storage = pic_malloc(pic, sizeof(pic_value) * n);
fp->regc = n;
fp->regs = fp->storage;
fp->up = NULL;
for (i = 0; i < n; ++i) {
fp->regs[i] = env[i];
}
}
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_FUNC); proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_FUNC);
proc->u.func = func; proc->u.func = f;
proc->fp = fp; proc->env = NULL;
if (n != 0) {
proc->env = pic_make_frame_unsafe(pic, n);
}
for (i = 0; i < n; ++i) {
proc->env->regs[i] = va_arg(ap, pic_value);
}
return obj_value(pic, proc); return obj_value(pic, proc);
} }
pic_value pic_value
pic_make_proc_irep(pic_state *pic, struct irep *irep, struct frame *fp) pic_make_proc_func(pic_state *pic, pic_func_t func)
{ {
struct proc *proc; struct proc *proc;
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP); proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_FUNC);
proc->u.func = func;
proc->env = NULL;
return obj_value(pic, proc);
}
pic_value
pic_make_proc_irep_unsafe(pic_state *pic, struct irep *irep, struct frame *fp)
{
struct proc *proc;
proc = (struct proc *)pic_obj_alloc_unsafe(pic, PIC_TYPE_PROC_IREP);
proc->u.irep = irep; proc->u.irep = irep;
proc->fp = fp; proc->env = fp;
return obj_value(pic, proc); return obj_value(pic, proc);
} }
@ -71,13 +81,15 @@ arg_error(pic_state *pic, int actual, bool varg, int expected)
{ {
const char *msg; const char *msg;
msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected), NULL); msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual - 1, (varg ? "at least " : ""), expected - 1), NULL);
pic_error(pic, msg, 0); pic_error(pic, msg, 0);
} }
#define GET_PROC(pic) (pic->ci->fp[0]) #define GET_ARGC(pic) (pic->cxt->pc[1])
#define GET_ARG(pic,n) (pic->ci->fp[(n)+1]) #define GET_PROC(pic) (pic->cxt->fp->regs[0])
#define GET_CONT(pic) (pic->cxt->fp->regs[1])
#define GET_ARG(pic,n) (pic->cxt->fp->regs[(n)+2])
/** /**
* char type desc. * char type desc.
@ -112,7 +124,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
const char *p = format; const char *p = format;
int paramc = 0, optc = 0; int paramc = 0, optc = 0;
bool proc = 0, rest = 0, opt = 0; bool proc = 0, rest = 0, opt = 0;
int i, argc = pic->ci->argc - 1; int i, argc = GET_ARGC(pic) - 1; /* one for continuation */
va_list ap; va_list ap;
/* parse format */ /* parse format */
@ -301,25 +313,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
pic_value pic_value
pic_closure_ref(pic_state *pic, int n) pic_closure_ref(pic_state *pic, int n)
{ {
struct proc *proc = proc_ptr(pic, GET_PROC(pic)); struct frame *fp = pic->cxt->fp->up;
assert(n >= 0); assert(n >= 0);
if (proc->fp == NULL || proc->fp->regc <= n) { if (fp == NULL || fp->regc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
} }
return proc->fp->regs[n]; return fp->regs[n];
} }
void void
pic_closure_set(pic_state *pic, int n, pic_value v) pic_closure_set(pic_state *pic, int n, pic_value v)
{ {
struct proc *proc = proc_ptr(pic, GET_PROC(pic)); struct frame *fp = pic->cxt->fp->up;
assert(n >= 0); assert(n >= 0);
if (proc->fp == NULL || proc->fp->regc <= n) { if (fp == NULL || fp->regc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
} }
proc->fp->regs[n] = v; fp->regs[n] = v;
} }
pic_value pic_value
@ -346,513 +356,200 @@ pic_vcall(pic_state *pic, pic_value proc, int n, va_list ap)
return pic_apply(pic, proc, n, args); return pic_apply(pic, proc, n, args);
} }
static void
vm_push_cxt(pic_state *pic)
{
struct callinfo *ci = pic->ci;
ci->cxt = (struct frame *)pic_obj_alloc(pic, PIC_TYPE_FRAME);
ci->cxt->storage = pic_malloc(pic, sizeof(pic_value) * ci->regc);
ci->cxt->up = ci->up;
ci->cxt->regc = ci->regc;
ci->cxt->regs = ci->regs;
}
static void
vm_tear_off(struct callinfo *ci)
{
struct frame *cxt;
int i;
assert(ci->cxt != NULL);
cxt = ci->cxt;
if (cxt->regs == cxt->storage) {
return; /* is torn off */
}
for (i = 0; i < cxt->regc; ++i) {
cxt->storage[i] = cxt->regs[i];
}
cxt->regs = cxt->storage;
}
void
pic_vm_tear_off(pic_state *pic)
{
struct callinfo *ci;
for (ci = pic->ci; ci > pic->cibase; ci--) {
if (ci->cxt != NULL) {
vm_tear_off(ci);
}
}
}
/* for arithmetic instructions */
pic_value pic_add(pic_state *, pic_value, pic_value);
pic_value pic_sub(pic_state *, pic_value, pic_value);
pic_value pic_mul(pic_state *, pic_value, pic_value);
pic_value pic_div(pic_state *, pic_value, pic_value);
bool pic_eq(pic_state *, pic_value, pic_value);
bool pic_lt(pic_state *, pic_value, pic_value);
bool pic_le(pic_state *, pic_value, pic_value);
bool pic_gt(pic_state *, pic_value, pic_value);
bool pic_ge(pic_state *, pic_value, pic_value);
pic_value pic_value
pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv) pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
{ {
struct code c; struct context cxt;
size_t ai = pic_enter(pic); size_t arena_base = pic->cxt->ai;
struct code boot[2];
int i;
#define PUSH(v) ((*pic->sp = (v)), pic->sp++) #define MKCALL(argc) (cxt.tmpcode[0] = OP_CALL, cxt.tmpcode[1] = (argc), cxt.tmpcode)
#define POP() (*--pic->sp)
#define PUSHCI() (++pic->ci) cxt.pc = MKCALL(argc + 1);
#define POPCI() (pic->ci--) cxt.sp = pic_make_frame_unsafe(pic, argc + 3);
cxt.sp->regs[0] = proc;
cxt.sp->regs[1] = pic->halt;
if (argc != 0) {
int i;
for (i = 0; i < argc; ++i) {
cxt.sp->regs[i + 2] = argv[i];
}
}
cxt.fp = NULL;
cxt.irep = NULL;
cxt.ai = pic->cxt->ai;
cxt.prev = pic->cxt;
pic->cxt = &cxt;
PUSH(proc); if (PIC_SETJMP(pic, cxt.jmp) != 0) {
/* pass */
for (i = 0; i < argc; ++i) {
PUSH(argv[i]);
} }
/* boot! */ #define SAVE (cxt.ai = arena_base)
boot[0].insn = OP_CALL;
boot[0].a = argc + 1; #define A (cxt.pc[1])
boot[1].insn = OP_STOP; #define B (cxt.pc[2])
pic->ip = boot; #define C (cxt.pc[3])
#define Bx ((C << 8) + B)
#define REG(i) (cxt.sp->regs[i])
#if PIC_DIRECT_THREADED_VM #if PIC_DIRECT_THREADED_VM
# define VM_LOOP JUMP; # define VM_LOOP JUMP;
# define CASE(x) L_##x: # define CASE(x) L_##x:
# define NEXT pic->ip++; JUMP; # define NEXT(n) (cxt.pc += n); JUMP;
# define JUMP c = *pic->ip; goto *oplabels[c.insn]; # define JUMP goto *oplabels[*cxt.pc];
# define VM_LOOP_END # define VM_LOOP_END
#else #else
# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) { # define VM_LOOP for (;;) { switch (*cxt.pc) {
# define CASE(x) case x: # define CASE(x) case x:
# define NEXT pic->ip++; break # define NEXT(n) (cxt.pc += n); break
# define JUMP break # define JUMP break
# define VM_LOOP_END } } # define VM_LOOP_END } }
#endif #endif
#if PIC_DIRECT_THREADED_VM #if PIC_DIRECT_THREADED_VM
static const void *oplabels[] = { static const void *oplabels[] = {
&&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHUNDEF, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, [OP_HALT] = &&L_OP_HALT, [OP_CALL] = &&L_OP_CALL, [OP_PROC] = &&L_OP_PROC,
&&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHFLOAT, [OP_LOAD] = &&L_OP_LOAD, [OP_LREF] = &&L_OP_LREF, [OP_LSET] = &&L_OP_LSET,
&&L_OP_PUSHCHAR, &&L_OP_PUSHEOF, &&L_OP_PUSHCONST, [OP_GREF] = &&L_OP_GREF, [OP_GSET] = &&L_OP_GSET, [OP_COND] = &&L_OP_COND,
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, [OP_LOADT] = &&L_OP_LOADT, [OP_LOADF] = &&L_OP_LOADF, [OP_LOADN] = &&L_OP_LOADN,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, [OP_LOADU] = &&L_OP_LOADU, [OP_LOADI] = &&L_OP_LOADI
&&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_SYMBOLP, &&L_OP_PAIRP,
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
&&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_GT, &&L_OP_GE, &&L_OP_STOP
}; };
#endif #endif
VM_LOOP { VM_LOOP {
CASE(OP_NOP) { CASE(OP_HALT) {
NEXT; pic_value ret = cxt.fp->regs[1];
} pic->cxt = pic->cxt->prev;
CASE(OP_POP) { pic_protect(pic, ret);
(void)(POP()); return ret;
NEXT;
}
CASE(OP_PUSHUNDEF) {
PUSH(pic_undef_value(pic));
NEXT;
}
CASE(OP_PUSHNIL) {
PUSH(pic_nil_value(pic));
NEXT;
}
CASE(OP_PUSHTRUE) {
PUSH(pic_true_value(pic));
NEXT;
}
CASE(OP_PUSHFALSE) {
PUSH(pic_false_value(pic));
NEXT;
}
CASE(OP_PUSHINT) {
PUSH(pic_int_value(pic, pic->ci->irep->ints[c.a]));
NEXT;
}
CASE(OP_PUSHFLOAT) {
PUSH(pic_float_value(pic, pic->ci->irep->nums[c.a]));
NEXT;
}
CASE(OP_PUSHCHAR) {
PUSH(pic_char_value(pic, pic->ci->irep->ints[c.a]));
NEXT;
}
CASE(OP_PUSHEOF) {
PUSH(pic_eof_object(pic));
NEXT;
}
CASE(OP_PUSHCONST) {
PUSH(obj_value(pic, pic->ci->irep->pool[c.a]));
NEXT;
}
CASE(OP_GREF) {
PUSH(pic_global_ref(pic, obj_value(pic, pic->ci->irep->pool[c.a])));
NEXT;
}
CASE(OP_GSET) {
pic_global_set(pic, obj_value(pic, pic->ci->irep->pool[c.a]), POP());
PUSH(pic_undef_value(pic));
NEXT;
}
CASE(OP_LREF) {
struct callinfo *ci = pic->ci;
struct irep *irep = ci->irep;
if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
if (c.a >= irep->argc + irep->localc) {
PUSH(ci->cxt->regs[c.a - (ci->regs - ci->fp)]);
NEXT;
}
}
PUSH(pic->ci->fp[c.a]);
NEXT;
}
CASE(OP_LSET) {
struct callinfo *ci = pic->ci;
struct irep *irep = ci->irep;
if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
if (c.a >= irep->argc + irep->localc) {
ci->cxt->regs[c.a - (ci->regs - ci->fp)] = POP();
PUSH(pic_undef_value(pic));
NEXT;
}
}
pic->ci->fp[c.a] = POP();
PUSH(pic_undef_value(pic));
NEXT;
}
CASE(OP_CREF) {
int depth = c.a;
struct frame *cxt;
cxt = pic->ci->up;
while (--depth) {
cxt = cxt->up;
}
PUSH(cxt->regs[c.b]);
NEXT;
}
CASE(OP_CSET) {
int depth = c.a;
struct frame *cxt;
cxt = pic->ci->up;
while (--depth) {
cxt = cxt->up;
}
cxt->regs[c.b] = POP();
PUSH(pic_undef_value(pic));
NEXT;
}
CASE(OP_JMP) {
pic->ip += c.a;
JUMP;
}
CASE(OP_JMPIF) {
pic_value v;
v = POP();
if (! pic_false_p(pic, v)) {
pic->ip += c.a;
JUMP;
}
NEXT;
} }
CASE(OP_CALL) { CASE(OP_CALL) {
pic_value x, v;
struct callinfo *ci;
struct proc *proc; struct proc *proc;
if (! pic_proc_p(pic, REG(0))) {
if (c.a == -1) { pic_error(pic, "invalid application", 1, REG(0));
pic->sp += pic->ci[1].retc - 1;
c.a = pic->ci[1].retc + 1;
} }
proc = proc_ptr(pic, REG(0));
L_CALL:
x = pic->sp[-c.a];
if (! pic_proc_p(pic, x)) {
pic_error(pic, "invalid application", 1, x);
}
proc = proc_ptr(pic, x);
if (pic->sp >= pic->stend) {
pic_panic(pic, "VM stack overflow");
}
ci = PUSHCI();
ci->argc = c.a;
ci->retc = 1;
ci->ip = pic->ip;
ci->fp = pic->sp - c.a;
ci->irep = NULL;
ci->cxt = NULL;
if (proc->tt == PIC_TYPE_PROC_FUNC) { if (proc->tt == PIC_TYPE_PROC_FUNC) {
pic_value v;
/* invoke! */ cxt.sp->up = proc->env; /* push static link */
cxt.fp = cxt.sp;
cxt.sp = NULL;
cxt.irep = NULL;
v = proc->u.func(pic); v = proc->u.func(pic);
pic->sp[0] = v; if (cxt.sp != NULL) { /* tail call */
pic->sp += pic->ci->retc; SAVE;
JUMP;
pic_leave(pic, ai); } else {
goto L_RET; cxt.sp = pic_make_frame_unsafe(pic, 3);
} cxt.sp->regs[0] = cxt.fp->regs[1]; /* cont. */
else { cxt.sp->regs[1] = v;
cxt.pc = MKCALL(1);
SAVE;
JUMP;
}
} else {
struct irep *irep = proc->u.irep; struct irep *irep = proc->u.irep;
int i;
pic_value rest;
ci->irep = irep; if (A != irep->argc) {
if (ci->argc != irep->argc) { if (! ((irep->flags & IREP_VARG) != 0 && A >= irep->argc)) {
if (! (irep->varg && ci->argc >= irep->argc)) { arg_error(pic, A, (irep->flags & IREP_VARG), irep->argc);
arg_error(pic, ci->argc - 1, irep->varg, irep->argc - 1); }
} }
} if (irep->flags & IREP_VARG) {
/* prepare rest args */ REG(irep->argc + 1) = pic_make_list(pic, A - irep->argc, &REG(irep->argc + 1));
if (irep->varg) { SAVE; /* TODO: get rid of this */
rest = pic_nil_value(pic); }
for (i = 0; i < ci->argc - irep->argc; ++i) {
pic_protect(pic, v = POP());
rest = pic_cons(pic, v, rest);
}
PUSH(rest);
}
/* prepare local variable area */
if (irep->localc > 0) {
int l = irep->localc;
if (irep->varg) {
--l;
}
for (i = 0; i < l; ++i) {
PUSH(pic_undef_value(pic));
}
}
/* prepare cxt */ cxt.sp->up = proc->env; /* push static link */
ci->up = proc->fp; cxt.fp = cxt.sp;
ci->regc = irep->capturec; cxt.sp = pic_make_frame_unsafe(pic, irep->frame_size);
ci->regs = ci->fp + irep->argc + irep->localc; cxt.pc = irep->code;
cxt.irep = irep;
pic->ip = irep->code; JUMP;
pic_leave(pic, ai);
JUMP;
} }
} }
CASE(OP_TAILCALL) { CASE(OP_LREF) {
int i, argc; struct frame *f;
pic_value *argv; int depth = B;
struct callinfo *ci; for (f = cxt.fp; depth--; f = f->up);
REG(A) = f->regs[C];
if (pic->ci->cxt != NULL) { NEXT(4);
vm_tear_off(pic->ci); }
CASE(OP_LSET) {
struct frame *f;
int depth = B;
for (f = cxt.fp; depth--; f = f->up);
f->regs[C] = REG(A);
NEXT(4);
}
CASE(OP_GREF) {
REG(A) = pic_global_ref(pic, cxt.irep->obj[B]);
NEXT(3);
}
CASE(OP_GSET) {
pic_global_set(pic, cxt.irep->obj[B], REG(A));
NEXT(3);
}
CASE(OP_COND) {
if (pic_false_p(pic, REG(A))) {
NEXT(Bx);
} else {
NEXT(4);
} }
if (c.a == -1) {
pic->sp += pic->ci[1].retc - 1;
c.a = pic->ci[1].retc + 1;
}
argc = c.a;
argv = pic->sp - argc;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
}
ci = POPCI();
pic->sp = ci->fp + argc;
pic->ip = ci->ip;
/* c is not changed */
goto L_CALL;
} }
CASE(OP_RET) { CASE(OP_PROC) {
int i, retc; REG(A) = pic_make_proc_irep_unsafe(pic, cxt.irep->irep[B], cxt.fp);
pic_value *retv; NEXT(3);
struct callinfo *ci;
if (pic->ci->cxt != NULL) {
vm_tear_off(pic->ci);
}
assert(pic->ci->retc == 1);
L_RET:
retc = pic->ci->retc;
retv = pic->sp - retc;
if (retc == 0) {
pic->ci->fp[0] = retv[0]; /* copy at least once */
}
for (i = 0; i < retc; ++i) {
pic->ci->fp[i] = retv[i];
}
ci = POPCI();
pic->sp = ci->fp + 1; /* advance only one! */
pic->ip = ci->ip;
NEXT;
} }
CASE(OP_LAMBDA) { CASE(OP_LOAD) {
if (pic->ci->cxt == NULL) { REG(A) = cxt.irep->obj[B];
vm_push_cxt(pic); NEXT(3);
}
PUSH(pic_make_proc_irep(pic, pic->ci->irep->irep[c.a], pic->ci->cxt));
pic_leave(pic, ai);
NEXT;
} }
CASE(OP_LOADU) {
CASE(OP_CONS) { REG(A) = pic_undef_value(pic);
pic_value a, b; NEXT(2);
pic_protect(pic, b = POP());
pic_protect(pic, a = POP());
PUSH(pic_cons(pic, a, b));
pic_leave(pic, ai);
NEXT;
} }
CASE(OP_CAR) { CASE(OP_LOADT) {
pic_value p; REG(A) = pic_true_value(pic);
p = POP(); NEXT(2);
PUSH(pic_car(pic, p));
NEXT;
} }
CASE(OP_CDR) { CASE(OP_LOADF) {
pic_value p; REG(A) = pic_false_value(pic);
p = POP(); NEXT(2);
PUSH(pic_cdr(pic, p));
NEXT;
} }
CASE(OP_NILP) { CASE(OP_LOADN) {
pic_value p; REG(A) = pic_nil_value(pic);
p = POP(); NEXT(2);
PUSH(pic_bool_value(pic, pic_nil_p(pic, p)));
NEXT;
} }
CASE(OP_SYMBOLP) { CASE(OP_LOADI) {
pic_value p; REG(A) = pic_int_value(pic, (signed char) B);
p = POP(); NEXT(3);
PUSH(pic_bool_value(pic, pic_sym_p(pic, p)));
NEXT;
} }
CASE(OP_PAIRP) { } VM_LOOP_END
pic_value p;
p = POP();
PUSH(pic_bool_value(pic, pic_pair_p(pic, p)));
NEXT;
}
CASE(OP_NOT) {
pic_value v;
v = pic_false_p(pic, POP()) ? pic_true_value(pic) : pic_false_value(pic);
PUSH(v);
NEXT;
}
CASE(OP_ADD) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_add(pic, a, b));
NEXT;
}
CASE(OP_SUB) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_sub(pic, a, b));
NEXT;
}
CASE(OP_MUL) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_mul(pic, a, b));
NEXT;
}
CASE(OP_DIV) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_div(pic, a, b));
NEXT;
}
CASE(OP_EQ) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic, pic_eq(pic, a, b)));
NEXT;
}
CASE(OP_LE) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic, pic_le(pic, a, b)));
NEXT;
}
CASE(OP_LT) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic, pic_lt(pic, a, b)));
NEXT;
}
CASE(OP_GE) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic, pic_ge(pic, a, b)));
NEXT;
}
CASE(OP_GT) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic, pic_gt(pic, a, b)));
NEXT;
}
CASE(OP_STOP) {
return pic_protect(pic, POP());
}
} VM_LOOP_END;
} }
pic_value pic_value
pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args) pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args)
{ {
static const struct code iseq[2] = { { OP_NOP, 0, 0 }, { OP_TAILCALL, -1, 0 } }; const code_t *pc;
pic_value *sp; struct frame *sp;
struct callinfo *ci;
int i;
*pic->sp++ = proc; #define MKCALLK(argc) \
(pic->cxt->tmpcode[0] = OP_CALL, pic->cxt->tmpcode[1] = (argc), pic->cxt->tmpcode)
sp = pic->sp; pc = MKCALLK(argc + 1);
for (i = 0; i < argc; ++i) { sp = pic_make_frame_unsafe(pic, argc + 3);
*sp++ = args[i]; sp->regs[0] = proc;
} sp->regs[1] = GET_CONT(pic);
if (argc != 0) {
ci = PUSHCI(); int i;
ci->ip = iseq; for (i = 0; i < argc; ++i) {
ci->fp = pic->sp; sp->regs[i + 2] = args[i];
ci->retc = (int)argc; }
if (ci->retc == 0) {
return pic_undef_value(pic);
} else {
return args[0];
} }
pic->cxt->pc = pc;
pic->cxt->sp = sp;
return pic_invalid_value(pic);
} }
static pic_value static pic_value

87
lib/state.c
View File

@ -168,29 +168,18 @@ pic_open(pic_allocf allocf, void *userdata)
/* user data */ /* user data */
pic->userdata = userdata; pic->userdata = userdata;
/* continuation chain */ /* context */
pic->cc = NULL; pic->default_cxt.ai = 0;
pic->default_cxt.pc = NULL;
/* prepare VM stack */ pic->default_cxt.fp = NULL;
pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value)); pic->default_cxt.sp = NULL;
pic->stend = pic->stbase + PIC_STACK_SIZE; pic->default_cxt.irep = NULL;
pic->default_cxt.prev = NULL;
if (! pic->sp) { pic->cxt = &pic->default_cxt;
goto EXIT_SP;
}
/* callinfo */
pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(struct callinfo));
pic->ciend = pic->cibase + PIC_STACK_SIZE;
if (! pic->ci) {
goto EXIT_CI;
}
/* arena */ /* arena */
pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *)); pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *));
pic->arena_size = PIC_ARENA_SIZE; pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
if (! pic->arena) { if (! pic->arena) {
goto EXIT_ARENA; goto EXIT_ARENA;
@ -214,12 +203,29 @@ pic_open(pic_allocf allocf, void *userdata)
/* dynamic environment */ /* dynamic environment */
pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic)); pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
/* top continuation */
{
static const code_t halt_code[] = { 0x00, 0x01 };
struct irep *irep;
struct proc *proc;
irep = (struct irep *)pic_obj_alloc(pic, PIC_TYPE_IREP);
irep->argc = 1;
irep->flags = IREP_CODE_STATIC;
irep->frame_size = 1;
irep->irepc = 0;
irep->objc = 0;
irep->irep = NULL;
irep->obj = NULL;
irep->code = halt_code;
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
proc->u.irep = irep;
proc->env = NULL;
pic->halt = obj_value(pic, proc);
}
/* panic handler */ /* panic handler */
pic->panicf = NULL; pic->panicf = NULL;
/* error object */
pic->err = pic_invalid_value(pic);
/* turn on GC */ /* turn on GC */
pic->gc_enable = true; pic->gc_enable = true;
@ -230,10 +236,6 @@ pic_open(pic_allocf allocf, void *userdata)
return pic; return pic;
EXIT_ARENA: EXIT_ARENA:
allocf(userdata, pic->ci, 0);
EXIT_CI:
allocf(userdata, pic->sp, 0);
EXIT_SP:
allocf(userdata, pic, 0); allocf(userdata, pic, 0);
EXIT_PIC: EXIT_PIC:
return NULL; return NULL;
@ -245,24 +247,25 @@ pic_close(pic_state *pic)
pic_allocf allocf = pic->allocf; pic_allocf allocf = pic->allocf;
/* clear out root objects */ /* clear out root objects */
pic->sp = pic->stbase; pic->cxt = &pic->default_cxt;
pic->ci = pic->cibase; pic->cxt->ai = 0;
pic->arena_idx = 0; pic->halt = pic_invalid_value(pic);
pic->err = pic_invalid_value(pic);
pic->globals = pic_invalid_value(pic); pic->globals = pic_invalid_value(pic);
pic->features = pic_invalid_value(pic); pic->features = pic_invalid_value(pic);
pic->dyn_env = pic_invalid_value(pic); pic->dyn_env = pic_invalid_value(pic);
assert(pic->cxt->pc == NULL);
assert(pic->cxt->fp == NULL);
assert(pic->cxt->sp == NULL);
assert(pic->cxt->irep == NULL);
assert(pic->cxt->prev == NULL);
/* free all heap objects */ /* free all heap objects */
pic_gc(pic); pic_gc(pic);
/* free heaps */ /* free heaps */
pic_heap_close(pic, pic->heap); pic_heap_close(pic, pic->heap);
/* free runtime context */
allocf(pic->userdata, pic->stbase, 0);
allocf(pic->userdata, pic->cibase, 0);
/* free global stacks */ /* free global stacks */
kh_destroy(oblist, &pic->oblist); kh_destroy(oblist, &pic->oblist);
@ -280,18 +283,20 @@ pic_global_ref(pic_state *pic, pic_value sym)
pic_error(pic, "undefined variable", 1, sym); pic_error(pic, "undefined variable", 1, sym);
} }
val = pic_dict_ref(pic, pic->globals, sym); val = pic_dict_ref(pic, pic->globals, sym);
if (pic_invalid_p(pic, val)) { /* FIXME */
pic_error(pic, "uninitialized global variable", 1, sym); /* if (pic_invalid_p(pic, val)) { */
} /* pic_error(pic, "uninitialized global variable", 1, sym); */
/* } */
return val; return val;
} }
void void
pic_global_set(pic_state *pic, pic_value sym, pic_value value) pic_global_set(pic_state *pic, pic_value sym, pic_value value)
{ {
if (! pic_dict_has(pic, pic->globals, sym)) { /* FIXME */
pic_error(pic, "undefined variable", 1, sym); /* if (! pic_dict_has(pic, pic->globals, sym)) { */
} /* pic_error(pic, "undefined variable", 1, sym); */
/* } */
pic_dict_set(pic, pic->globals, sym, value); pic_dict_set(pic, pic->globals, sym, value);
} }
@ -321,7 +326,7 @@ pic_define(pic_state *pic, const char *name, pic_value val)
void void
pic_defun(pic_state *pic, const char *name, pic_func_t f) pic_defun(pic_state *pic, const char *name, pic_func_t f)
{ {
pic_define(pic, name, pic_make_proc_func(pic, f, 0, NULL)); pic_define(pic, name, pic_make_proc_func(pic, f));
} }
void void

42
lib/state.h
View File

@ -10,34 +10,30 @@ extern "C" {
#endif #endif
#include "khash.h" #include "khash.h"
#include "vm.h" #include "object.h"
struct callinfo {
int argc, retc;
const struct code *ip;
pic_value *fp;
struct irep *irep;
struct frame *cxt;
int regc;
pic_value *regs;
struct frame *up;
};
KHASH_DECLARE(oblist, struct string *, struct symbol *) KHASH_DECLARE(oblist, struct string *, struct symbol *)
struct context {
PIC_JMPBUF jmp;
size_t ai;
/* vm */
const code_t *pc;
struct frame *sp;
struct frame *fp;
struct irep *irep;
code_t tmpcode[2];
struct context *prev;
};
struct pic_state { struct pic_state {
pic_allocf allocf; pic_allocf allocf;
void *userdata; void *userdata;
struct cont *cc; struct context *cxt, default_cxt;
pic_value *sp;
pic_value *stbase, *stend;
struct callinfo *ci;
struct callinfo *cibase, *ciend;
const struct code *ip;
pic_value dyn_env; pic_value dyn_env;
@ -48,9 +44,9 @@ struct pic_state {
bool gc_enable; bool gc_enable;
struct heap *heap; struct heap *heap;
struct object **arena; struct object **arena;
size_t arena_size, arena_idx; size_t arena_size;
pic_value err; pic_value halt; /* top continuation */
pic_panicf panicf; pic_panicf panicf;
}; };

65
lib/vm.h
View File

@ -1,65 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_VM_H
#define PICRIN_VM_H
#if defined(__cplusplus)
extern "C" {
#endif
enum {
OP_NOP = 0,
OP_POP = 1,
OP_PUSHUNDEF = 2,
OP_PUSHNIL = 3,
OP_PUSHTRUE = 4,
OP_PUSHFALSE = 5,
OP_PUSHINT = 6,
OP_PUSHFLOAT = 7,
OP_PUSHCHAR = 8,
OP_PUSHEOF = 9,
OP_PUSHCONST = 10,
OP_GREF = 11,
OP_GSET = 12,
OP_LREF = 13,
OP_LSET = 14,
OP_CREF = 15,
OP_CSET = 16,
OP_JMP = 17,
OP_JMPIF = 18,
OP_NOT = 19,
OP_CALL = 20,
OP_TAILCALL = 21,
OP_RET = 22,
OP_LAMBDA = 23,
OP_CONS = 24,
OP_CAR = 25,
OP_CDR = 26,
OP_NILP = 27,
OP_SYMBOLP = 28,
OP_PAIRP = 29,
OP_ADD = 30,
OP_SUB = 31,
OP_MUL = 32,
OP_DIV = 33,
OP_EQ = 34,
OP_LT = 35,
OP_LE = 36,
OP_GT = 37,
OP_GE = 38,
OP_STOP = 39
};
struct code {
int insn;
int a;
int b;
};
#if defined(__cplusplus)
}
#endif
#endif

8
lib/weak.c
View File

@ -50,7 +50,7 @@ pic_make_weak(pic_state *pic)
pic_value pic_value
pic_weak_ref(pic_state *pic, pic_value weak, pic_value key) pic_weak_ref(pic_state *pic, pic_value weak, pic_value key)
{ {
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->fp->regs[0])->hash; khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int it; int it;
it = kh_get(weak, h, obj_ptr(pic, key)); it = kh_get(weak, h, obj_ptr(pic, key));
@ -63,7 +63,7 @@ pic_weak_ref(pic_state *pic, pic_value weak, pic_value key)
void void
pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val) pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
{ {
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->fp->regs[0])->hash; khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int ret; int ret;
int it; int it;
@ -74,7 +74,7 @@ pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
bool bool
pic_weak_has(pic_state *pic, pic_value weak, pic_value key) pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
{ {
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->fp->regs[0])->hash; khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
return kh_get(weak, h, obj_ptr(pic, key)) != kh_end(h); return kh_get(weak, h, obj_ptr(pic, key)) != kh_end(h);
} }
@ -82,7 +82,7 @@ pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
void void
pic_weak_del(pic_state *pic, pic_value weak, pic_value key) pic_weak_del(pic_state *pic, pic_value weak, pic_value key)
{ {
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->fp->regs[0])->hash; khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int it; int it;
it = kh_get(weak, h, obj_ptr(pic, key)); it = kh_get(weak, h, obj_ptr(pic, key));

5
tools/mkboot.scm
View File

@ -1,7 +1,6 @@
(import (scheme base) (import (scheme base)
(scheme read) (scheme read)
(scheme write) (scheme write))
(only (picrin base) compile expand default-environment))
(define (generate-rom) (define (generate-rom)
@ -16,7 +15,7 @@
(define text (define text
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write (compile (expand (read) default-environment)))))) (write (read)))))
(define (escape-string s) (define (escape-string s)
(with-output-to-string (with-output-to-string