diff --git a/gc.c b/gc.c index afb57970..49caa5fb 100644 --- a/gc.c +++ b/gc.c @@ -1,10 +1,11 @@ -/* gc.c -- simple garbage collector */ +/* gc.c -- simple mark&sweep garbage collector */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 50000 +#define SEXP_INITIAL_HEAP_SIZE 40000 +#define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -49,15 +50,16 @@ void sexp_mark (sexp x) { struct sexp_gc_var_t *saves; loop: if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { - if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE)) + if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE) + && (sexp_pointer_tag(x) != SEXP_CORE)) 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)); +/* fprintf(stderr, "----------------- marking %p (%x) --------------------\n", */ +/* x, sexp_pointer_tag(x)); */ switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); @@ -153,6 +155,88 @@ void sexp_mark (sexp 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) { + sexp *data; + sexp_uint_t i; + struct sexp_gc_var_t *saves; + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + _adjust(sexp_car(x)); _adjust(sexp_cdr(x)); break; + case SEXP_STACK: + data = sexp_stack_data(x); + for (i=sexp_stack_top(x)-1; i>=0; i--) + _adjust(data[i]); + break; + case SEXP_VECTOR: + data = sexp_vector_data(x); + for (i=sexp_vector_length(x)-1; i>=0; i--) + _adjust(data[i]); + break; + case SEXP_SYMBOL: + _adjust(sexp_symbol_string(x)); break; + case SEXP_BYTECODE: + _adjust(sexp_bytecode_literals(x)); break; + case SEXP_ENV: + _adjust(sexp_env_lambda(x)); + _adjust(sexp_env_bindings(x)); + _adjust(sexp_env_parent(x)); + break; + case SEXP_PROCEDURE: + _adjust(sexp_procedure_code(x)); _adjust(sexp_procedure_vars(x)); break; + case SEXP_MACRO: + _adjust(sexp_macro_proc(x)); _adjust(sexp_macro_env(x)); break; + case SEXP_SYNCLO: + _adjust(sexp_synclo_free_vars(x)); + _adjust(sexp_synclo_expr(x)); + _adjust(sexp_synclo_env(x)); + break; + case SEXP_OPCODE: + _adjust(sexp_opcode_proc(x)); + _adjust(sexp_opcode_default(x)); + _adjust(sexp_opcode_data(x)); + break; + case SEXP_IPORT: + case SEXP_OPORT: + _adjust(sexp_port_cookie(x)); + case SEXP_LAMBDA: + _adjust(sexp_lambda_name(x)); + _adjust(sexp_lambda_params(x)); + _adjust(sexp_lambda_locals(x)); + _adjust(sexp_lambda_defs(x)); + _adjust(sexp_lambda_flags(x)); + _adjust(sexp_lambda_body(x)); + _adjust(sexp_lambda_fv(x)); + _adjust(sexp_lambda_sv(x)); + _adjust(sexp_lambda_body(x)); + break; + case SEXP_CND: + _adjust(sexp_cnd_test(x)); + _adjust(sexp_cnd_fail(x)); + _adjust(sexp_cnd_pass(x)); + break; + case SEXP_SET: + _adjust(sexp_set_var(x)); _adjust(sexp_set_value(x)); break; + case SEXP_REF: + _adjust(sexp_ref_name(x)); _adjust(sexp_ref_cell(x)); break; + case SEXP_SEQ: + _adjust(sexp_seq_ls(x)); break; + case SEXP_LIT: + _adjust(sexp_lit_value(x)); break; + case SEXP_CONTEXT: + _adjust(sexp_context_env(x)); + _adjust(sexp_context_bc(x)); + _adjust(sexp_context_fv(x)); + _adjust(sexp_context_lambda(x)); + _adjust(sexp_context_parent(x)); + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) _adjust(*(saves->var)); + _adjust(sexp_context_stack(x)); + break; + } +} + void simple_write (sexp obj, int depth, FILE *out) { unsigned long len, c, res; long i=0; @@ -161,7 +245,7 @@ void simple_write (sexp obj, int depth, FILE *out) { if (! obj) { fputs("#", out); - } if (! sexp_pointerp(obj)) { + } else if (! sexp_pointerp(obj)) { if (sexp_integerp(obj)) { fprintf(out, "%ld", sexp_unbox_integer(obj)); } else if (sexp_charp(obj)) { @@ -334,10 +418,15 @@ void simple_write (sexp obj, int depth, FILE *out) { } void sexp_show_free_list (sexp ctx) { - sexp p=sexp_free_list; + sexp p=sexp_free_list, prev=NULL; 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)); + if (p < prev) { + fprintf(stderr, " \x1B[31m%p-%p\x1B[0m", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); + } else { + fprintf(stderr, " %p-%p", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); + } + prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); p = sexp_cdr(p); } putc('\n', stderr); @@ -346,33 +435,36 @@ void sexp_show_free_list (sexp ctx) { sexp sexp_sweep (sexp ctx) { sexp_uint_t freed=0, size; sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); - sexp f1=sexp_free_list, f2; + sexp q=sexp_free_list, r; /* scan over the whole heap */ - while ((char*)p size) ? cur_size : size) * 2, 4); + /* fprintf(stderr, "************* growing heap *************\n"); */ + if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) { + fprintf(stderr, "************* heap too large *************\n"); + return 0; + } + if (! (tmp1 = realloc(sexp_heap, new_size))) { + fprintf(stderr, "************* couldn't realloc *************\n"); + return 0; + } + if (tmp1 != sexp_heap) { + sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); + tmp2 = sexp_heap; + sexp_heap = tmp1; + free(tmp2); + } else { + for (q = sexp_free_list; + sexp_cdr(q) && sexp_pairp(sexp_cdr(q)); + q = sexp_cdr(q)) + ; + sexp_cdr(q) = (sexp) sexp_heap_end; + q = sexp_cdr(q); + sexp_pointer_tag(q) = SEXP_PAIR; + sexp_car(q) = (sexp) (new_size - cur_size); + sexp_cdr(q) = SEXP_NULL; + } + sexp_heap_end = sexp_heap + new_size; + return 1; +} + +void* sexp_try_alloc (sexp ctx, size_t size) { sexp ls1, ls2, ls3; - size = sexp_align(size, 4); - try_alloc: ls1 = sexp_free_list; ls2 = sexp_cdr(ls1); for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ) { @@ -408,21 +559,32 @@ void *sexp_alloc (sexp ctx, size_t size) { } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } - bzero((void*)ls2, size); + bzero((void*)ls2, size); /* maybe not needed */ return ls2; } - ls1=ls2; - ls2=sexp_cdr(ls2); + 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); - exit(70); + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + 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); + if (! res) { + fprintf(stderr, + "chibi: out of memory trying to allocate %ld bytes, aborting\n", + size); + exit(70); + } } + return res; } void sexp_gc_init () { @@ -438,6 +600,6 @@ void sexp_gc_init () { 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); + /* fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); */ }