Merge branch 'native-mv'. fix #16
This commit is contained in:
commit
1d7e46fbdf
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
34
src/cont.c
34
src/cont.c
|
@ -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) {
|
||||
argv[i] = ci->fp[i];
|
||||
}
|
||||
for (i = 0; i < n; ++i) {
|
||||
argv[i] = ci->fp[i];
|
||||
}
|
||||
return i;
|
||||
|
||||
return retc;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
72
src/vm.c
72
src/vm.c
|
@ -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);
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
NEXT;
|
||||
|
||||
/* invoke! */
|
||||
pic->sp[0] = proc->u.cfunc(pic);
|
||||
pic->sp += ci->retc;
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
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
|
||||
|
|
Loading…
Reference in New Issue