Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

several gc bugfixes (fixes #52)

Browse source
This commit is contained in:
Alex Shinn 2010-12-05 16:50:57 -08:00
parent 9802b38ccb
commit 2eaf4068e5
4 changed files with 37 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
eval.c
View file

@ -148,8 +148,10 @@ static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
sexp_gc_preserve1(ctx, res); sexp_gc_preserve1(ctx, res);
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls)); sexp_push(ctx, res, sexp_car(ls));
if (!sexp_nullp(ls))
res = sexp_cons(ctx, ls, res);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); return res;
} }
static sexp sexp_flatten_dot (sexp ctx, sexp ls) { static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
@ -1423,15 +1425,14 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
int flags, sexp_proc1 f, sexp data) { int flags, sexp_proc1 f, sexp data) {
sexp res = SEXP_VOID; sexp_gc_var2(op, res);
sexp_gc_var1(op); sexp_gc_preserve2(ctx, op, res);
sexp_gc_preserve1(ctx, op);
op = sexp_make_foreign(ctx, name, num_args, flags, f, data); op = sexp_make_foreign(ctx, name, num_args, flags, f, data);
if (sexp_exceptionp(op)) if (sexp_exceptionp(op))
res = op; res = op;
else else
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); sexp_env_define(ctx, env, res = sexp_intern(ctx, name, -1), op);
sexp_gc_release1(ctx); sexp_gc_release2(ctx);
return res; return res;
} }
@ -1477,11 +1478,14 @@ sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) {
sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp e = sexp_make_env(ctx), core; sexp_gc_var2(e, core);
sexp_gc_preserve2(ctx, e, core);
e = sexp_make_env(ctx);
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
core = sexp_copy_core(ctx, &core_forms[i]); core = sexp_copy_core(ctx, &core_forms[i]);
sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core);
} }
sexp_gc_release2(ctx);
return e; return e;
} }
@ -1652,7 +1656,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1));
#endif #endif
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1));
sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp);
sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
#if SEXP_USE_SIMPLIFY #if SEXP_USE_SIMPLIFY
op = sexp_make_foreign(ctx, "simplify", 1, 0, op = sexp_make_foreign(ctx, "simplify", 1, 0,
@ -1699,7 +1703,9 @@ sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version)
} }
sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) {
sexp oldname, newname, value; sexp oldname, newname;
sexp_gc_var1(value);
sexp_gc_preserve1(ctx, value);
if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(to)) to = sexp_context_env(ctx);
if (! sexp_envp(from)) from = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx);
if (sexp_not(ls)) { if (sexp_not(ls)) {
@ -1730,6 +1736,7 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se
} }
} }
} }
sexp_gc_release1(ctx);
return SEXP_VOID; return SEXP_VOID;
} }

4
gc.c
View file

