From 57b2bc281d4f71bd7e481faaed4425788c6b203d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 18 Jul 2012 21:34:53 +0900 Subject: [PATCH] apply opcode is now tail-recursive - calling it in a non-tail position is an error --- eval.c | 2 +- include/chibi/eval.h | 1 + include/chibi/sexp.h | 1 + lib/init-7.scm | 2 +- opcodes.c | 2 +- vm.c | 37 ++++++++++++++++++++++++++----------- 6 files changed, 31 insertions(+), 14 deletions(-) diff --git a/eval.c b/eval.c index a8f2118a..1bf2d333 100644 --- a/eval.c +++ b/eval.c @@ -33,7 +33,7 @@ sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { return exn; } -static void sexp_warn (sexp ctx, char *msg, sexp x) { +void sexp_warn (sexp ctx, char *msg, sexp x) { sexp out = sexp_current_error_port(ctx); if (sexp_oportp(out)) { sexp_write_string(ctx, "WARNING: ", out); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 4147f5bc..03236f03 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -54,6 +54,7 @@ SEXP_API const char** sexp_opcode_names; /**************************** prototypes ******************************/ +SEXP_API void sexp_warn (sexp ctx, char *msg, sexp x); SEXP_API void sexp_scheme_init (void); SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size); SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 5a19ff41..b20981cc 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -972,6 +972,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) #define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) #define sexp_opcode_static_param_p(x) (sexp_opcode_flags(x) & 8) +#define sexp_opcode_tail_call_p(x) (sexp_opcode_flags(x) & 16) #define sexp_lambda_name(x) (sexp_field(x, lambda, SEXP_LAMBDA, name)) #define sexp_lambda_params(x) (sexp_field(x, lambda, SEXP_LAMBDA, params)) diff --git a/lib/init-7.scm b/lib/init-7.scm index 415f1775..9166ff96 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -57,7 +57,7 @@ (if (every pair? lol) (mapn proc (map1 cdr lol '()) - (cons (apply1 proc (map1 car lol '())) res)) + (cons (apply proc (map1 car lol '())) res)) (reverse res))) (if (null? lol) (map1 proc ls '()) diff --git a/opcodes.c b/opcodes.c index d6b6e848..3fa39ee1 100644 --- a/opcodes.c +++ b/opcodes.c @@ -128,7 +128,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "output-port?", 0, sexp_port_outputp_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "binary-port?", 0, sexp_port_binaryp_op), _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "port-open?", 0, sexp_port_openp_op), -_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 16, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), #if SEXP_USE_NATIVE_X86 diff --git a/vm.c b/vm.c index 019905c7..b5fa7a5d 100644 --- a/vm.c +++ b/vm.c @@ -290,6 +290,12 @@ static void generate_opcode_app (sexp ctx, sexp app) { sexp_gc_var1(ls); sexp_gc_preserve1(ctx, ls); + if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) { + sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app); + generate_lit(ctx, SEXP_VOID); + return; + } + num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); sexp_context_tailp(ctx) = 0; @@ -951,9 +957,14 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { self = sexp_global(ctx, SEXP_G_FINAL_RESUMER); bc = sexp_procedure_code(self); cp = sexp_procedure_vars(self); - ip = sexp_bytecode_data(bc); + ip = sexp_bytecode_data(bc) - sizeof(sexp); tmp1 = proc, tmp2 = args; - goto apply1; + i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); + sexp_ensure_stack(i + 64 + sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0); + for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) + _ARG1 = sexp_car(tmp2); + top += i+1; + goto make_call; loop: #if SEXP_USE_GREEN_THREADS @@ -1066,23 +1077,27 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { case SEXP_OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; - top -= 2; apply1: - i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); + i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); /* number of params */ sexp_ensure_stack(i + 64 + sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0); - top += i; - for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) - _ARG1 = sexp_car(tmp2); - top += i+1; - ip -= sizeof(sexp); + k = sexp_unbox_fixnum(stack[fp+3]); /* previous fp */ + j = sexp_unbox_fixnum(stack[fp]); /* previous num params */ + self = stack[fp+2]; + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); + ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp); + for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) + stack[top] = sexp_car(tmp2); + top = fp+i-j+1; + fp = k; goto make_call; case SEXP_OP_TAIL_CALL: _ALIGN_IP(); i = sexp_unbox_fixnum(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ - tmp2 = stack[fp+3]; - j = sexp_unbox_fixnum(stack[fp]); + tmp2 = stack[fp+3]; /* previous fp */ + j = sexp_unbox_fixnum(stack[fp]); /* previous num params */ self = stack[fp+2]; bc = sexp_procedure_code(self); cp = sexp_procedure_vars(self);