diff --git a/include/picrin.h b/include/picrin.h index fbdf6602..27c1e210 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -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; diff --git a/src/codegen.c b/src/codegen.c index 0b589820..c3be8f8e 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -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); diff --git a/src/cont.c b/src/cont.c index 578f83a6..52a31bcd 100644 --- a/src/cont.c +++ b/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 diff --git a/src/vm.c b/src/vm.c index fe5fb3e9..58360f41 100644 --- a/src/vm.c +++ b/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