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
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
$(MAKE) -C docs html

212
lib/cont.c
View File

@ -6,101 +6,22 @@
#include "object.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
cont_call(pic_state *pic)
applyk(pic_state *pic, pic_value proc, pic_value cont, int argc, pic_value *argv)
{
int argc;
pic_value *argv;
struct cont *cc, *cont;
int i;
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));
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
if (cc == cont) {
break;
}
pic->cxt->pc = MKCALL(argc + 1);
pic->cxt->sp = pic_make_frame_unsafe(pic, argc + 3);
pic->cxt->sp->regs[0] = proc;
pic->cxt->sp->regs[1] = cont;
for (i = 0; i < argc; ++i) {
pic->cxt->sp->regs[i + 2] = argv[i];
}
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));
return pic_invalid_value(pic);
}
static pic_value
@ -108,34 +29,13 @@ valuesk(pic_state *pic, int argc, pic_value *argv)
{
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) {
pic->sp[i] = 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;
pic->cxt->sp->regs[i + 1] = argv[i];
}
return pic_invalid_value(pic);
}
pic_value
@ -162,30 +62,59 @@ pic_vvalues(pic_state *pic, int n, va_list ap)
return valuesk(pic, n, retv);
}
int
pic_receive(pic_state *pic, int n, pic_value *argv)
static pic_value
cont_call(pic_state *pic)
{
struct callinfo *ci;
int i, retc;
int argc;
pic_value *argv;
struct context *cxt, *c;
int i;
/* take info from discarded frame */
ci = pic->ci + 1;
retc = ci->retc;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < retc && i < n; ++i) {
argv[i] = ci->fp[i];
cxt = pic_data(pic, pic_closure_ref(pic, 0));
/* 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
pic_cont_callcc(pic_state *pic)
{
pic_value f;
pic_value f, args[1];
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
@ -199,22 +128,31 @@ pic_cont_values(pic_state *pic)
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
pic_cont_call_with_values(pic_state *pic)
{
pic_value producer, consumer, retv[256];
int retc;
pic_value producer, consumer, k;
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);
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);
return applyk(pic, producer, k, 0, NULL);
}
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")
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
native_exception_handler(pic_state *pic)
{
@ -37,28 +54,20 @@ native_exception_handler(pic_state *pic)
pic_get_args(pic, "o", &err);
pic->err = err;
pic_call(pic, pic_closure_ref(pic, 0), 1, pic_false_value(pic));
pic_call(pic, pic_closure_ref(pic, 0), 1, err);
PIC_UNREACHABLE();
}
void
pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
pic_enter_try(pic_state *pic)
{
struct cont *cont;
pic_value handler;
pic_value cont, handler;
pic_value var, env;
/* call/cc */
cont = pic_alloca_cont(pic);
pic_save_point(pic, cont, jmp);
handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont));
cont = pic_make_cont(pic, pic->cxt, pic_invalid_value(pic));
handler = pic_lambda(pic, native_exception_handler, 1, cont);
/* with-exception-handler */
var = pic_exc(pic);
env = pic_make_weak(pic);
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
pic_end_try(pic_state *pic)
pic_exit_try(pic_state *pic)
{
pic->dyn_env = pic_cdr(pic, pic->dyn_env);
pic_exit_point(pic);
pic->cxt = pic->cxt->prev;
}
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

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
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 = 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
@ -165,13 +165,13 @@ pic_protect(pic_state *pic, pic_value v)
size_t
pic_enter(pic_state *pic)
{
return pic->arena_idx;
return pic->cxt->ai;
}
void
pic_leave(pic_state *pic, size_t state)
{
pic->arena_idx = state;
pic->cxt->ai = state;
}
void *
@ -238,24 +238,24 @@ gc_mark_object(pic_state *pic, struct object *obj)
break;
}
case PIC_TYPE_PROC_FUNC: {
if (obj->u.proc.fp) {
LOOP(obj->u.proc.fp);
if (obj->u.proc.env) {
LOOP(obj->u.proc.env);
}
break;
}
case PIC_TYPE_PROC_IREP: {
if (obj->u.proc.fp) {
gc_mark_object(pic, (struct object *)obj->u.proc.fp);
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.npool; ++i) {
gc_mark_object(pic, obj->u.irep.pool[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.nirep; ++i) {
for (i = 0; i < obj->u.irep.irepc; ++i) {
gc_mark_object(pic, (struct object *)obj->u.irep.irep[i]);
}
break;
@ -319,38 +319,32 @@ gc_mark_object(pic_state *pic, struct object *obj)
static void
gc_mark_phase(pic_state *pic)
{
pic_value *stack;
struct callinfo *ci;
struct context *cxt;
size_t j;
assert(pic->heap->weaks == NULL);
/* stack */
for (stack = pic->stbase; stack != pic->sp; ++stack) {
gc_mark(pic, *stack);
}
/* callinfo */
for (ci = pic->ci; ci != pic->cibase; --ci) {
if (ci->cxt) {
gc_mark_object(pic, (struct object *)ci->cxt);
}
/* context */
for (cxt = pic->cxt; cxt != NULL; cxt = cxt->prev) {
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);
}
/* 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]);
}
/* global variables */
gc_mark(pic, pic->globals);
/* error object */
gc_mark(pic, pic->err);
/* dynamic environment */
gc_mark(pic, pic->dyn_env);
/* top continuation */
gc_mark(pic, pic->halt);
/* features */
gc_mark(pic, pic->features);
@ -422,10 +416,10 @@ gc_finalize_object(pic_state *pic, struct object *obj)
}
case PIC_TYPE_IREP: {
struct irep *irep = &obj->u.irep;
pic_free(pic, irep->code);
pic_free(pic, irep->ints);
pic_free(pic, irep->nums);
pic_free(pic, irep->pool);
if ((irep->flags & IREP_CODE_STATIC) == 0) {
pic_free(pic, irep->code);
}
pic_free(pic, irep->obj);
pic_free(pic, irep->irep);
break;
}
@ -434,7 +428,7 @@ gc_finalize_object(pic_state *pic, struct object *obj)
break;
}
case PIC_TYPE_FRAME: {
pic_free(pic, obj->u.frame.storage);
pic_free(pic, obj->u.frame.regs);
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_error(pic_state *, const char *msg, int n, ...);
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_(cont, jmp) \
do { \
extern void pic_start_try(pic_state *, PIC_JMPBUF *); \
extern void pic_end_try(pic_state *); \
extern pic_value pic_err(pic_state *); \
PIC_JMPBUF jmp; \
if (PIC_SETJMP(pic, jmp) == 0) { \
pic_start_try(pic, &jmp);
extern PIC_JMPBUF *pic_prepare_try(pic_state *); \
extern void pic_enter_try(pic_state *); \
extern void pic_exit_try(pic_state *); \
extern pic_value pic_abort_try(pic_state *); \
PIC_JMPBUF *jmp = pic_prepare_try(pic); \
if (PIC_SETJMP(pic, *jmp) == 0) { \
pic_enter_try(pic);
#define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
#define pic_catch_(e, label) \
pic_end_try(pic); \
pic_exit_try(pic); \
} else { \
e = pic_err(pic); \
e = pic_abort_try(pic); \
goto label; \
} \
} 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_values(pic_state *, int n, ...);
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)
#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 */
#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)) { \
return pic_float_value(pic, pic_float(pic, a) op pic_int(pic, b)); \
} else { \
pic_error(pic, #name ": non-number operand given", 0); \
pic_error(pic, #name ": non-number operand given", 2, a, b); \
} \
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)) { \
return pic_float(pic, a) op pic_int(pic, b); \
} else { \
pic_error(pic, #name ": non-number operand given", 0); \
pic_error(pic, #name ": non-number operand given", 2, a, b); \
} \
PIC_UNREACHABLE(); \
}

52
lib/object.h
View File

@ -78,24 +78,44 @@ struct record {
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 {
OBJECT_HEADER
int argc, localc, capturec;
bool varg;
struct code *code;
unsigned char argc;
unsigned char flags;
unsigned char frame_size;
unsigned char irepc, objc;
struct irep **irep;
int *ints;
double *nums;
struct object **pool;
size_t ncode, nirep, nints, nnums, npool;
pic_value *obj;
const code_t *code;
};
struct frame {
OBJECT_HEADER
int regc;
unsigned char regc;
pic_value *regs;
struct frame *up;
pic_value *storage;
};
struct proc {
@ -104,7 +124,7 @@ struct proc {
pic_func_t func;
struct irep *irep;
} u;
struct frame *fp;
struct frame *env;
};
enum {
@ -243,20 +263,20 @@ DEFPTR(irep, struct irep)
#undef pic_port_p
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 *);
pic_value pic_make_proc_irep(pic_state *, struct irep *, struct frame *);
struct frame *pic_make_frame_unsafe(pic_state *, int n);
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_record_type(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 *);
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 */

689
lib/proc.c
View File

@ -5,7 +5,22 @@
#include "picrin.h"
#include "object.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_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_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;
for (i = 0; i < n; ++i) {
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];
}
}
assert(n >= 0);
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_FUNC);
proc->u.func = func;
proc->fp = fp;
proc->u.func = f;
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);
}
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;
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->fp = fp;
proc->env = fp;
return obj_value(pic, proc);
}
@ -71,13 +81,15 @@ arg_error(pic_state *pic, int actual, bool varg, int expected)
{
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);
}
#define GET_PROC(pic) (pic->ci->fp[0])
#define GET_ARG(pic,n) (pic->ci->fp[(n)+1])
#define GET_ARGC(pic) (pic->cxt->pc[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.
@ -112,7 +124,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
const char *p = format;
int paramc = 0, optc = 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;
/* parse format */
@ -301,25 +313,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
pic_value
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);
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));
}
return proc->fp->regs[n];
return fp->regs[n];
}
void
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);
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));
}
proc->fp->regs[n] = v;
fp->regs[n] = v;
}
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);
}
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_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
{
struct code c;
size_t ai = pic_enter(pic);
struct code boot[2];
int i;
struct context cxt;
size_t arena_base = pic->cxt->ai;
#define PUSH(v) ((*pic->sp = (v)), pic->sp++)
#define POP() (*--pic->sp)
#define MKCALL(argc) (cxt.tmpcode[0] = OP_CALL, cxt.tmpcode[1] = (argc), cxt.tmpcode)
#define PUSHCI() (++pic->ci)
#define POPCI() (pic->ci--)
cxt.pc = MKCALL(argc + 1);
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);
for (i = 0; i < argc; ++i) {
PUSH(argv[i]);
if (PIC_SETJMP(pic, cxt.jmp) != 0) {
/* pass */
}
/* boot! */
boot[0].insn = OP_CALL;
boot[0].a = argc + 1;
boot[1].insn = OP_STOP;
pic->ip = boot;
#define SAVE (cxt.ai = arena_base)
#define A (cxt.pc[1])
#define B (cxt.pc[2])
#define C (cxt.pc[3])
#define Bx ((C << 8) + B)
#define REG(i) (cxt.sp->regs[i])
#if PIC_DIRECT_THREADED_VM
# define VM_LOOP JUMP;
# define CASE(x) L_##x:
# define NEXT pic->ip++; JUMP;
# define JUMP c = *pic->ip; goto *oplabels[c.insn];
# define NEXT(n) (cxt.pc += n); JUMP;
# define JUMP goto *oplabels[*cxt.pc];
# define VM_LOOP_END
#else
# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) {
# define VM_LOOP for (;;) { switch (*cxt.pc) {
# define CASE(x) case x:
# define NEXT pic->ip++; break
# define NEXT(n) (cxt.pc += n); break
# define JUMP break
# define VM_LOOP_END } }
#endif
#if PIC_DIRECT_THREADED_VM
static const void *oplabels[] = {
&&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHUNDEF, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE,
&&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHFLOAT,
&&L_OP_PUSHCHAR, &&L_OP_PUSHEOF, &&L_OP_PUSHCONST,
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET,
&&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
[OP_HALT] = &&L_OP_HALT, [OP_CALL] = &&L_OP_CALL, [OP_PROC] = &&L_OP_PROC,
[OP_LOAD] = &&L_OP_LOAD, [OP_LREF] = &&L_OP_LREF, [OP_LSET] = &&L_OP_LSET,
[OP_GREF] = &&L_OP_GREF, [OP_GSET] = &&L_OP_GSET, [OP_COND] = &&L_OP_COND,
[OP_LOADT] = &&L_OP_LOADT, [OP_LOADF] = &&L_OP_LOADF, [OP_LOADN] = &&L_OP_LOADN,
[OP_LOADU] = &&L_OP_LOADU, [OP_LOADI] = &&L_OP_LOADI
};
#endif
VM_LOOP {
CASE(OP_NOP) {
NEXT;
}
CASE(OP_POP) {
(void)(POP());
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_HALT) {
pic_value ret = cxt.fp->regs[1];
pic->cxt = pic->cxt->prev;
pic_protect(pic, ret);
return ret;
}
CASE(OP_CALL) {
pic_value x, v;
struct callinfo *ci;
struct proc *proc;
if (c.a == -1) {
pic->sp += pic->ci[1].retc - 1;
c.a = pic->ci[1].retc + 1;
if (! pic_proc_p(pic, REG(0))) {
pic_error(pic, "invalid application", 1, 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;
proc = proc_ptr(pic, REG(0));
if (proc->tt == PIC_TYPE_PROC_FUNC) {
/* invoke! */
pic_value v;
cxt.sp->up = proc->env; /* push static link */
cxt.fp = cxt.sp;
cxt.sp = NULL;
cxt.irep = NULL;
v = proc->u.func(pic);
pic->sp[0] = v;
pic->sp += pic->ci->retc;
pic_leave(pic, ai);
goto L_RET;
}
else {
if (cxt.sp != NULL) { /* tail call */
SAVE;
JUMP;
} else {
cxt.sp = pic_make_frame_unsafe(pic, 3);
cxt.sp->regs[0] = cxt.fp->regs[1]; /* cont. */
cxt.sp->regs[1] = v;
cxt.pc = MKCALL(1);
SAVE;
JUMP;
}
} else {
struct irep *irep = proc->u.irep;
int i;
pic_value rest;
ci->irep = irep;
if (ci->argc != irep->argc) {
if (! (irep->varg && ci->argc >= irep->argc)) {
arg_error(pic, ci->argc - 1, irep->varg, irep->argc - 1);
}
}
/* prepare rest args */
if (irep->varg) {
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));
}
}
if (A != irep->argc) {
if (! ((irep->flags & IREP_VARG) != 0 && A >= irep->argc)) {
arg_error(pic, A, (irep->flags & IREP_VARG), irep->argc);
}
}
if (irep->flags & IREP_VARG) {
REG(irep->argc + 1) = pic_make_list(pic, A - irep->argc, &REG(irep->argc + 1));
SAVE; /* TODO: get rid of this */
}
/* prepare cxt */
ci->up = proc->fp;
ci->regc = irep->capturec;
ci->regs = ci->fp + irep->argc + irep->localc;
pic->ip = irep->code;
pic_leave(pic, ai);
JUMP;
cxt.sp->up = proc->env; /* push static link */
cxt.fp = cxt.sp;
cxt.sp = pic_make_frame_unsafe(pic, irep->frame_size);
cxt.pc = irep->code;
cxt.irep = irep;
JUMP;
}
}
CASE(OP_TAILCALL) {
int i, argc;
pic_value *argv;
struct callinfo *ci;
if (pic->ci->cxt != NULL) {
vm_tear_off(pic->ci);
CASE(OP_LREF) {
struct frame *f;
int depth = B;
for (f = cxt.fp; depth--; f = f->up);
REG(A) = f->regs[C];
NEXT(4);
}
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) {
int i, retc;
pic_value *retv;
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_PROC) {
REG(A) = pic_make_proc_irep_unsafe(pic, cxt.irep->irep[B], cxt.fp);
NEXT(3);
}
CASE(OP_LAMBDA) {
if (pic->ci->cxt == NULL) {
vm_push_cxt(pic);
}
PUSH(pic_make_proc_irep(pic, pic->ci->irep->irep[c.a], pic->ci->cxt));
pic_leave(pic, ai);
NEXT;
CASE(OP_LOAD) {
REG(A) = cxt.irep->obj[B];
NEXT(3);
}
CASE(OP_CONS) {
pic_value a, b;
pic_protect(pic, b = POP());
pic_protect(pic, a = POP());
PUSH(pic_cons(pic, a, b));
pic_leave(pic, ai);
NEXT;
CASE(OP_LOADU) {
REG(A) = pic_undef_value(pic);
NEXT(2);
}
CASE(OP_CAR) {
pic_value p;
p = POP();
PUSH(pic_car(pic, p));
NEXT;
CASE(OP_LOADT) {
REG(A) = pic_true_value(pic);
NEXT(2);
}
CASE(OP_CDR) {
pic_value p;
p = POP();
PUSH(pic_cdr(pic, p));
NEXT;
CASE(OP_LOADF) {
REG(A) = pic_false_value(pic);
NEXT(2);
}
CASE(OP_NILP) {
pic_value p;
p = POP();
PUSH(pic_bool_value(pic, pic_nil_p(pic, p)));
NEXT;
CASE(OP_LOADN) {
REG(A) = pic_nil_value(pic);
NEXT(2);
}
CASE(OP_SYMBOLP) {
pic_value p;
p = POP();
PUSH(pic_bool_value(pic, pic_sym_p(pic, p)));
NEXT;
CASE(OP_LOADI) {
REG(A) = pic_int_value(pic, (signed char) B);
NEXT(3);
}
CASE(OP_PAIRP) {
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;
} VM_LOOP_END
}
pic_value
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 } };
pic_value *sp;
struct callinfo *ci;
int i;
const code_t *pc;
struct frame *sp;
*pic->sp++ = proc;
#define MKCALLK(argc) \
(pic->cxt->tmpcode[0] = OP_CALL, pic->cxt->tmpcode[1] = (argc), pic->cxt->tmpcode)
sp = pic->sp;
for (i = 0; i < argc; ++i) {
*sp++ = args[i];
}
ci = PUSHCI();
ci->ip = iseq;
ci->fp = pic->sp;
ci->retc = (int)argc;
if (ci->retc == 0) {
return pic_undef_value(pic);
} else {
return args[0];
pc = MKCALLK(argc + 1);
sp = pic_make_frame_unsafe(pic, argc + 3);
sp->regs[0] = proc;
sp->regs[1] = GET_CONT(pic);
if (argc != 0) {
int i;
for (i = 0; i < argc; ++i) {
sp->regs[i + 2] = args[i];
}
}
pic->cxt->pc = pc;
pic->cxt->sp = sp;
return pic_invalid_value(pic);
}
static pic_value

87
lib/state.c
View File

@ -168,29 +168,18 @@ pic_open(pic_allocf allocf, void *userdata)
/* user data */
pic->userdata = userdata;
/* continuation chain */
pic->cc = NULL;
/* prepare VM stack */
pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value));
pic->stend = pic->stbase + PIC_STACK_SIZE;
if (! pic->sp) {
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;
}
/* context */
pic->default_cxt.ai = 0;
pic->default_cxt.pc = NULL;
pic->default_cxt.fp = NULL;
pic->default_cxt.sp = NULL;
pic->default_cxt.irep = NULL;
pic->default_cxt.prev = NULL;
pic->cxt = &pic->default_cxt;
/* arena */
pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *));
pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
if (! pic->arena) {
goto EXIT_ARENA;
@ -214,12 +203,29 @@ pic_open(pic_allocf allocf, void *userdata)
/* dynamic environment */
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 */
pic->panicf = NULL;
/* error object */
pic->err = pic_invalid_value(pic);
/* turn on GC */
pic->gc_enable = true;
@ -230,10 +236,6 @@ pic_open(pic_allocf allocf, void *userdata)
return pic;
EXIT_ARENA:
allocf(userdata, pic->ci, 0);
EXIT_CI:
allocf(userdata, pic->sp, 0);
EXIT_SP:
allocf(userdata, pic, 0);
EXIT_PIC:
return NULL;
@ -245,24 +247,25 @@ pic_close(pic_state *pic)
pic_allocf allocf = pic->allocf;
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->arena_idx = 0;
pic->err = pic_invalid_value(pic);
pic->cxt = &pic->default_cxt;
pic->cxt->ai = 0;
pic->halt = pic_invalid_value(pic);
pic->globals = pic_invalid_value(pic);
pic->features = 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 */
pic_gc(pic);
/* free heaps */
pic_heap_close(pic, pic->heap);
/* free runtime context */
allocf(pic->userdata, pic->stbase, 0);
allocf(pic->userdata, pic->cibase, 0);
/* free global stacks */
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);
}
val = pic_dict_ref(pic, pic->globals, sym);
if (pic_invalid_p(pic, val)) {
pic_error(pic, "uninitialized global variable", 1, sym);
}
/* FIXME */
/* if (pic_invalid_p(pic, val)) { */
/* pic_error(pic, "uninitialized global variable", 1, sym); */
/* } */
return val;
}
void
pic_global_set(pic_state *pic, pic_value sym, pic_value value)
{
if (! pic_dict_has(pic, pic->globals, sym)) {
pic_error(pic, "undefined variable", 1, sym);
}
/* FIXME */
/* if (! pic_dict_has(pic, pic->globals, sym)) { */
/* pic_error(pic, "undefined variable", 1, sym); */
/* } */
pic_dict_set(pic, pic->globals, sym, value);
}
@ -321,7 +326,7 @@ pic_define(pic_state *pic, const char *name, pic_value val)
void
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

42
lib/state.h
View File

@ -10,34 +10,30 @@ extern "C" {
#endif
#include "khash.h"
#include "vm.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;
};
#include "object.h"
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 {
pic_allocf allocf;
void *userdata;
struct cont *cc;
pic_value *sp;
pic_value *stbase, *stend;
struct callinfo *ci;
struct callinfo *cibase, *ciend;
const struct code *ip;
struct context *cxt, default_cxt;
pic_value dyn_env;
@ -48,9 +44,9 @@ struct pic_state {
bool gc_enable;
struct heap *heap;
struct object **arena;
size_t arena_size, arena_idx;
size_t arena_size;
pic_value err;
pic_value halt; /* top continuation */
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_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;
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
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 it;
@ -74,7 +74,7 @@ pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
bool
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);
}
@ -82,7 +82,7 @@ pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
void
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;
it = kh_get(weak, h, obj_ptr(pic, key));

5
tools/mkboot.scm
View File

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