Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-06-20 12:56:50 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

apply opcode is now tail-recursive - calling it in a non-tail position is an error

Browse source
This commit is contained in:
Alex Shinn 2012-07-18 21:34:53 +09:00
parent 016560e5fe
commit 57b2bc281d
6 changed files with 31 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
eval.c
View file

@ -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);

1
include/chibi/eval.h
View file

@ -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);

1
include/chibi/sexp.h
View file

@ -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))

2
lib/init-7.scm
View file

@ -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 '())

2
opcodes.c
View file

@ -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

37
vm.c
View file

@ -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);