From 7e3014ba38e2ca49e094cbd8ab8c70ccbc58b014 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 18 Jun 2009 00:36:39 +0900 Subject: [PATCH] cleanup, removing mid-function returns which could corrupt the gc_var trace. --- Makefile | 2 +- eval.c | 190 ++++++++++++++----------- gc.c | 33 +++-- sexp-huff.c => opt/sexp-huff.c | 0 sexp-hufftabs.c => opt/sexp-hufftabs.c | 0 sexp-unhuff.c => opt/sexp-unhuff.c | 0 sexp.c | 147 +++++++++---------- sexp.h | 2 + 8 files changed, 205 insertions(+), 169 deletions(-) rename sexp-huff.c => opt/sexp-huff.c (100%) rename sexp-hufftabs.c => opt/sexp-hufftabs.c (100%) rename sexp-unhuff.c => opt/sexp-unhuff.c (100%) diff --git a/Makefile b/Makefile index cc7450df..ccf712fb 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 -save-temps +CFLAGS=-Wall -O2 -g -save-temps ./gc/gc.a: ./gc/alloc.c cd gc && make diff --git a/eval.c b/eval.c index 758eaab3..2145fdc3 100644 --- a/eval.c +++ b/eval.c @@ -246,12 +246,14 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { return res; } +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) + 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); if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } @@ -354,14 +356,6 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { return exn; } -#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ - return (x); \ - } while (0) - -#define analyze_bind(var, x, ctx) do {(var) = analyze(ctx, x); \ - analyze_check_exception(var); \ - } while (0) - static sexp analyze_app (sexp ctx, sexp x) { sexp_gc_var(ctx, res, s_res); sexp_gc_var(ctx, tmp, s_tmp); @@ -429,20 +423,27 @@ static sexp analyze_set (sexp ctx, sexp x) { sexp_gc_var(ctx, value, s_value); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, value, s_value); - ref = analyze_var_ref(ctx, sexp_cadr(x)); - if (sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); - value = analyze(ctx, sexp_caddr(x)); - if (sexp_exceptionp(ref)) - res = ref; - else if (sexp_exceptionp(value)) - res = value; - else - res = sexp_make_set(ctx, ref, value); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) + && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { + res = sexp_compile_error(ctx, "bad set! syntax", x); + } else { + ref = analyze_var_ref(ctx, sexp_cadr(x)); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x)); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + } sexp_gc_release(ctx, ref, s_ref); return res; } +#define sexp_return(res, val) do {res=val; goto cleanup;} while (0) + static sexp analyze_lambda (sexp ctx, sexp x) { sexp name, ls; sexp_gc_var(ctx, res, s_res); @@ -457,14 +458,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, defs, s_defs); sexp_gc_preserve(ctx, ctx2, s_ctx2); - /* verify syntax - XXXX release! */ + /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) - return sexp_compile_error(ctx, "bad lambda syntax", x); + sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_idp(sexp_car(ls))) - return sexp_compile_error(ctx, "non-symbol parameter", x); + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) - return sexp_compile_error(ctx, "duplicate parameter", x); + sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); ctx2 = sexp_make_child_context(ctx, res); @@ -472,7 +473,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_context_env(ctx2) = extend_env(ctx2, sexp_context_env(ctx2), tmp, res); sexp_env_lambda(sexp_context_env(ctx2)) = res; body = analyze_seq(ctx2, sexp_cddr(x)); - analyze_check_exception(body); + if (sexp_exceptionp(body)) sexp_return(res, body); /* delayed analyze internal defines */ defs = SEXP_NULL; for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { @@ -485,7 +486,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { name = sexp_cadr(tmp); value = analyze(ctx2, sexp_caddr(tmp)); } - analyze_check_exception(value); + if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value)); } @@ -498,6 +499,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; + cleanup: sexp_gc_release(ctx, res, s_res); return res; } @@ -510,11 +512,16 @@ static sexp analyze_if (sexp ctx, sexp x) { sexp_gc_preserve(ctx, test, s_test); sexp_gc_preserve(ctx, pass, s_pass); sexp_gc_preserve(ctx, fail, s_fail); - analyze_bind(test, sexp_cadr(x), ctx); - analyze_bind(pass, sexp_caddr(x), ctx); - fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; - analyze_bind(fail, fail_expr, ctx); - res = sexp_make_cnd(ctx, test, pass, fail); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad if syntax", x); + } else { + test = analyze(ctx, sexp_cadr(x)); + pass = analyze(ctx, sexp_caddr(x)); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + fail = analyze(ctx, fail_expr); + res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : + sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); + } sexp_gc_release(ctx, test, s_test); return res; } @@ -530,35 +537,40 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, env, s_env); env = sexp_context_env(ctx); - name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); - sexp_push(ctx, sexp_env_bindings(env), tmp); - sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); - sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); - sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); - res = SEXP_VOID; + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad define syntax", x); } else { - env_cell_create(ctx, env, name, SEXP_VOID); - if (sexp_pairp(sexp_cadr(x))) { - tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); - tmp = sexp_cons(ctx, SEXP_VOID, tmp); - value = analyze_lambda(ctx, tmp); - } else - value = analyze(ctx, sexp_caddr(x)); - ref = analyze_var_ref(ctx, name); - if (sexp_exceptionp(ref)) - res = ref; - else if (sexp_exceptionp(value)) - res = value; - else - res = sexp_make_set(ctx, ref, value); + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_env_bindings(env), tmp); + sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); + res = SEXP_VOID; + } else { + env_cell_create(ctx, env, name, SEXP_VOID); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + } } sexp_gc_release(ctx, ref, s_ref); return res; } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID; sexp_gc_var(eval_ctx, proc, s_proc); sexp_gc_var(eval_ctx, mac, s_mac); sexp_gc_var(eval_ctx, tmp, s_tmp); @@ -566,16 +578,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp_gc_preserve(eval_ctx, mac, s_mac); sexp_gc_preserve(eval_ctx, tmp, s_tmp); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { - proc = eval_in_context(eval_ctx, sexp_cadar(ls)); - analyze_check_exception(proc); - if (sexp_procedurep(proc)) { - mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); - tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); - sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) + && sexp_nullp(sexp_cddar(ls)))) { + res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); + } else { + proc = eval_in_context(eval_ctx, sexp_cadar(ls)); + if (sexp_exceptionp(proc)) { + res = proc; + break; + } else if (sexp_procedurep(proc)) { + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); + tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); + sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + } } } sexp_gc_release(eval_ctx, proc, s_proc); - return SEXP_VOID; + return res; } static sexp analyze_define_syntax (sexp ctx, sexp x) { @@ -596,14 +615,17 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { sexp_gc_preserve(ctx, env, s_env); sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, tmp, s_tmp); - env = sexp_alloc_type(ctx, env, SEXP_ENV); - sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); - sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); - ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); - sexp_context_env(ctx2) = env; - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); - analyze_check_exception(tmp); - res = analyze_seq(ctx2, sexp_cddr(x)); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } sexp_gc_release(ctx, env, s_env); return res; } @@ -612,8 +634,12 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) { sexp res; sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, tmp, s_tmp); - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); - res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad letrec-syntax", x); + } else { + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + } sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -685,8 +711,8 @@ static sexp analyze (sexp ctx, sexp object) { res = sexp_compile_error(ctx, "too many args for opcode", x); } else { res = analyze_app(ctx, sexp_cdr(x)); - analyze_check_exception(res); - sexp_push(ctx, res, op); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); } } else { res = analyze_app(ctx, x); @@ -2031,15 +2057,19 @@ sexp compile (sexp ctx, sexp x) { sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, vec, s_vec); sexp_gc_preserve(ctx, res, s_res); - analyze_bind(ast, x, ctx); - free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ - ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); - sexp_context_parent(ctx2) = ctx; - generate(ctx2, ast); - res = finalize_bytecode(ctx2); - vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), - res, vec); + ast = analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + ctx2 = sexp_make_context(ctx,sexp_context_stack(ctx),sexp_context_env(ctx)); + sexp_context_parent(ctx2) = ctx; + generate(ctx2, ast); + res = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), + res, vec); + } sexp_gc_release(ctx, ast, s_ast); return res; } diff --git a/gc.c b/gc.c index 0f5c63d7..2770f575 100644 --- a/gc.c +++ b/gc.c @@ -4,9 +4,11 @@ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */ +#define SEXP_INITIAL_HEAP_SIZE 37000 #define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) +#define SEXP_GROW_HEAP_RATIO 0.8 typedef struct sexp_heap *sexp_heap; @@ -21,6 +23,11 @@ static sexp_heap heap; static sexp* stack_base; extern sexp continuation_resumer, final_resumer; +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t res, *len_ptr; sexp t; @@ -57,7 +64,7 @@ void sexp_mark (sexp x) { } } -#ifdef USE_DEBUG_GC +#if USE_DEBUG_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=&x; pnext; h=h->next) - ; + sexp_heap h = sexp_heap_last(heap); cur_size = h->size; new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4); h->next = sexp_make_heap(new_size); @@ -200,17 +205,20 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; + size_t freed; + sexp_heap h; size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) - res = sexp_try_alloc(ctx, size); - if ((! res) && sexp_grow_heap(ctx, size)) - res = sexp_try_alloc(ctx, size); + freed = sexp_unbox_integer(sexp_gc(ctx)); + h = sexp_heap_last(heap); + if (((freed < size) + || ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); if (! res) { - fprintf(stderr, - "chibi: out of memory trying to allocate %ld bytes, aborting\n", - size); + fprintf(stderr, "out of memory allocating %ld bytes, aborting\n", size); exit(70); } } @@ -220,6 +228,7 @@ void* sexp_alloc (sexp ctx, size_t size) { void sexp_gc_init () { sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4); heap = sexp_make_heap(size); + /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; } diff --git a/sexp-huff.c b/opt/sexp-huff.c similarity index 100% rename from sexp-huff.c rename to opt/sexp-huff.c diff --git a/sexp-hufftabs.c b/opt/sexp-hufftabs.c similarity index 100% rename from sexp-hufftabs.c rename to opt/sexp-hufftabs.c diff --git a/sexp-unhuff.c b/opt/sexp-unhuff.c similarity index 100% rename from sexp-unhuff.c rename to opt/sexp-unhuff.c diff --git a/sexp.c b/sexp.c index 79269495..87bf0e6b 100644 --- a/sexp.c +++ b/sexp.c @@ -10,9 +10,9 @@ struct huff_entry { unsigned char len; unsigned short bits; }; -#include "sexp-hufftabs.c" +#include "opt/sexp-hufftabs.c" static struct huff_entry huff_table[] = { -#include "sexp-huff.c" +#include "opt/sexp-huff.c" }; #endif @@ -41,7 +41,6 @@ static int digit_value (c) { } static int is_separator(int c) { - /* return (!((c-9)&(~3))) | (~(c^4)); */ return 0>3; while (c) { -#include "sexp-unhuff.c" +#include "opt/sexp-unhuff.c" sexp_write_char(res, out); } } @@ -1119,7 +1111,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read(ctx, in); if (sexp_listp(ctx, res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { - sexp_deep_free(ctx, res); res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", SEXP_NULL, in); @@ -1192,11 +1183,15 @@ sexp sexp_read (sexp ctx, sexp in) { #if USE_STRING_STREAMS sexp sexp_read_from_string(sexp ctx, char *str) { - sexp s = sexp_c_string(ctx, str, -1); - sexp in = sexp_make_input_string_port(ctx, s); - sexp res = sexp_read(ctx, in); - sexp_free(ctx, s); - sexp_deep_free(ctx, in); + sexp res; + sexp_gc_var(ctx, s, s_s); + sexp_gc_var(ctx, in, s_in); + sexp_gc_preserve(ctx, s, s_s); + sexp_gc_preserve(ctx, in, s_in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release(ctx, s, s_s); return res; } #endif diff --git a/sexp.h b/sexp.h index bded73f8..f713e0bd 100644 --- a/sexp.h +++ b/sexp.h @@ -426,6 +426,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_stack_top(x) ((x)->value.stack.top) #define sexp_stack_data(x) ((x)->value.stack.data) +#define sexp_context_heap(x) ((x)->value.context.heap) +#define sexp_context_symbols(x) ((x)->value.context.symbols) #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)