@ -48,10 +48,6 @@ static int sexp_in_heap(sexp ctx, sexp_uint_t x) {
} }
#endif #endif
#if SEXP_USE_DEBUG_GC
#include "opt/gc_debug.c"
#endif
void sexp_mark (sexp ctx, sexp x) { void sexp_mark (sexp ctx, sexp x) {
sexp_sint_t i, len; sexp_sint_t i, len;
sexp t, *p; sexp t, *p;

2
sexp.c
View file

@ -1091,7 +1091,7 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) {
sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp_gc_var1(tmp); sexp_gc_var1(tmp);
if (! sexp_oportp(p)) if (! sexp_oportp(p))
return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); return sexp_type_exception(ctx, NULL, SEXP_OPORT, p);
if (! sexp_port_openp(p)) if (! sexp_port_openp(p))
return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p);
else { else {

32
vm.c
View file

@ -149,10 +149,11 @@ static void generate_ref (sexp ctx, sexp ref, int unboxp) {
if (! sexp_lambdap(sexp_ref_loc(ref))) { if (! sexp_lambdap(sexp_ref_loc(ref))) {
/* global ref */ /* global ref */
if (unboxp) { if (unboxp) {
emit(ctx, emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
(sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
sexp_ref_cell(ref));
} else } else
emit_push(ctx, sexp_ref_cell(ref)); emit_push(ctx, sexp_ref_cell(ref));
} else { } else {
@ -211,13 +212,13 @@ static void generate_opcode_app (sexp ctx, sexp app) {
emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
#else #else
emit_push(ctx, sexp_opcode_data(op)); emit_push(ctx, sexp_opcode_data(op));
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
sexp_opcode_data(op));
#endif #endif
emit(ctx, SEXP_OP_CDR); emit(ctx, SEXP_OP_CDR);
} else { } else {
emit_push(ctx, sexp_opcode_data(op)); emit_push(ctx, sexp_opcode_data(op));
} }
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
sexp_opcode_data(op));
sexp_context_depth(ctx)++; sexp_context_depth(ctx)++;
num_args++; num_args++;
} }
@ -270,6 +271,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
case SEXP_OPC_FOREIGN: case SEXP_OPC_FOREIGN:
emit(ctx, sexp_opcode_code(op)); emit(ctx, sexp_opcode_code(op));
emit_word(ctx, (sexp_uint_t)op); emit_word(ctx, (sexp_uint_t)op);
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op);
break; break;
case SEXP_OPC_TYPE_PREDICATE: case SEXP_OPC_TYPE_PREDICATE:
case SEXP_OPC_GETTER: case SEXP_OPC_GETTER:
@ -282,6 +284,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
if (sexp_opcode_data2(op)) if (sexp_opcode_data2(op))
emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op);
} }
break; break;
case SEXP_OPC_PARAMETER: case SEXP_OPC_PARAMETER:
@ -435,8 +438,8 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) {
} }
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
sexp ls, bc, res, env; sexp ls, res, env;
sexp_gc_var5(params, ref, refs, lambda, ctx2); sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
if (i == sexp_opcode_num_args(op)) { /* return before preserving */ if (i == sexp_opcode_num_args(op)) { /* return before preserving */
if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
} else if (i < sexp_opcode_num_args(op)) { } else if (i < sexp_opcode_num_args(op)) {
@ -444,7 +447,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
} else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
return sexp_compile_error(ctx, "too many args for opcode", op); return sexp_compile_error(ctx, "too many args for opcode", op);
} }
sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
params = make_param_list(ctx, i); params = make_param_list(ctx, i);
lambda = sexp_make_lambda(ctx, params); lambda = sexp_make_lambda(ctx, params);
ctx2 = sexp_make_child_context(ctx, lambda); ctx2 = sexp_make_child_context(ctx, lambda);
@ -462,7 +465,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
if (i == sexp_opcode_num_args(op)) if (i == sexp_opcode_num_args(op))
sexp_opcode_proc(op) = res; sexp_opcode_proc(op) = res;
sexp_gc_release5(ctx); sexp_gc_release6(ctx);
return res; return res;
} }
@ -987,14 +990,14 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_REF:
_ALIGN_IP(); _ALIGN_IP();
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); sexp_raise("slot-ref: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
_ARG1 = sexp_slot_ref(_ARG1, _UWORD1); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
ip += sizeof(sexp)*2; ip += sizeof(sexp)*2;
break; break;
case SEXP_OP_SLOT_SET: case SEXP_OP_SLOT_SET:
_ALIGN_IP(); _ALIGN_IP();
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); sexp_raise("slot-set!: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
else if (sexp_immutablep(_ARG1)) else if (sexp_immutablep(_ARG1))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
sexp_slot_set(_ARG1, _UWORD1, _ARG2); sexp_slot_set(_ARG1, _UWORD1, _ARG2);
@ -1401,7 +1404,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
_ARG1 = sexp_make_character(i); _ARG1 = sexp_make_character(i);
break; break;
case SEXP_OP_YIELD: case SEXP_OP_YIELD:
#if SEXP_USE_GREEN_THREADS
fuel = 0; fuel = 0;
#endif
_PUSH(SEXP_VOID); _PUSH(SEXP_VOID);
break; break;
case SEXP_OP_RET: case SEXP_OP_RET:
@ -1457,9 +1462,11 @@ sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
sexp_sint_t top = sexp_context_top(ctx), len, offset; sexp_sint_t top = sexp_context_top(ctx), len, offset;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
len = sexp_unbox_fixnum(sexp_length(ctx, args)); len = sexp_unbox_fixnum(sexp_length(ctx, args));
if (sexp_opcodep(proc)) if (sexp_opcodep(proc))
proc = make_opcode_procedure(ctx, proc, len); proc = tmp = make_opcode_procedure(ctx, proc, len);
if (! sexp_procedurep(proc)) { if (! sexp_procedurep(proc)) {
res = sexp_exceptionp(proc) ? proc : res = sexp_exceptionp(proc) ? proc :
sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc);
@ -1475,5 +1482,6 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
res = sexp_vm(ctx, proc); res = sexp_vm(ctx, proc);
if (! res) res = SEXP_VOID; /* shouldn't happen */ if (! res) res = SEXP_VOID; /* shouldn't happen */
} }
sexp_gc_release1(ctx);
return res; return res;
} }