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

test suite now passes with new gc, even starting

Browse source 
with a tiny heap and causing multiple allocations.
pointer adjusting after a moved realloc still segfaults.
This commit is contained in:
Alex Shinn 2009-06-13 21:16:49 +09:00
parent b636225da7
commit bddbaedfa7
5 changed files with 261 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
config.h
View file

@ -2,8 +2,8 @@
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
/* uncomment this to use manual memory management */ /* uncomment this to use the Boehm conservative GC */
/* #define USE_BOEHM 0 */ /* #define USE_BOEHM 1 */
/* uncomment this if you only want fixnum support */ /* uncomment this if you only want fixnum support */
/* #define USE_FLONUMS 0 */ /* #define USE_FLONUMS 0 */

115
eval.c
View file

@ -483,7 +483,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
} }
analyze_check_exception(value); analyze_check_exception(value);
sexp_push(ctx2, defs, sexp_push(ctx2, defs,
sexp_make_set(ctx2, analyze_var_ref(ctx, name), value)); sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value));
} }
if (sexp_pairp(defs)) { if (sexp_pairp(defs)) {
if (! sexp_seqp(body)) { if (! sexp_seqp(body)) {
@ -683,8 +683,13 @@ static sexp analyze (sexp ctx, sexp object) {
res = analyze_app(ctx, x); res = analyze_app(ctx, x);
} }
} }
} else { } else if (sexp_truep(sexp_listp(ctx, sexp_car(x)))
|| (sexp_synclop(sexp_car(x))
&& sexp_truep(sexp_listp(ctx,
sexp_synclo_expr(sexp_car(x)))))) {
res = analyze_app(ctx, x); res = analyze_app(ctx, x);
} else {
res = sexp_compile_error(ctx, "invalid operand in application", x);
} }
} else if (sexp_idp(x)) { } else if (sexp_idp(x)) {
res = analyze_var_ref(ctx, x); res = analyze_var_ref(ctx, x);
@ -824,8 +829,11 @@ static void generate_set (sexp ctx, sexp set) {
} }
static void generate_opcode_app (sexp ctx, sexp app) { static void generate_opcode_app (sexp ctx, sexp app) {
sexp ls, op = sexp_car(app); sexp op = sexp_car(app);
sexp_sint_t i, num_args; sexp_sint_t i, num_args;
sexp_gc_var(ctx, ls, s_ls);
sexp_gc_preserve(ctx, ls, s_ls);
num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app)));
sexp_context_tailp(ctx) = 0; sexp_context_tailp(ctx) = 0;
@ -900,12 +908,14 @@ static void generate_opcode_app (sexp ctx, sexp app) {
emit(ctx, sexp_opcode_code(op)); emit(ctx, sexp_opcode_code(op));
sexp_context_depth(ctx) -= (num_args-1); sexp_context_depth(ctx) -= (num_args-1);
sexp_gc_release(ctx, ls, s_ls);
} }
static void generate_general_app (sexp ctx, sexp app) { static void generate_general_app (sexp ctx, sexp app) {
sexp ls;
sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))),
tailp = sexp_context_tailp(ctx); tailp = sexp_context_tailp(ctx);
sexp_gc_var(ctx, ls, s_ls);
sexp_gc_preserve(ctx, ls, s_ls);
/* push the arguments onto the stack */ /* push the arguments onto the stack */
sexp_context_tailp(ctx) = 0; sexp_context_tailp(ctx) = 0;
@ -921,6 +931,7 @@ static void generate_general_app (sexp ctx, sexp app) {
emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); emit_word(ctx, (sexp_uint_t)sexp_make_integer(len));
sexp_context_depth(ctx) -= len; sexp_context_depth(ctx) -= len;
sexp_gc_release(ctx, ls, s_ls);
} }
static void generate_app (sexp ctx, sexp app) { static void generate_app (sexp ctx, sexp app) {
@ -933,8 +944,8 @@ static void generate_app (sexp ctx, sexp app) {
static void generate_lambda (sexp ctx, sexp lambda) { static void generate_lambda (sexp ctx, sexp lambda) {
sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv; sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv;
sexp_uint_t k; sexp_uint_t k;
sexp_gc_var(ctx, vec, s_vec); sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, vec, s_vec); sexp_gc_preserve(ctx, tmp, s_tmp);
prev_lambda = sexp_context_lambda(ctx); prev_lambda = sexp_context_lambda(ctx);
prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
fv = sexp_lambda_fv(lambda); fv = sexp_lambda_fv(lambda);
@ -965,8 +976,10 @@ static void generate_lambda (sexp ctx, sexp lambda) {
sexp_bytecode_name(bc) = sexp_lambda_name(lambda); sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
if (sexp_nullp(fv)) { if (sexp_nullp(fv)) {
/* shortcut, no free vars */ /* shortcut, no free vars */
vec = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); tmp = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID);
generate_lit(ctx, sexp_make_procedure(ctx2, flags, len, bc, vec)); tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp);
generate_lit(ctx, tmp);
} else { } else {
/* push the closed vars */ /* push the closed vars */
emit_push(ctx, SEXP_VOID); emit_push(ctx, SEXP_VOID);
@ -990,7 +1003,7 @@ static void generate_lambda (sexp ctx, sexp lambda) {
emit_push(ctx, flags); emit_push(ctx, flags);
emit(ctx, OP_MAKE_PROCEDURE); emit(ctx, OP_MAKE_PROCEDURE);
} }
sexp_gc_release(ctx, vec, s_vec); sexp_gc_release(ctx, tmp, s_tmp);
} }
static void generate (sexp ctx, sexp x) { static void generate (sexp ctx, sexp x) {
@ -1020,53 +1033,62 @@ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) {
} }
static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) {
sexp_gc_var(ctx, res, s_res);
sexp_gc_preserve(ctx, res, s_res);
if (sexp_nullp(fv2)) if (sexp_nullp(fv2))
return fv1; return fv1;
for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
fv2 = insert_free_var(ctx, sexp_car(fv1), fv2); res = insert_free_var(ctx, sexp_car(fv1), res);
return fv2; sexp_gc_release(ctx, res, s_res);
return res;
} }
static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) {
sexp res = SEXP_NULL; sexp_gc_var(ctx, res, s_res);
sexp_gc_preserve(ctx, res, s_res);
res = SEXP_NULL;
for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
if ((sexp_ref_loc(sexp_car(fv)) != lambda) if ((sexp_ref_loc(sexp_car(fv)) != lambda)
|| (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
== SEXP_FALSE)) == SEXP_FALSE))
sexp_push(ctx, res, sexp_car(fv)); sexp_push(ctx, res, sexp_car(fv));
sexp_gc_release(ctx, res, s_res);
return res; return res;
} }
static sexp free_vars (sexp ctx, sexp x, sexp fv) { static sexp free_vars (sexp ctx, sexp x, sexp fv) {
sexp fv1, fv2; sexp_gc_var(ctx, fv1, s_fv1);
sexp_gc_var(ctx, fv2, s_fv2);
sexp_gc_preserve(ctx, fv1, s_fv1);
sexp_gc_preserve(ctx, fv2, s_fv2);
fv1 = fv;
if (sexp_lambdap(x)) { if (sexp_lambdap(x)) {
fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
fv2 = diff_free_vars(ctx, x, fv1, fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x));
sexp_append2(ctx, fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2);
sexp_lambda_locals(x), fv2 = diff_free_vars(ctx, x, fv1, fv2);
sexp_flatten_dot(ctx,
sexp_lambda_params(x))));
sexp_lambda_fv(x) = fv2; sexp_lambda_fv(x) = fv2;
fv = union_free_vars(ctx, fv2, fv); fv1 = union_free_vars(ctx, fv2, fv);
} else if (sexp_pairp(x)) { } else if (sexp_pairp(x)) {
for ( ; sexp_pairp(x); x=sexp_cdr(x)) for ( ; sexp_pairp(x); x=sexp_cdr(x))
fv = free_vars(ctx, sexp_car(x), fv); fv1 = free_vars(ctx, sexp_car(x), fv1);
} else if (sexp_cndp(x)) { } else if (sexp_cndp(x)) {
fv = free_vars(ctx, sexp_cnd_test(x), fv); fv1 = free_vars(ctx, sexp_cnd_test(x), fv);
fv = free_vars(ctx, sexp_cnd_pass(x), fv); fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1);
fv = free_vars(ctx, sexp_cnd_fail(x), fv); fv1 = free_vars(ctx, sexp_cnd_fail(x), fv1);
} else if (sexp_seqp(x)) { } else if (sexp_seqp(x)) {
for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x))
fv = free_vars(ctx, sexp_car(x), fv); fv1 = free_vars(ctx, sexp_car(x), fv1);
} else if (sexp_setp(x)) { } else if (sexp_setp(x)) {
fv = free_vars(ctx, sexp_set_value(x), fv); fv1 = free_vars(ctx, sexp_set_value(x), fv);
fv = free_vars(ctx, sexp_set_var(x), fv); fv1 = free_vars(ctx, sexp_set_var(x), fv1);
} else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) {
fv = insert_free_var(ctx, x, fv); fv1 = insert_free_var(ctx, x, fv);
} else if (sexp_synclop(x)) { } else if (sexp_synclop(x)) {
fv = free_vars(ctx, sexp_synclo_expr(x), fv); fv1 = free_vars(ctx, sexp_synclo_expr(x), fv);
} }
return fv; sexp_gc_release(ctx, fv1, s_fv1);
return fv1;
} }
static sexp make_param_list(sexp ctx, sexp_uint_t i) { static sexp make_param_list(sexp ctx, sexp_uint_t i) {
@ -1084,11 +1106,11 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
sexp_gc_var(ctx, params, s_params); sexp_gc_var(ctx, params, s_params);
sexp_gc_var(ctx, ref, s_ref); sexp_gc_var(ctx, ref, s_ref);
sexp_gc_var(ctx, refs, s_refs); sexp_gc_var(ctx, refs, s_refs);
if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
return sexp_opcode_proc(op);
sexp_gc_preserve(ctx, params, s_params); sexp_gc_preserve(ctx, params, s_params);
sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, ref, s_ref);
sexp_gc_preserve(ctx, refs, s_refs); sexp_gc_preserve(ctx, refs, s_refs);
if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
return sexp_opcode_proc(op);
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);
@ -1098,7 +1120,9 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls))); ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls)));
sexp_push(ctx2, refs, ref); sexp_push(ctx2, refs, ref);
} }
generate_opcode_app(ctx2, sexp_cons(ctx2, op, sexp_reverse(ctx2, refs))); refs = sexp_reverse(ctx2, refs);
refs = sexp_cons(ctx2, op, refs);
generate_opcode_app(ctx2, refs);
bc = finalize_bytecode(ctx2); bc = finalize_bytecode(ctx2);
sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1);
res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i), res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i),
@ -1903,6 +1927,18 @@ static struct sexp_struct core_forms[] = {
#include "opcodes.c" #include "opcodes.c"
static sexp sexp_copy_core (sexp ctx, sexp core) {
sexp res = sexp_alloc_type(ctx, core, SEXP_CORE);
memcpy(res, core, sexp_sizeof(core));
return res;
}
static sexp sexp_copy_opcode (sexp ctx, sexp op) {
sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
memcpy(res, op, sexp_sizeof(opcode));
return res;
}
static sexp sexp_make_null_env (sexp ctx, sexp version) { static sexp sexp_make_null_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
@ -1911,16 +1947,10 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) {
sexp_env_bindings(e) = SEXP_NULL; sexp_env_bindings(e) = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++)
env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])),
&core_forms[i]); sexp_copy_core(ctx, &core_forms[i]));
return e; return e;
} }
static sexp sexp_copy_opcode (sexp ctx, sexp op) {
sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
memcpy(res, op, sexp_sizeof(opcode));
return res;
}
static sexp sexp_make_standard_env (sexp ctx, sexp version) { static sexp sexp_make_standard_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp cell, sym; sexp cell, sym;
@ -1930,9 +1960,10 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
sexp_gc_preserve(ctx, op, s_op); sexp_gc_preserve(ctx, op, s_op);
e = sexp_make_null_env(ctx, version); e = sexp_make_null_env(ctx, version);
for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
op = &opcodes[i]; /* op = &opcodes[i]; */
op = sexp_copy_opcode(ctx, &opcodes[i]);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) {
op = sexp_copy_opcode(ctx, op); /* op = sexp_copy_opcode(ctx, op); */
sym = sexp_intern(ctx, (char*)sexp_opcode_default(op)); sym = sexp_intern(ctx, (char*)sexp_opcode_default(op));
cell = env_cell_create(ctx, e, sym, SEXP_VOID); cell = env_cell_create(ctx, e, sym, SEXP_VOID);
sexp_opcode_default(op) = cell; sexp_opcode_default(op) = cell;

192
gc.c
View file

@ -5,7 +5,7 @@
#include "sexp.h" #include "sexp.h"
/* #define SEXP_INITIAL_HEAP_SIZE (3*1024*1024) */ /* #define SEXP_INITIAL_HEAP_SIZE (3*1024*1024) */
#define SEXP_INITIAL_HEAP_SIZE 40000 #define SEXP_INITIAL_HEAP_SIZE 37000
#define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MAXIMUM_HEAP_SIZE 0
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
@ -57,6 +57,8 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
if (res != sexp_allocated_bytes0(x)) { if (res != sexp_allocated_bytes0(x)) {
fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res); fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res);
if (! res)
res = sexp_align(1, 4);
/* exit(1); */ /* exit(1); */
} }
return res; return res;
@ -64,7 +66,7 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
void sexp_mark (sexp x) { void sexp_mark (sexp x) {
sexp *data; sexp *data;
sexp_uint_t i; sexp_sint_t i;
struct sexp_gc_var_t *saves; struct sexp_gc_var_t *saves;
loop: loop:
if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) {
@ -101,6 +103,7 @@ void sexp_mark (sexp x) {
x = sexp_symbol_string(x); x = sexp_symbol_string(x);
goto loop; goto loop;
case SEXP_BYTECODE: case SEXP_BYTECODE:
sexp_mark(sexp_bytecode_name(x));
x = sexp_bytecode_literals(x); x = sexp_bytecode_literals(x);
goto loop; goto loop;
case SEXP_ENV: case SEXP_ENV:
@ -124,7 +127,6 @@ void sexp_mark (sexp x) {
case SEXP_OPCODE: case SEXP_OPCODE:
if (sexp_opcode_proc(x)) sexp_mark(sexp_opcode_proc(x)); if (sexp_opcode_proc(x)) sexp_mark(sexp_opcode_proc(x));
if (sexp_opcode_default(x)) sexp_mark(sexp_opcode_default(x)); if (sexp_opcode_default(x)) sexp_mark(sexp_opcode_default(x));
if (sexp_opcode_data(x)) sexp_mark(sexp_opcode_data(x));
break; break;
case SEXP_IPORT: case SEXP_IPORT:
case SEXP_OPORT: case SEXP_OPORT:
@ -136,7 +138,6 @@ void sexp_mark (sexp x) {
sexp_mark(sexp_lambda_locals(x)); sexp_mark(sexp_lambda_locals(x));
sexp_mark(sexp_lambda_defs(x)); sexp_mark(sexp_lambda_defs(x));
sexp_mark(sexp_lambda_flags(x)); sexp_mark(sexp_lambda_flags(x));
sexp_mark(sexp_lambda_body(x));
sexp_mark(sexp_lambda_fv(x)); sexp_mark(sexp_lambda_fv(x));
sexp_mark(sexp_lambda_sv(x)); sexp_mark(sexp_lambda_sv(x));
x = sexp_lambda_body(x); x = sexp_lambda_body(x);
@ -173,6 +174,128 @@ void sexp_mark (sexp x) {
} }
} }
#define sexp_valid_objectp(x) ((! x) || sexp_pointerp(x) || sexp_nullp(x) || sexp_isymbolp(x) || sexp_integerp(x) || (x == SEXP_NULL) || (x == SEXP_FALSE) || (x == SEXP_TRUE) || (x == SEXP_EOF) || (x == SEXP_VOID) || (x == SEXP_UNDEF) || (x == SEXP_CLOSE) || (x == SEXP_RAWDOT) || (sexp_charp(x) && (sexp_unbox_character(x) <= 256)) || (x == SEXP_TRUE) || (x == SEXP_FALSE))
#define sexp_verify_one(x, p, t) \
do { \
if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { \
if (x && sexp_pointerp(x)) { \
fprintf(stderr, "outside heap: %p (%x) from: %p %s\n", x, sexp_pointer_tag(x), p, t); \
return; \
} \
} else if (! sexp_valid_objectp(x)) { \
fprintf(stderr, "bad object: %p from: %p %s\n", x, p, t); \
} \
} while (0)
void sexp_verify (sexp x) {
sexp *data;
sexp_sint_t i;
struct sexp_gc_var_t *saves;
sexp_verify_one(x, x, "x");
if ((! x) || (! sexp_pointerp(x)))
return;
switch (sexp_pointer_tag(x)) {
case SEXP_PAIR:
sexp_verify_one(sexp_car(x), x, "car");
sexp_verify_one(sexp_cdr(x), x, "car");
break;
case SEXP_STACK:
data = sexp_stack_data(x);
if (! sexp_stack_top(x)) break;
for (i=sexp_stack_top(x)-1; i>=0; i--)
sexp_verify_one(data[i], x, "stack");
break;
case SEXP_VECTOR:
data = sexp_vector_data(x);
if (! sexp_vector_length(x)) break;
for (i=sexp_vector_length(x)-1; i>=0; i--)
sexp_verify_one(data[i], x, "vector");
break;
case SEXP_SYMBOL:
sexp_verify_one(sexp_symbol_string(x), x, "symbol_string");
break;
case SEXP_BYTECODE:
sexp_verify_one(sexp_bytecode_literals(x), x, "bytecode_literals");
break;
case SEXP_ENV:
sexp_verify_one(sexp_env_lambda(x), x, "env_lambda");
sexp_verify_one(sexp_env_bindings(x), x, "env_bindings");
sexp_verify_one(sexp_env_parent(x), x, "env_parent");
break;
case SEXP_PROCEDURE:
sexp_verify_one(sexp_procedure_code(x), x, "procedure_code");
sexp_verify_one(sexp_procedure_vars(x), x, "procedure_vars");
break;
case SEXP_MACRO:
sexp_verify_one(sexp_macro_proc(x), x, "macro_proc");
sexp_verify_one(sexp_macro_env(x), x, "macro_env");
break;
case SEXP_SYNCLO:
sexp_verify_one(sexp_synclo_free_vars(x), x, "synclo_free_vars");
sexp_verify_one(sexp_synclo_expr(x), x, "synclo_expr");
sexp_verify_one(sexp_synclo_env(x), x, "synclo_env");
break;
case SEXP_OPCODE:
if (sexp_opcode_proc(x))
sexp_verify_one(sexp_opcode_proc(x), x, "opcode_proc");
if (sexp_opcode_default(x))
sexp_verify_one(sexp_opcode_default(x), x, "opcode_default");
break;
case SEXP_IPORT:
case SEXP_OPORT:
sexp_verify_one(sexp_port_cookie(x), x, "port_cookie");
break;
case SEXP_LAMBDA:
sexp_verify_one(sexp_lambda_name(x), x, "lambda_name");
sexp_verify_one(sexp_lambda_params(x), x, "lambda_params");
sexp_verify_one(sexp_lambda_locals(x), x, "lambda_locals");
sexp_verify_one(sexp_lambda_defs(x), x, "lambda_defs");
sexp_verify_one(sexp_lambda_flags(x), x, "lambda_flags");
sexp_verify_one(sexp_lambda_body(x), x, "lambda_body");
sexp_verify_one(sexp_lambda_fv(x), x, "lambda_fv");
sexp_verify_one(sexp_lambda_sv(x), x, "lambda_sv");
sexp_verify_one(sexp_lambda_body(x), x, "lambda_body");
break;
case SEXP_CND:
sexp_verify_one(sexp_cnd_test(x), x, "cnd_test");
sexp_verify_one(sexp_cnd_fail(x), x, "cnd_fail");
sexp_verify_one(sexp_cnd_pass(x), x, "cnd_pass");
break;
case SEXP_SET:
sexp_verify_one(sexp_set_var(x), x, "set_var");
sexp_verify_one(sexp_set_value(x), x, "set_value");
break;
case SEXP_REF:
sexp_verify_one(sexp_ref_name(x), x, "ref_name");
sexp_verify_one(sexp_ref_cell(x), x, "ref_cell");
break;
case SEXP_SEQ:
sexp_verify_one(sexp_seq_ls(x), x, "seq_ls");
break;
case SEXP_LIT:
sexp_verify_one(sexp_lit_value(x), x, "lit_value");
break;
case SEXP_CONTEXT:
sexp_verify_one(sexp_context_env(x), x, "context_env");
sexp_verify_one(sexp_context_bc(x), x, "context_bc");
sexp_verify_one(sexp_context_fv(x), x, "context_fv");
sexp_verify_one(sexp_context_lambda(x), x, "context_lambda");
sexp_verify_one(sexp_context_parent(x), x, "context_parent");
for (saves=sexp_context_saves(x); saves; saves=saves->next)
if (saves->var) sexp_verify_one(*(saves->var), x, "context_saves");
sexp_verify_one(sexp_context_stack(x), x, "context_stack");
break;
case SEXP_STRING:
case SEXP_FLONUM:
case SEXP_CORE:
break;
default:
fprintf(stderr, "verify: unknown type: %d\n", sexp_pointer_tag(x));
}
}
#define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset) #define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset)
void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) { void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) {
@ -457,6 +580,8 @@ void validate_free_list (sexp ctx) {
fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev); fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev);
if (p < prev) if (p < prev)
fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p)); fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p));
if ((sexp_uint_t)p != sexp_align((sexp_uint_t)p, 4))
fprintf(stderr, " \x1B[31mfree-list misaligned: %p prev: %p\x1B[0m", p, prev);
prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p));
p = sexp_cdr(p); p = sexp_cdr(p);
} }
@ -471,18 +596,19 @@ void validate_heap (sexp ctx) {
/* find the preceding and succeeding free list pointers */ /* find the preceding and succeeding free list pointers */
for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r)) for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r))
; ;
/* fprintf(stderr, "p: %p q: %p r: %p\n", p, q, r); */
if (r == p) { if (r == p) {
p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p)); p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
continue; continue;
} }
/* if (((sexp_uint_t)p >= 0x29e00) && ((sexp_uint_t)p <= 0x2a000)) */
/* fprintf(stderr, "validate heap: %p (%p .. %p)\n", p, q, r); */
size = sexp_align(sexp_allocated_bytes(p), 4); size = sexp_align(sexp_allocated_bytes(p), 4);
if (sexp_pointer_tag(p) == 0) { if (sexp_pointer_tag(p) == 0) {
fprintf(stderr, "bare object found at %p\n", p); fprintf(stderr, "bare object found at %p\n", p);
} else if (sexp_pointer_tag(p) == 0) {
fprintf(stderr, "type object found at %p\n", p);
} else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) {
fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p));
} else {
sexp_verify(p);
} }
p = (sexp) (((char*)p)+size); p = (sexp) (((char*)p)+size);
} }
@ -493,11 +619,14 @@ void validate_gc_vars (sexp ctx) {
if (! ctx) if (! ctx)
return; return;
for (saves=sexp_context_saves(ctx); saves; saves=saves->next) { for (saves=sexp_context_saves(ctx); saves; saves=saves->next) {
/* if (saves->var) { */ if (saves->var && *(saves->var) && sexp_pointerp(*(saves->var))) {
/* if (((char*)*(saves->var) < sexp_heap) */ if (((char*)*(saves->var) < sexp_heap)
/* || ((char*)*(saves->var) >= sexp_heap_end)) */ || ((char*)*(saves->var) >= sexp_heap_end))
/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */ fprintf(stderr, "bad variable in gc var: %s => %p\n", saves->name, *(saves->var));
/* } */ if ((sexp_uint_t)*(saves->var)
!= sexp_align((sexp_uint_t)*(saves->var), 4))
fprintf(stderr, "misaligned gc var: %p\n", *(saves->var));
}
if (prev && (prev > saves)) { if (prev && (prev > saves)) {
fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves); fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves);
return; return;
@ -509,15 +638,18 @@ void validate_gc_vars (sexp ctx) {
} }
} }
void validate_freed_pointer (sexp x, sexp *start) { int validate_freed_pointer (sexp x) {
int freep = 1;
sexp *p; sexp *p;
for (p=start; p<stack_base; p++) { for (p=&x; p<stack_base; p++) {
if (*p == x) { if (*p == x) {
fprintf(stderr, "reference to freed var %p at %p: ", x, p); fprintf(stderr, "reference to freed var %p at %p: ", x, p);
simple_write(x, 1, stderr); simple_write(x, 1, stderr);
putc('\n', stderr); putc('\n', stderr);
freep = 0;
} }
} }
return freep;
} }
sexp sexp_sweep (sexp ctx) { sexp sexp_sweep (sexp ctx) {
@ -537,11 +669,10 @@ sexp sexp_sweep (sexp ctx) {
fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q); fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q);
} }
size = sexp_align(sexp_allocated_bytes(p), 4); size = sexp_align(sexp_allocated_bytes(p), 4);
if (! sexp_gc_mark(p)) { if ((! sexp_gc_mark(p)) && validate_freed_pointer(p)) {
/* fprintf(stderr, "\x1B[31mfreeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ /* fprintf(stderr, "\x1B[31mfreeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */
/* simple_write(p, 1, stderr); */ /* simple_write(p, 1, stderr); */
/* fprintf(stderr, "\x1B[0m\n"); */ /* fprintf(stderr, "\x1B[0m\n"); */
validate_freed_pointer(p, &ctx);
sum_freed += size; sum_freed += size;
if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p) if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
&& (q != sexp_free_list)) { && (q != sexp_free_list)) {
@ -597,6 +728,7 @@ sexp sexp_sweep (sexp ctx) {
extern sexp continuation_resumer, final_resumer; extern sexp continuation_resumer, final_resumer;
sexp sexp_gc (sexp ctx) { sexp sexp_gc (sexp ctx) {
sexp res;
int i; int i;
fprintf(stderr, "************* garbage collecting *************\n"); fprintf(stderr, "************* garbage collecting *************\n");
/* sexp_show_free_list(ctx); */ /* sexp_show_free_list(ctx); */
@ -605,7 +737,13 @@ sexp sexp_gc (sexp ctx) {
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++) for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
sexp_mark(sexp_symbol_table[i]); sexp_mark(sexp_symbol_table[i]);
sexp_mark(ctx); sexp_mark(ctx);
return sexp_sweep(ctx); res = sexp_sweep(ctx);
fprintf(stderr, "************* post gc validation *************\n");
validate_heap(ctx);
validate_free_list(ctx);
validate_gc_vars(ctx);
fprintf(stderr, "************* done post gc validation *************\n");
return res;
} }
void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) { void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) {
@ -675,7 +813,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
sexp ls1, ls2, ls3; sexp ls1, ls2, ls3;
ls1 = sexp_free_list; ls1 = sexp_free_list;
ls2 = sexp_cdr(ls1); ls2 = sexp_cdr(ls1);
for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ) { while (sexp_pairp(ls2)) {
if ((sexp_uint_t)sexp_car(ls2) >= size) { if ((sexp_uint_t)sexp_car(ls2) >= size) {
if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */
@ -686,7 +824,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
} else { /* take the whole chunk */ } else { /* take the whole chunk */
sexp_cdr(ls1) = sexp_cdr(ls2); sexp_cdr(ls1) = sexp_cdr(ls2);
} }
bzero((void*)ls2, size); /* maybe not needed */ bzero((void*)ls2, size);
return ls2; return ls2;
} }
ls1 = ls2; ls1 = ls2;
@ -697,9 +835,9 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
void* sexp_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) {
void *res; void *res;
validate_heap(ctx); /* validate_heap(ctx); */
validate_free_list(ctx); /* validate_free_list(ctx); */
validate_gc_vars(ctx); /* validate_gc_vars(ctx); */
size = sexp_align(size, 4); size = sexp_align(size, 4);
res = sexp_try_alloc(ctx, size); res = sexp_try_alloc(ctx, size);
if (! res) { if (! res) {
@ -719,19 +857,19 @@ void* sexp_alloc (sexp ctx, size_t size) {
} }
void sexp_gc_init () { void sexp_gc_init () {
sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4);
sexp next; sexp next;
sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); sexp_heap = malloc(size);
sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; sexp_heap_end = sexp_heap + size;
sexp_free_list = (sexp)sexp_heap; sexp_free_list = (sexp)sexp_heap;
next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4)); next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4));
sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; sexp_pointer_tag(sexp_free_list) = SEXP_PAIR;
sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */
sexp_cdr(sexp_free_list) = next; sexp_cdr(sexp_free_list) = next;
sexp_pointer_tag(next) = SEXP_PAIR; sexp_pointer_tag(next) = SEXP_PAIR;
sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4));
- sexp_align(sexp_sizeof(pair), 4));
sexp_cdr(next) = SEXP_NULL; sexp_cdr(next) = SEXP_NULL;
stack_base = &next; stack_base = &next + 32;
fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next);
} }

22
sexp.c
View file

@ -251,7 +251,7 @@ sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
sexp sexp_listp (sexp ctx, sexp hare) { sexp sexp_listp (sexp ctx, sexp hare) {
sexp turtle; sexp turtle;
if (! sexp_pairp(hare)) if (! sexp_pairp(hare))
return sexp_make_boolean(hare == SEXP_NULL); return sexp_make_boolean(sexp_nullp(hare));
turtle = hare; turtle = hare;
hare = sexp_cdr(hare); hare = sexp_cdr(hare);
for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) {
@ -259,7 +259,7 @@ sexp sexp_listp (sexp ctx, sexp hare) {
hare = sexp_cdr(hare); hare = sexp_cdr(hare);
if (sexp_pairp(hare)) hare = sexp_cdr(hare); if (sexp_pairp(hare)) hare = sexp_cdr(hare);
} }
return sexp_make_boolean(hare == SEXP_NULL); return sexp_make_boolean(sexp_nullp(hare));
} }
sexp sexp_memq (sexp ctx, sexp x, sexp ls) { sexp sexp_memq (sexp ctx, sexp x, sexp ls) {
@ -281,9 +281,11 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) {
} }
sexp sexp_reverse (sexp ctx, sexp ls) { sexp sexp_reverse (sexp ctx, sexp ls) {
sexp res = SEXP_NULL; sexp_gc_var(ctx, res, s_res);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_gc_preserve(ctx, res, s_res);
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(ctx, sexp_car(ls), res); res = sexp_cons(ctx, sexp_car(ls), res);
sexp_gc_release(ctx, res, s_res);
return res; return res;
} }
@ -306,9 +308,15 @@ sexp sexp_nreverse (sexp ctx, sexp ls) {
} }
sexp sexp_append2 (sexp ctx, sexp a, sexp b) { sexp sexp_append2 (sexp ctx, sexp a, sexp b) {
for (a=sexp_reverse(ctx, a); sexp_pairp(a); a=sexp_cdr(a)) sexp_gc_var(ctx, a1, s_a1);
b = sexp_cons(ctx, sexp_car(a), b); sexp_gc_var(ctx, b1, s_b1);
return b; sexp_gc_preserve(ctx, a1, s_a1);
sexp_gc_preserve(ctx, b1, s_b1);
b1 = b;
for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1))
b1 = sexp_cons(ctx, sexp_car(a1), b1);
sexp_gc_release(ctx, a1, s_a1);
return b1;
} }
sexp sexp_length (sexp ctx, sexp ls) { sexp sexp_length (sexp ctx, sexp ls) {

11
sexp.h
View file

@ -65,7 +65,6 @@ enum sexp_types {
SEXP_IPORT, SEXP_IPORT,
SEXP_OPORT, SEXP_OPORT,
SEXP_EXCEPTION, SEXP_EXCEPTION,
/* the following are used only by the evaluator */
SEXP_PROCEDURE, SEXP_PROCEDURE,
SEXP_MACRO, SEXP_MACRO,
SEXP_SYNCLO, SEXP_SYNCLO,
@ -201,10 +200,10 @@ struct sexp_struct {
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \ #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+ SEXP_EXTENDED_TAG)) + SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0) #define SEXP_NULL SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) #define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) #define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) /* 46 0x2e */
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) #define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) /* 62 0x3e */
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */ #define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */ #define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
@ -280,6 +279,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
/***************************** predicates *****************************/ /***************************** predicates *****************************/
#define sexp_truep(x) ((x) != SEXP_FALSE)
#define sexp_nullp(x) ((x) == SEXP_NULL) #define sexp_nullp(x) ((x) == SEXP_NULL)
#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) #define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
#define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) #define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG)