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

Merge branch 'native-mv'. fix #16

This commit is contained in:
Yuichi Nishiwaki 2014-02-20 18:42:13 +09:00
parent 16639a1764 7c5d337119
commit 1d7e46fbdf
4 changed files with 136 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
include/picrin.h
View File

@ -60,7 +60,7 @@ extern "C" {
struct pic_code;
typedef struct {
int argc;
int argc, retc;
struct pic_code *ip;
pic_value *fp;
struct pic_env *env;

91
src/codegen.c
View File

@ -88,7 +88,9 @@ typedef struct analyze_state {
pic_sym rCONS, rCAR, rCDR, rNILP;
pic_sym rADD, rSUB, rMUL, rDIV;
pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT;
pic_sym sCALL, sTAILCALL, sREF, sRETURN;
pic_sym rVALUES, rCALL_WITH_VALUES;
pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
pic_sym sREF, sRETURN;
} analyze_state;
static void push_scope(analyze_state *, pic_value);
@ -134,9 +136,13 @@ new_analyze_state(pic_state *pic)
register_renamed_symbol(pic, state, rGT, stdlib, ">");
register_renamed_symbol(pic, state, rGE, stdlib, ">=");
register_renamed_symbol(pic, state, rNOT, stdlib, "not");
register_renamed_symbol(pic, state, rVALUES, stdlib, "values");
register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "call-with-values");
register_symbol(pic, state, sCALL, "call");
register_symbol(pic, state, sTAILCALL, "tail-call");
register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
register_symbol(pic, state, sREF, "ref");
register_symbol(pic, state, sRETURN, "return");
@ -264,7 +270,7 @@ analyze(analyze_state *state, pic_value obj, bool tailpos)
tag = pic_sym(pic_car(pic, res));
if (tailpos) {
if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sRETURN) {
if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) {
/* pass through */
}
else {
@ -540,6 +546,30 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
ARGC_ASSERT(1);
return CONSTRUCT_OP1(pic->sNOT);
}
else if (sym == state->rVALUES && tailpos) {
pic_value v, seq;
seq = pic_list(pic, 1, pic_symbol_value(state->sRETURN));
pic_for_each (v, pic_cdr(pic, obj)) {
seq = pic_cons(pic, analyze(state, v, false), seq);
}
return pic_reverse(pic, seq);
}
else if (sym == state->rCALL_WITH_VALUES) {
pic_value prod, cnsm;
pic_sym call;
ARGC_ASSERT(2);
if (! tailpos) {
call = state->sCALL_WITH_VALUES;
} else {
call = state->sTAILCALL_WITH_VALUES;
}
prod = analyze(state, pic_list_ref(pic, obj, 1), false);
cnsm = analyze(state, pic_list_ref(pic, obj, 2), false);
return pic_list(pic, 3, pic_symbol_value(call), prod, cnsm);
}
}
return analyze_call(state, obj, tailpos);
}
@ -939,6 +969,7 @@ typedef struct codegen_state {
codegen_context *cxt;
pic_sym sGREF, sCREF, sLREF;
pic_sym sCALL, sTAILCALL, sRETURN;
pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
unsigned *cv_tbl, cv_num;
} codegen_state;
@ -960,6 +991,8 @@ new_codegen_state(pic_state *pic)
register_symbol(pic, state, sLREF, "lref");
register_symbol(pic, state, sCREF, "cref");
register_symbol(pic, state, sRETURN, "return");
register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
push_codegen_context(state, pic_nil_value(), pic_nil_value(), false, pic_nil_value());
@ -1311,9 +1344,29 @@ codegen(codegen_state *state, pic_value obj)
cxt->clen++;
return;
}
else if (sym == state->sRETURN) {
else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) {
/* stack consumer at first */
codegen(state, pic_list_ref(pic, obj, 2));
codegen(state, pic_list_ref(pic, obj, 1));
/* call producer */
cxt->code[cxt->clen].insn = OP_CALL;
cxt->code[cxt->clen].u.i = 1;
cxt->clen++;
/* call consumer */
cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL;
cxt->code[cxt->clen].u.i = -1;
cxt->clen++;
return;
}
else if (sym == state->sRETURN) {
int len = pic_length(pic, obj);
pic_value elt;
pic_for_each (elt, pic_cdr(pic, obj)) {
codegen(state, elt);
}
cxt->code[cxt->clen].insn = OP_RET;
cxt->code[cxt->clen].u.i = len - 1;
cxt->clen++;
return;
}
@ -1361,51 +1414,51 @@ compile(pic_state *pic, pic_value obj)
int ai = pic_gc_arena_preserve(pic);
#if DEBUG
fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stderr, "# input expression\n");
fprintf(stdout, "# input expression\n");
pic_debug(pic, obj);
fprintf(stderr, "\n");
fprintf(stdout, "\n");
fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
#endif
/* macroexpand */
obj = pic_macroexpand(pic, obj);
#if DEBUG
fprintf(stderr, "## macroexpand completed\n");
fprintf(stdout, "## macroexpand completed\n");
pic_debug(pic, obj);
fprintf(stderr, "\n");
fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "\n");
fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
#endif
/* analyze */
obj = pic_analyze(pic, obj);
#if DEBUG
fprintf(stderr, "## analyzer completed\n");
fprintf(stdout, "## analyzer completed\n");
pic_debug(pic, obj);
fprintf(stderr, "\n");
fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "\n");
fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
#endif
/* resolution */
obj = pic_resolve(pic, obj);
#if DEBUG
fprintf(stderr, "## resolver completed\n");
fprintf(stdout, "## resolver completed\n");
pic_debug(pic, obj);
fprintf(stderr, "\n");
fprintf(stderr, "ai = %d\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "\n");
fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
#endif
/* codegen */
irep = pic_codegen(pic, obj);
#if DEBUG
fprintf(stderr, "## codegen completed\n");
fprintf(stdout, "## codegen completed\n");
pic_dump_irep(pic, irep);
#endif
#if DEBUG
fprintf(stderr, "# compilation finished\n");
fprintf(stdout, "# compilation finished\n");
puts("");
#endif
@ -1581,7 +1634,7 @@ print_code(pic_state *pic, struct pic_code c)
printf("OP_TAILCALL\t%d\n", c.u.i);
break;
case OP_RET:
puts("OP_RET");
printf("OP_RET\t%d\n", c.u.i);
break;
case OP_LAMBDA:
printf("OP_LAMBDA\t%d\n", c.u.i);

32
src/cont.c
View File

@ -181,13 +181,13 @@ pic_values(pic_state *pic, size_t c, ...)
va_start(ap, c);
for (i = 0; i < c; ++i) {
pic->ci->fp[i] = va_arg(ap, pic_value);
pic->sp[i] = va_arg(ap, pic_value);
}
pic->ci->fp[i] = pic_undef_value();
pic->ci->retc = c;
va_end(ap);
return c == 0 ? pic_none_value() : pic->ci->fp[0];
return c == 0 ? pic_none_value() : pic->sp[0];
}
pic_value
@ -196,11 +196,11 @@ pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
size_t i;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
pic->sp[i] = argv[i];
}
pic->ci->fp[i] = pic_undef_value();
pic->ci->retc = argc;
return argc == 0 ? pic_none_value() : pic->ci->fp[0];
return argc == 0 ? pic_none_value() : pic->sp[0];
}
pic_value
@ -211,30 +211,28 @@ pic_values_by_list(pic_state *pic, pic_value list)
i = 0;
pic_for_each (v, list) {
pic->ci->fp[i++] = v;
pic->sp[i++] = v;
}
pic->ci->fp[i] = pic_undef_value();
pic->ci->retc = i;
return pic_nil_p(list) ? pic_none_value() : pic->ci->fp[0];
return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
}
size_t
pic_receive(pic_state *pic, size_t n, pic_value *argv)
{
pic_callinfo *ci;
size_t i;
size_t i, retc;
/* take info from already discarded frame */
/* take info from discarded frame */
ci = pic->ci + 1;
retc = ci->retc;
for (i = 0; ; ++i) {
if (pic_undef_p(ci->fp[i]))
break;
if (i < n) {
for (i = 0; i < n; ++i) {
argv[i] = ci->fp[i];
}
}
return i;
return retc;
}
static pic_value

70
src/vm.c
View File

@ -411,6 +411,8 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
#if VM_DEBUG
puts("### booting VM... ###");
pic_value *stbase = pic->sp;
pic_callinfo *cibase = pic->ci;
#endif
PUSH(pic_obj_value(proc));
@ -532,13 +534,15 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_callinfo *ci;
struct pic_proc *proc;
if (c.u.i == -1) {
pic->sp += pic->ci[1].retc - 1;
c.u.i = pic->ci[1].retc + 1;
}
L_CALL:
x = pic->sp[-c.u.i];
if (! pic_proc_p(x)) {
#if DEBUG
pic_debug(pic, x);
#endif
pic_error(pic, "invalid application");
pic_errorf(pic, "invalid application: ~S", x);
}
proc = pic_proc_ptr(x);
@ -566,17 +570,18 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
ci = PUSHCI();
ci->argc = c.u.i;
ci->retc = 1;
ci->ip = pic->ip;
ci->fp = pic->sp - c.u.i;
ci->env = NULL;
if (pic_proc_cfunc_p(x)) {
v = proc->u.cfunc(pic);
ci = POPCI();
pic->ip = ci->ip;
pic->sp = ci->fp;
PUSH(v);
/* invoke! */
pic->sp[0] = proc->u.cfunc(pic);
pic->sp += ci->retc;
pic_gc_arena_restore(pic, ai);
NEXT;
goto L_RET;
}
else {
int i;
@ -624,20 +629,28 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
CASE(OP_TAILCALL) {
int i, argc;
pic_value *argv;
pic_callinfo *ci;
if (c.u.i == -1) {
pic->sp += pic->ci[1].retc - 1;
c.u.i = pic->ci[1].retc + 1;
}
argc = c.u.i;
argv = pic->sp - argc;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
}
pic->sp = pic->ci->fp + argc;
pic->ip = POPCI()->ip;
ci = POPCI();
pic->sp = ci->fp + argc;
pic->ip = ci->ip;
/* c is not changed */
goto L_CALL;
}
CASE(OP_RET) {
pic_value v;
int i, retc;
pic_value *retv;
pic_callinfo *ci;
if (pic->err) {
@ -645,13 +658,22 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
L_RAISE:
goto L_STOP;
}
else {
v = POP();
ci = POPCI();
pic->ip = ci->ip;
pic->sp = ci->fp;
PUSH(v);
pic->ci->retc = c.u.i;
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) {
@ -789,17 +811,17 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
#if VM_DEBUG
puts("**VM END STATE**");
printf("stbase\t= %p\nsp\t= %p\n", (void *)pic->stbase, (void *)pic->sp);
printf("cibase\t= %p\nci\t= %p\n", (void *)pic->cibase, (void *)pic->ci);
if (pic->stbase < pic->sp) {
printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp);
printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci);
if (stbase < pic->sp) {
pic_value *sp;
printf("* stack trace:");
for (sp = pic->stbase; pic->sp != sp; ++sp) {
for (sp = stbase; pic->sp != sp; ++sp) {
pic_debug(pic, *sp);
puts("");
}
}
if (pic->stbase > pic->sp) {
if (stbase > pic->sp) {
puts("*** stack underflow!");
}
#endif