From d65e7255f86e6de05f2af2014b50565d51d134e1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 8 Jun 2009 02:06:24 +0900 Subject: [PATCH] stack is now a data type (maybe merge w/ vector), new gc seems initially functional --- Makefile | 4 +- eval.c | 221 ++++++++++++++++++++-------------------- gc.c | 299 +++++++++++++++++++++++++++++++++++++++++++++++++------ sexp.c | 26 +++-- sexp.h | 47 +++++---- 5 files changed, 432 insertions(+), 165 deletions(-) diff --git a/Makefile b/Makefile index fe8e381a..6dc9b848 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm # -Oz for smaller size on darwin -CFLAGS=-Wall -g -Os -save-temps +CFLAGS=-Wall -g -save-temps #GC_OBJ=./gc/gc.a GC_OBJ= @@ -20,7 +20,7 @@ GC_OBJ= ./gc/gc.a: ./gc/alloc.c cd gc && make -sexp.o: sexp.c sexp.h config.h defaults.h Makefile +sexp.o: sexp.c gc.c sexp.h config.h defaults.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile diff --git a/eval.c b/eval.c index 0a18859d..ba4aa3d8 100644 --- a/eval.c +++ b/eval.c @@ -8,7 +8,7 @@ static int scheme_initialized_p = 0; -static sexp continuation_resumer, final_resumer; +sexp continuation_resumer, final_resumer; static sexp the_interaction_env_symbol; static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; @@ -89,7 +89,6 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { sexp_push(ctx, sexp_env_bindings(e), tmp); } sexp_gc_release(ctx, e, s_e); - sexp_gc_release(ctx, tmp, s_tmp); return e; } @@ -247,12 +246,16 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { return res; } -static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { +static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); - sexp_context_stack(res) - = (stack ? stack : (sexp*) sexp_alloc(res, sizeof(sexp)*INIT_STACK_SIZE)); + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; sexp_context_env(res) = (env ? env : sexp_make_standard_env(res, sexp_make_integer(5))); sexp_context_bc(res) @@ -313,7 +316,6 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { res = x; } sexp_gc_release(ctx, kar, s_kar); - sexp_gc_release(ctx, kdr, s_kdr); return res; } @@ -434,7 +436,6 @@ static sexp analyze_set (sexp ctx, sexp x) { else res = sexp_make_set(ctx, ref, value); sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, value, s_value); return res; } @@ -497,10 +498,6 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } sexp_lambda_body(res) = body; sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, body, s_body); - sexp_gc_release(ctx, tmp, s_tmp); - sexp_gc_release(ctx, value, s_value); - sexp_gc_release(ctx, defs, s_defs); return res; } @@ -518,8 +515,6 @@ static sexp analyze_if (sexp ctx, sexp x) { analyze_bind(fail, fail_expr, ctx); res = sexp_make_cnd(ctx, test, pass, fail); sexp_gc_release(ctx, test, s_test); - sexp_gc_release(ctx, pass, s_pass); - sexp_gc_release(ctx, fail, s_fail); return res; } @@ -556,8 +551,6 @@ static sexp analyze_define (sexp ctx, sexp x) { else res = sexp_make_set(ctx, ref, value); sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, value, s_value); - sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -578,8 +571,6 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } } sexp_gc_release(eval_ctx, proc, s_proc); - sexp_gc_release(eval_ctx, mac, s_mac); - sexp_gc_release(eval_ctx, tmp, s_tmp); return SEXP_VOID; } @@ -610,8 +601,6 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { analyze_check_exception(tmp); res = analyze_seq(ctx2, sexp_cddr(x)); sexp_gc_release(ctx, env, s_env); - sexp_gc_release(ctx, ctx2, s_ctx2); - sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -711,8 +700,6 @@ static sexp analyze (sexp ctx, sexp object) { res = x; } sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, tmp, s_tmp); - sexp_gc_release(ctx, x, s_x); return res; } @@ -1119,8 +1106,6 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; sexp_gc_release(ctx, params, s_params); - sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, refs, s_refs); return res; } @@ -1155,24 +1140,36 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] -#define sexp_raise(msg, args) do {stack[top]=sexp_user_exception(context, self, msg, args); \ - top++; \ - goto call_error_handler;} \ - while (0) +#define sexp_raise(msg, args) \ + do {sexp_context_top(ctx) = top+1; \ + stack[top] = args; \ + stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \ + top++; \ + goto call_error_handler;} \ + while (0) #define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \ goto call_error_handler;} \ while (0) -sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { - sexp bc = sexp_procedure_code(self), cp = sexp_procedure_vars(self); - unsigned char *ip=sexp_bytecode_data(bc); - sexp tmp1, tmp2, env=sexp_context_env(context); - sexp_sint_t i, j, k, fp=top-4; +sexp vm (sexp proc, sexp ctx) { + sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); + sexp env = sexp_context_env(ctx), + *stack = sexp_stack_data(sexp_context_stack(ctx)); + unsigned char *ip = sexp_bytecode_data(bc); + sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx)); + fp = top - 4; + sexp_gc_var(ctx, self, s_self); + sexp_gc_var(ctx, tmp1, s_tmp1); + sexp_gc_var(ctx, tmp2, s_tmp2); + sexp_gc_preserve(ctx, self, s_self); + sexp_gc_preserve(ctx, tmp1, s_tmp1); + sexp_gc_preserve(ctx, tmp2, s_tmp2); + self = proc; loop: #ifdef DEBUG_VM - if (sexp_context_tracep(context)) { + if (sexp_context_tracep(ctx)) { sexp_print_stack(stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); @@ -1213,8 +1210,9 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { stack[top+3] = sexp_make_integer(fp); tmp1 = _ARG1; i = 1; - tmp2 = sexp_vector(context, 1, sexp_save_stack(context, stack, top+4)); - _ARG1 = sexp_make_procedure(context, sexp_make_integer(0), + sexp_context_top(ctx) = top; + tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4)); + _ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, tmp2); top++; @@ -1223,7 +1221,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; - i = sexp_unbox_integer(sexp_length(context, tmp2)); + i = sexp_unbox_integer(sexp_length(ctx, tmp2)); top += (i-2); for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) _ARG1 = sexp_car(tmp2); @@ -1256,29 +1254,31 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { make_call: if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - sexp_context_top(context) = top; - tmp1 = make_opcode_procedure(context, tmp1, i); + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; } } if (! sexp_procedurep(tmp1)) - sexp_raise("non procedure application", sexp_list1(context, tmp1)); + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); if (j < 0) - sexp_raise("not enough args", sexp_list2(context, tmp1, sexp_make_integer(i))); + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_integer(i))); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { - stack[top-i-1] = sexp_cons(context, stack[top-i-1], SEXP_NULL); + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); for (k=top-i; kinexact: not a number", sexp_list1(context, _ARG1)); + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_FLO2FIX: #if USE_FLONUMS @@ -1629,7 +1632,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { else #endif if (! sexp_integerp(_ARG1)) - sexp_raise("inexact->exact: not a number", sexp_list1(context, _ARG1)); + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); @@ -1675,7 +1678,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { _ARG1 = SEXP_VOID; break; case OP_READ: - _ARG1 = sexp_read(context, _ARG1); + _ARG1 = sexp_read(ctx, _ARG1); sexp_check_exception(); break; case OP_READ_CHAR: @@ -1700,11 +1703,12 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_DONE: goto end_loop; default: - sexp_raise("unknown opcode", sexp_list1(context, sexp_make_integer(*(ip-1)))); + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1)))); } goto loop; end_loop: + sexp_gc_release(ctx, self, s_self); return _ARG1; } @@ -1719,10 +1723,12 @@ static sexp sexp_exception_type_func (sexp ctx, sexp exn) { static sexp sexp_open_input_file (sexp ctx, sexp path) { FILE *in; - if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); in = fopen(sexp_string_data(path), "r"); if (! in) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); return sexp_make_input_port(ctx, in, sexp_string_data(path)); } @@ -1732,7 +1738,8 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { return sexp_type_exception(ctx, "not a string", path); out = fopen(sexp_string_data(path), "w"); if (! out) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); return sexp_make_input_port(ctx, out, sexp_string_data(path)); } @@ -1781,8 +1788,6 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif sexp_gc_release(ctx, ctx2, s_ctx2); - sexp_gc_release(ctx, x, s_x); - sexp_gc_release(ctx, in, s_in); return res; } @@ -1796,8 +1801,8 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { else if (sexp_integerp(z)) \ d = (double)sexp_unbox_integer(z); \ else \ - return sexp_type_exception(ctx, "not a number", z); \ - return sexp_make_flonum(ctx, cname(d)); \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ } define_math_op(sexp_exp, exp) @@ -1898,6 +1903,7 @@ static struct sexp_struct core_forms[] = { static sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_lambda(e) = NULL; sexp_env_parent(e) = NULL; sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -1938,14 +1944,13 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_make_output_port(ctx, stderr, NULL)); env_define(ctx, e, the_interaction_env_symbol, e); sexp_gc_release(ctx, e, s_e); - sexp_gc_release(ctx, op, s_op); return e; } /************************** eval interface ****************************/ -sexp apply(sexp ctx, sexp proc, sexp args) { - sexp *stack = sexp_context_stack(ctx), ls; +sexp apply (sexp ctx, sexp proc, sexp args) { + sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx), offset; offset = top + sexp_unbox_integer(sexp_length(ctx, args)); for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) @@ -1955,7 +1960,8 @@ sexp apply(sexp ctx, sexp proc, sexp args) { stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - return vm(proc, ctx, stack, top); + sexp_context_top(ctx) = top; + return vm(proc, ctx); } sexp compile (sexp ctx, sexp x) { @@ -1973,7 +1979,6 @@ sexp compile (sexp ctx, sexp x) { finalize_bytecode(ctx2), sexp_make_vector(ctx, 0, SEXP_VOID)); sexp_gc_release(ctx, ast, s_ast); - sexp_gc_release(ctx, ctx2, s_ctx2); return res; } diff --git a/gc.c b/gc.c index 2d1ecca0..afb57970 100644 --- a/gc.c +++ b/gc.c @@ -4,7 +4,7 @@ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 100000000 +#define SEXP_INITIAL_HEAP_SIZE 50000 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -18,6 +18,8 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); case SEXP_VECTOR: return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); + case SEXP_STACK: + return sexp_sizeof(stack)+(sexp_stack_length(x)*sizeof(sexp)); case SEXP_FLONUM: return sexp_sizeof(flonum); case SEXP_BIGNUM: return sexp_sizeof(bignum); case SEXP_IPORT: @@ -37,27 +39,46 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { case SEXP_SEQ: return sexp_sizeof(seq); case SEXP_LIT: return sexp_sizeof(lit); case SEXP_CONTEXT: return sexp_sizeof(context); - default: return 0; + default: return sexp_align(1, 4); } } void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; + struct sexp_gc_var_t *saves; loop: - if ((! sexp_pointerp(x)) || sexp_gc_mark(x)) + if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { + if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE)) + fprintf(stderr, "--------------- outside heap: %p (%x) ------------------\n", x, sexp_pointer_tag(x)); + return; + } + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; + fprintf(stderr, "----------------- marking %p (%x) --------------------\n", + x, sexp_pointer_tag(x)); switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); x = sexp_cdr(x); goto loop; + 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_mark(data[i]); + x = data[0]; + goto loop; 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_mark(data[i]); - x = data[i]; + x = data[0]; + goto loop; + case SEXP_SYMBOL: + x = sexp_symbol_string(x); goto loop; case SEXP_BYTECODE: x = sexp_bytecode_literals(x); @@ -119,71 +140,287 @@ void sexp_mark (sexp x) { case SEXP_LIT: x = sexp_lit_value(x); goto loop; + case SEXP_CONTEXT: + sexp_mark(sexp_context_env(x)); + sexp_mark(sexp_context_bc(x)); + sexp_mark(sexp_context_fv(x)); + sexp_mark(sexp_context_lambda(x)); + sexp_mark(sexp_context_parent(x)); + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(*(saves->var)); + x = sexp_context_stack(x); + goto loop; } } +void simple_write (sexp obj, int depth, FILE *out) { + unsigned long len, c, res; + long i=0; + double f; + char *str=NULL; + + if (! obj) { + fputs("#", out); + } if (! sexp_pointerp(obj)) { + if (sexp_integerp(obj)) { + fprintf(out, "%ld", sexp_unbox_integer(obj)); + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + fputs("#\\space", out); + else if (obj == sexp_make_character('\n')) + fputs("#\\newline", out); + else if (obj == sexp_make_character('\r')) + fputs("#\\return", out); + else if (obj == sexp_make_character('\t')) + fputs("#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) + fprintf(out, "#\\%c", sexp_unbox_character(obj)); + else + fprintf(out, "#\\x%02d", sexp_unbox_character(obj)); + } else if (sexp_symbolp(obj)) { + +#if USE_HUFF_SYMS + if (((sexp_uint_t)obj&7)==7) { + c = ((sexp_uint_t)obj)>>3; + while (c) { +#include "sexp-unhuff.c" + putc(res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + fputs("()", out); break; + case (sexp_uint_t) SEXP_TRUE: + fputs("#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + fputs("#f", out); break; + case (sexp_uint_t) SEXP_EOF: + fputs("#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + fputs("#", out); break; + default: + fprintf(out, "#", obj); + } + } + } else if (depth <= 0) { + fprintf(out, "#<...>"); + } else { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + putc('(', out); + simple_write(sexp_car(obj), depth-1, out); + if (sexp_pairp(sexp_cdr(obj))) { + fputs(" ...", out); + } else if (! sexp_nullp(sexp_cdr(obj))) { + fputs(" . ", out); + simple_write(sexp_cdr(obj), depth-1, out); + } + putc(')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + if (len == 0) { + fputs("#()", out); + } else { + fprintf(out, "#(... %ld ...)", len); + } + break; + case SEXP_FLONUM: + f = sexp_flonum_value(obj); + fprintf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); + break; + case SEXP_PROCEDURE: + fputs("#', out); + break; + case SEXP_IPORT: + fputs("#", out); break; + case SEXP_OPORT: + fputs("#", out); break; + case SEXP_CORE: + fputs("#", out); break; + case SEXP_OPCODE: + fputs("#", out); break; + case SEXP_BYTECODE: + fputs("#", out); break; + case SEXP_ENV: + fprintf(out, "#", obj); break; + case SEXP_EXCEPTION: + fputs("#", out); break; + case SEXP_MACRO: + fputs("#", out); break; + case SEXP_LAMBDA: + fputs("#', out); + break; + case SEXP_SEQ: + fputs("#', out); + break; + case SEXP_CND: + fputs("#', out); + break; + case SEXP_REF: + fputs("#", sexp_ref_loc(obj)); + break; + case SEXP_SET: + fputs("#', out); + break; + case SEXP_LIT: + fputs("#', out); + break; + case SEXP_CONTEXT: + fputs("#", out); + break; + case SEXP_SYNCLO: + fputs("#', out); + break; + case SEXP_STRING: + putc('"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': fputs("\\\\", out); break; + case '"': fputs("\\\"", out); break; + case '\n': fputs("\\n", out); break; + case '\r': fputs("\\r", out); break; + case '\t': fputs("\\t", out); break; + default: putc(str[0], out); + } + } + putc('"', out); + break; + case SEXP_SYMBOL: + i = sexp_string_length(sexp_symbol_string(obj)); + str = sexp_string_data(sexp_symbol_string(obj)); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + putc('\\', out); + putc(str[0], out); + } + break; + default: + fprintf(out, "#", sexp_pointer_tag(obj)); + break; + } + } +} + +void sexp_show_free_list (sexp ctx) { + sexp p=sexp_free_list; + fputs("free-list:", stderr); + while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { + fprintf(stderr, " %p-%p", p, p+(sexp_uint_t)sexp_car(p)); + p = sexp_cdr(p); + } + putc('\n', stderr); +} + sexp sexp_sweep (sexp ctx) { sexp_uint_t freed=0, size; - sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; + sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); + sexp f1=sexp_free_list, f2; + /* scan over the whole heap */ while ((char*)pnext) - if (saves->var) sexp_mark(*(saves->var)); - } + sexp_mark(ctx); return sexp_sweep(ctx); } void *sexp_alloc (sexp ctx, size_t size) { + int tries = 0; sexp ls1, ls2, ls3; - size = sexp_align(size, 3); + size = sexp_align(size, 4); try_alloc: - ls1=sexp_free_list; - for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + ls1 = sexp_free_list; + ls2 = sexp_cdr(ls1); + for (ls2=sexp_cdr(ls1); 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); + if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ sexp_pointer_tag(ls3) = SEXP_PAIR; sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); sexp_cdr(ls3) = sexp_cdr(ls2); sexp_cdr(ls1) = ls3; - } else { + } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } bzero((void*)ls2, size); return ls2; } - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { + ls1=ls2; + ls2=sexp_cdr(ls2); + } + if ((! tries) && (sexp_unbox_integer(sexp_gc(ctx)) >= size)) { + tries++; goto try_alloc; } else { - fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); + fprintf(stderr, + "chibi: out of memory trying to allocate %ld bytes, aborting\n", + size); exit(70); } } @@ -193,12 +430,14 @@ void sexp_gc_init () { sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; sexp_free_list = (sexp)sexp_heap; - next = (sexp) (sexp_heap + sexp_sizeof(pair)); + 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_sizeof(pair)); + sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE + - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; + fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); } diff --git a/sexp.c b/sexp.c index 5b39a125..04745ee1 100644 --- a/sexp.c +++ b/sexp.c @@ -117,10 +117,17 @@ sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { } sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { - return sexp_make_exception(ctx, sexp_intern(ctx, "range"), - sexp_c_string(ctx, "bad index range", -1), - sexp_list3(ctx, obj, start, end), - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, msg, s_msg); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, msg, s_msg); + msg = sexp_c_string(ctx, "bad index range", -1); + res = sexp_list2(ctx, start, end); + res = sexp_cons(ctx, obj, res); + res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res, + SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp_gc_release(ctx, res, s_res); + return res; } sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { @@ -193,6 +200,15 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) { return pair; } +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release(ctx, res, s_res); + return res; +} + sexp sexp_listp (sexp ctx, sexp hare) { sexp turtle; if (! sexp_pairp(hare)) @@ -996,7 +1012,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { in); } break; -/* case '=': */ /* case '0': case '1': case '2': case '3': case '4': */ /* case '5': case '6': case '7': case '8': case '9': */ case ';': @@ -1097,7 +1112,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, tmp, s_tmp); return res; } diff --git a/sexp.h b/sexp.h index 6cd61648..6d4b8789 100644 --- a/sexp.h +++ b/sexp.h @@ -78,6 +78,7 @@ enum sexp_types { SEXP_SET, SEXP_SEQ, SEXP_LIT, + SEXP_STACK, SEXP_CONTEXT, }; @@ -178,13 +179,29 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, *stack, env, fv, parent; + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp bc, lambda, stack, env, fv, parent; struct sexp_gc_var_t *saves; - sexp_uint_t pos, top, depth, tailp, tracep; + sexp_uint_t pos, depth, tailp, tracep; } context; } value; }; +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.lit.value) +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + #define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) #define sexp_context_bc(x) ((x)->value.context.bc) #define sexp_context_fv(x) ((x)->value.context.fv) #define sexp_context_pos(x) ((x)->value.context.pos) -#define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) #define sexp_context_parent(x) ((x)->value.context.parent) #define sexp_context_saves(x) ((x)->value.context.saves) #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) @@ -444,9 +455,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); /****************************** utilities *****************************/ #define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) -#define sexp_list2(x,a,b) sexp_cons((x), (a), sexp_cons((x), (b), SEXP_NULL)) -#define sexp_list3(x,a,b,c) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), SEXP_NULL))) -#define sexp_list4(x,a,b,c,d) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), sexp_cons((x), (d), SEXP_NULL)))) #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) #define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) @@ -481,6 +489,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_list2(sexp ctx, sexp a, sexp b); sexp sexp_equalp (sexp ctx, sexp a, sexp b); sexp sexp_listp(sexp ctx, sexp obj); sexp sexp_reverse(sexp ctx, sexp ls);