mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-22 07:09:18 +02:00
test suite now passes with new gc, even starting
with a tiny heap and causing multiple allocations. pointer adjusting after a moved realloc still segfaults.
This commit is contained in:
Alex Shinn
parent
b636225da7
commit
bddbaedfa7
5 changed files with 261 additions and 83 deletions
4
config.h
4
config.h
|
|
@ -2,8 +2,8 @@
|
|||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
/* uncomment this to use manual memory management */
|
||||
/* #define USE_BOEHM 0 */
|
||||
/* uncomment this to use the Boehm conservative GC */
|
||||
/* #define USE_BOEHM 1 */
|
||||
|
||||
/* uncomment this if you only want fixnum support */
|
||||
/* #define USE_FLONUMS 0 */
|
||||
|
|
|
|||
115
eval.c
115
eval.c
|
|
@ -483,7 +483,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
|
|||
}
|
||||
analyze_check_exception(value);
|
||||
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_seqp(body)) {
|
||||
|
|
@ -683,8 +683,13 @@ static sexp analyze (sexp ctx, sexp object) {
|
|||
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);
|
||||
} else {
|
||||
res = sexp_compile_error(ctx, "invalid operand in application", x);
|
||||
}
|
||||
} else if (sexp_idp(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) {
|
||||
sexp ls, op = sexp_car(app);
|
||||
sexp op = sexp_car(app);
|
||||
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)));
|
||||
sexp_context_tailp(ctx) = 0;
|
||||
|
||||
|
|
@ -900,12 +908,14 @@ static void generate_opcode_app (sexp ctx, sexp app) {
|
|||
emit(ctx, sexp_opcode_code(op));
|
||||
|
||||
sexp_context_depth(ctx) -= (num_args-1);
|
||||
sexp_gc_release(ctx, ls, s_ls);
|
||||
}
|
||||
|
||||
static void generate_general_app (sexp ctx, sexp app) {
|
||||
sexp ls;
|
||||
sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))),
|
||||
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 */
|
||||
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));
|
||||
|
||||
sexp_context_depth(ctx) -= len;
|
||||
sexp_gc_release(ctx, ls, s_ls);
|
||||
}
|
||||
|
||||
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) {
|
||||
sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv;
|
||||
sexp_uint_t k;
|
||||
sexp_gc_var(ctx, vec, s_vec);
|
||||
sexp_gc_preserve(ctx, vec, s_vec);
|
||||
sexp_gc_var(ctx, tmp, s_tmp);
|
||||
sexp_gc_preserve(ctx, tmp, s_tmp);
|
||||
prev_lambda = sexp_context_lambda(ctx);
|
||||
prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
|
||||
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);
|
||||
if (sexp_nullp(fv)) {
|
||||
/* shortcut, no free vars */
|
||||
vec = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID);
|
||||
generate_lit(ctx, sexp_make_procedure(ctx2, flags, len, bc, vec));
|
||||
tmp = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID);
|
||||
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 {
|
||||
/* push the closed vars */
|
||||
emit_push(ctx, SEXP_VOID);
|
||||
|
|
@ -990,7 +1003,7 @@ static void generate_lambda (sexp ctx, sexp lambda) {
|
|||
emit_push(ctx, flags);
|
||||
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) {
|
||||
|
|
@ -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) {
|
||||
sexp_gc_var(ctx, res, s_res);
|
||||
sexp_gc_preserve(ctx, res, s_res);
|
||||
if (sexp_nullp(fv2))
|
||||
return fv1;
|
||||
for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
|
||||
fv2 = insert_free_var(ctx, sexp_car(fv1), fv2);
|
||||
return fv2;
|
||||
for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1))
|
||||
res = insert_free_var(ctx, sexp_car(fv1), res);
|
||||
sexp_gc_release(ctx, res, s_res);
|
||||
return res;
|
||||
}
|
||||
|
||||
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))
|
||||
if ((sexp_ref_loc(sexp_car(fv)) != lambda)
|
||||
|| (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params)
|
||||
== SEXP_FALSE))
|
||||
sexp_push(ctx, res, sexp_car(fv));
|
||||
sexp_gc_release(ctx, res, s_res);
|
||||
return res;
|
||||
}
|
||||
|
||||
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)) {
|
||||
fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL);
|
||||
fv2 = diff_free_vars(ctx, x, fv1,
|
||||
sexp_append2(ctx,
|
||||
sexp_lambda_locals(x),
|
||||
sexp_flatten_dot(ctx,
|
||||
sexp_lambda_params(x))));
|
||||
fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x));
|
||||
fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2);
|
||||
fv2 = diff_free_vars(ctx, x, fv1, 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)) {
|
||||
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)) {
|
||||
fv = free_vars(ctx, sexp_cnd_test(x), fv);
|
||||
fv = free_vars(ctx, sexp_cnd_pass(x), fv);
|
||||
fv = free_vars(ctx, sexp_cnd_fail(x), fv);
|
||||
fv1 = free_vars(ctx, sexp_cnd_test(x), fv);
|
||||
fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1);
|
||||
fv1 = free_vars(ctx, sexp_cnd_fail(x), fv1);
|
||||
} else if (sexp_seqp(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)) {
|
||||
fv = free_vars(ctx, sexp_set_value(x), fv);
|
||||
fv = free_vars(ctx, sexp_set_var(x), fv);
|
||||
fv1 = free_vars(ctx, sexp_set_value(x), fv);
|
||||
fv1 = free_vars(ctx, sexp_set_var(x), fv1);
|
||||
} 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)) {
|
||||
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) {
|
||||
|
|
@ -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, ref, s_ref);
|
||||
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, ref, s_ref);
|
||||
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);
|
||||
lambda = sexp_make_lambda(ctx, params);
|
||||
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)));
|
||||
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);
|
||||
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),
|
||||
|
|
@ -1903,6 +1927,18 @@ static struct sexp_struct core_forms[] = {
|
|||
|
||||
#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) {
|
||||
sexp_uint_t i;
|
||||
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;
|
||||
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])),
|
||||
&core_forms[i]);
|
||||
sexp_copy_core(ctx, &core_forms[i]));
|
||||
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) {
|
||||
sexp_uint_t i;
|
||||
sexp cell, sym;
|
||||
|
|
@ -1930,9 +1960,10 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
sexp_gc_preserve(ctx, op, s_op);
|
||||
e = sexp_make_null_env(ctx, version);
|
||||
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)) {
|
||||
op = sexp_copy_opcode(ctx, op);
|
||||
/* op = sexp_copy_opcode(ctx, op); */
|
||||
sym = sexp_intern(ctx, (char*)sexp_opcode_default(op));
|
||||
cell = env_cell_create(ctx, e, sym, SEXP_VOID);
|
||||
sexp_opcode_default(op) = cell;
|
||||
|
|
|
|||
192
gc.c
192
gc.c
|
|
@ -5,7 +5,7 @@
|
|||
#include "sexp.h"
|
||||
|
||||
/* #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_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);
|
||||
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);
|
||||
if (! res)
|
||||
res = sexp_align(1, 4);
|
||||
/* exit(1); */
|
||||
}
|
||||
return res;
|
||||
|
|
@ -64,7 +66,7 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
|
|||
|
||||
void sexp_mark (sexp x) {
|
||||
sexp *data;
|
||||
sexp_uint_t i;
|
||||
sexp_sint_t i;
|
||||
struct sexp_gc_var_t *saves;
|
||||
loop:
|
||||
if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) {
|
||||
|
|
@ -101,6 +103,7 @@ void sexp_mark (sexp x) {
|
|||
x = sexp_symbol_string(x);
|
||||
goto loop;
|
||||
case SEXP_BYTECODE:
|
||||
sexp_mark(sexp_bytecode_name(x));
|
||||
x = sexp_bytecode_literals(x);
|
||||
goto loop;
|
||||
case SEXP_ENV:
|
||||
|
|
@ -124,7 +127,6 @@ void sexp_mark (sexp x) {
|
|||
case SEXP_OPCODE:
|
||||
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_data(x)) sexp_mark(sexp_opcode_data(x));
|
||||
break;
|
||||
case SEXP_IPORT:
|
||||
case SEXP_OPORT:
|
||||
|
|
@ -136,7 +138,6 @@ void sexp_mark (sexp x) {
|
|||
sexp_mark(sexp_lambda_locals(x));
|
||||
sexp_mark(sexp_lambda_defs(x));
|
||||
sexp_mark(sexp_lambda_flags(x));
|
||||
sexp_mark(sexp_lambda_body(x));
|
||||
sexp_mark(sexp_lambda_fv(x));
|
||||
sexp_mark(sexp_lambda_sv(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)
|
||||
|
||||
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);
|
||||
if (p < prev)
|
||||
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));
|
||||
p = sexp_cdr(p);
|
||||
}
|
||||
|
|
@ -471,18 +596,19 @@ void validate_heap (sexp ctx) {
|
|||
/* 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))
|
||||
;
|
||||
/* fprintf(stderr, "p: %p q: %p r: %p\n", p, q, r); */
|
||||
if (r == p) {
|
||||
p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
|
||||
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);
|
||||
if (sexp_pointer_tag(p) == 0) {
|
||||
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) {
|
||||
fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p));
|
||||
} else {
|
||||
sexp_verify(p);
|
||||
}
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
|
|
@ -493,11 +619,14 @@ void validate_gc_vars (sexp ctx) {
|
|||
if (! ctx)
|
||||
return;
|
||||
for (saves=sexp_context_saves(ctx); saves; saves=saves->next) {
|
||||
/* if (saves->var) { */
|
||||
/* if (((char*)*(saves->var) < sexp_heap) */
|
||||
/* || ((char*)*(saves->var) >= sexp_heap_end)) */
|
||||
/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */
|
||||
/* } */
|
||||
if (saves->var && *(saves->var) && sexp_pointerp(*(saves->var))) {
|
||||
if (((char*)*(saves->var) < sexp_heap)
|
||||
|| ((char*)*(saves->var) >= sexp_heap_end))
|
||||
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)) {
|
||||
fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves);
|
||||
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;
|
||||
for (p=start; p<stack_base; p++) {
|
||||
for (p=&x; p<stack_base; p++) {
|
||||
if (*p == x) {
|
||||
fprintf(stderr, "reference to freed var %p at %p: ", x, p);
|
||||
simple_write(x, 1, stderr);
|
||||
putc('\n', stderr);
|
||||
freep = 0;
|
||||
}
|
||||
}
|
||||
return freep;
|
||||
}
|
||||
|
||||
sexp sexp_sweep (sexp ctx) {
|
||||
|
|
@ -537,11 +669,10 @@ sexp sexp_sweep (sexp ctx) {
|
|||
fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q);
|
||||
}
|
||||
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)); */
|
||||
/* simple_write(p, 1, stderr); */
|
||||
/* fprintf(stderr, "\x1B[0m\n"); */
|
||||
validate_freed_pointer(p, &ctx);
|
||||
sum_freed += size;
|
||||
if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
|
||||
&& (q != sexp_free_list)) {
|
||||
|
|
@ -597,6 +728,7 @@ sexp sexp_sweep (sexp ctx) {
|
|||
extern sexp continuation_resumer, final_resumer;
|
||||
|
||||
sexp sexp_gc (sexp ctx) {
|
||||
sexp res;
|
||||
int i;
|
||||
fprintf(stderr, "************* garbage collecting *************\n");
|
||||
/* sexp_show_free_list(ctx); */
|
||||
|
|
@ -605,7 +737,13 @@ sexp sexp_gc (sexp ctx) {
|
|||
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
||||
sexp_mark(sexp_symbol_table[i]);
|
||||
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) {
|
||||
|
|
@ -675,7 +813,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
|
|||
sexp ls1, ls2, ls3;
|
||||
ls1 = sexp_free_list;
|
||||
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 + SEXP_MINIMUM_OBJECT_SIZE)) {
|
||||
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 */
|
||||
sexp_cdr(ls1) = sexp_cdr(ls2);
|
||||
}
|
||||
bzero((void*)ls2, size); /* maybe not needed */
|
||||
bzero((void*)ls2, size);
|
||||
return 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 *res;
|
||||
validate_heap(ctx);
|
||||
validate_free_list(ctx);
|
||||
validate_gc_vars(ctx);
|
||||
/* validate_heap(ctx); */
|
||||
/* validate_free_list(ctx); */
|
||||
/* validate_gc_vars(ctx); */
|
||||
size = sexp_align(size, 4);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
|
|
@ -719,19 +857,19 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
}
|
||||
|
||||
void sexp_gc_init () {
|
||||
sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4);
|
||||
sexp next;
|
||||
sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE);
|
||||
sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE;
|
||||
sexp_heap = malloc(size);
|
||||
sexp_heap_end = sexp_heap + size;
|
||||
sexp_free_list = (sexp)sexp_heap;
|
||||
next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4));
|
||||
sexp_pointer_tag(sexp_free_list) = SEXP_PAIR;
|
||||
sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */
|
||||
sexp_cdr(sexp_free_list) = next;
|
||||
sexp_pointer_tag(next) = SEXP_PAIR;
|
||||
sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE
|
||||
- sexp_align(sexp_sizeof(pair), 4));
|
||||
sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4));
|
||||
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);
|
||||
}
|
||||
|
||||
|
|
|
|||
22
sexp.c
22
sexp.c
|
|
@ -251,7 +251,7 @@ sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
|
|||
sexp sexp_listp (sexp ctx, sexp hare) {
|
||||
sexp turtle;
|
||||
if (! sexp_pairp(hare))
|
||||
return sexp_make_boolean(hare == SEXP_NULL);
|
||||
return sexp_make_boolean(sexp_nullp(hare));
|
||||
turtle = hare;
|
||||
hare = sexp_cdr(hare);
|
||||
for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) {
|
||||
|
|
@ -259,7 +259,7 @@ sexp sexp_listp (sexp ctx, sexp 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) {
|
||||
|
|
@ -281,9 +281,11 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) {
|
|||
}
|
||||
|
||||
sexp sexp_reverse (sexp ctx, sexp ls) {
|
||||
sexp res = SEXP_NULL;
|
||||
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
sexp_gc_var(ctx, res, s_res);
|
||||
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);
|
||||
sexp_gc_release(ctx, res, s_res);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -306,9 +308,15 @@ sexp sexp_nreverse (sexp ctx, sexp ls) {
|
|||
}
|
||||
|
||||
sexp sexp_append2 (sexp ctx, sexp a, sexp b) {
|
||||
for (a=sexp_reverse(ctx, a); sexp_pairp(a); a=sexp_cdr(a))
|
||||
b = sexp_cons(ctx, sexp_car(a), b);
|
||||
return b;
|
||||
sexp_gc_var(ctx, a1, s_a1);
|
||||
sexp_gc_var(ctx, b1, s_b1);
|
||||
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) {
|
||||
|
|
|
|||
11
sexp.h
11
sexp.h
|
|
@ -65,7 +65,6 @@ enum sexp_types {
|
|||
SEXP_IPORT,
|
||||
SEXP_OPORT,
|
||||
SEXP_EXCEPTION,
|
||||
/* the following are used only by the evaluator */
|
||||
SEXP_PROCEDURE,
|
||||
SEXP_MACRO,
|
||||
SEXP_SYNCLO,
|
||||
|
|
@ -201,10 +200,10 @@ struct sexp_struct {
|
|||
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
|
||||
+ SEXP_EXTENDED_TAG))
|
||||
|
||||
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
|
||||
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
|
||||
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
|
||||
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
|
||||
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
|
||||
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
|
||||
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) /* 46 0x2e */
|
||||
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) /* 62 0x3e */
|
||||
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
|
||||
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* 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 *****************************/
|
||||
|
||||
#define sexp_truep(x) ((x) != SEXP_FALSE)
|
||||
|
||||
#define sexp_nullp(x) ((x) == SEXP_NULL)
|
||||
#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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue