diff --git a/Makefile b/Makefile index d23dd575..fe8e381a 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,8 @@ LDFLAGS=-lm # -Oz for smaller size on darwin CFLAGS=-Wall -g -Os -save-temps -GC_OBJ=./gc/gc.a +#GC_OBJ=./gc/gc.a +GC_OBJ= ./gc/gc.a: ./gc/alloc.c cd gc && make @@ -38,7 +39,7 @@ cleaner: clean rm -f chibi-scheme rm -rf *.dSYM -test: chibi-scheme +test-basic: chibi-scheme @for f in tests/basic/*.scm; do \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ @@ -47,6 +48,8 @@ test: chibi-scheme echo "[FAIL] $${f%.scm}"; \ fi; \ done + +test: chibi-scheme ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm # install: chibi-scheme diff --git a/defaults.h b/defaults.h index 2367f68f..ad53a516 100644 --- a/defaults.h +++ b/defaults.h @@ -17,7 +17,7 @@ #endif #ifndef USE_BOEHM -#define USE_BOEHM 1 +#define USE_BOEHM 0 #endif #ifndef USE_MALLOC @@ -60,24 +60,3 @@ #define USE_CHECK_STACK 0 #endif -#if USE_BOEHM -#include "gc/include/gc.h" -#define sexp_alloc(ctx, size) GC_malloc(size) -#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) -#define sexp_realloc(ctx, x, size) GC_realloc(x, size) -#define sexp_free(ctx, x) -#define sexp_deep_free(ctx, x) -#elif USE_MALLOC -#define sexp_alloc(ctx, size) malloc(size) -#define sexp_alloc_atomic(ctx, size) malloc(size) -#define sexp_realloc(ctx, x, size) realloc(x, size) -#define sexp_free(ctx, x) free(x) -void sexp_deep_free(sexp ctx, sexp obj); -#else /* native gc */ -void *sexp_alloc(sexp ctx, size_t size); -#define sexp_alloc_atomic sexp_alloc -void *sexp_realloc(sexp ctx, sexp x, size_t size); -#define sexp_free(ctx, x) -#define sexp_deep_free(ctx, x) -#endif - diff --git a/gc.c b/gc.c index f6f7a537..8e9856b1 100644 --- a/gc.c +++ b/gc.c @@ -2,9 +2,9 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#include +#include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 10000000 +#define SEXP_INITIAL_HEAP_SIZE 100000000 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -12,7 +12,7 @@ static char* sexp_heap_end; static sexp sexp_free_list; sexp_uint_t sexp_allocated_bytes (sexp x) { - switch (sexp_tag(x)) { + switch (sexp_pointer_tag(x)) { case SEXP_PAIR: return sexp_sizeof(pair); case SEXP_SYMBOL: return sexp_sizeof(symbol); case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); @@ -41,38 +41,14 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { } } -void *sexp_alloc (sexp ctx, size_t size) { - sexp ls1, ls2, ls3; - try_alloc: - ls1=sexp_free_list; - for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) - if (sexp_car(ls2) >= size) { - if (sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { - ls3 = (sexp) (((char*)ls2)+size); - sexp_car(ls3) = (sexp) (sexp_car(ls2) - size); - sexp_cdr(ls3) = sexp_cdr(ls2); - sexp_cdr(ls1) = sexp_cdr(ls3); - } else { - sexp_cdr(ls1) = sexp_cdr(ls2); - } - return ls2; - } - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { - goto try_alloc; - } else { - fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); - exit(70); - } -} - void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; loop: - if ((! sexp_pointerp(x)) || sexp_mark(x)) + if ((! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; - switch (sexp_tag(x)) { + switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); x = sexp_cdr(x); @@ -87,42 +63,75 @@ void sexp_mark (sexp x) { sexp sexp_sweep () { sexp_uint_t freed=0, size; sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; - while (p= size) { + if ((sexp_uint_t)sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { + ls3 = (sexp) (((char*)ls2)+size); + 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 { + sexp_cdr(ls1) = sexp_cdr(ls2); + } + bzero((void*)ls2, size); + return ls2; + } + if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { + goto try_alloc; + } else { + fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); + exit(70); + } +} + +void sexp_gc_init () { + sexp next; + 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)); + 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_cdr(next) = SEXP_NULL; } diff --git a/sexp.c b/sexp.c index ee113fda..13190cd6 100644 --- a/sexp.c +++ b/sexp.c @@ -63,6 +63,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { } #if ! USE_BOEHM +#if USE_MALLOC void sexp_deep_free (sexp ctx, sexp obj) { int len, i; sexp *elts; @@ -87,6 +88,9 @@ void sexp_deep_free (sexp ctx, sexp obj) { sexp_free(ctx, obj); } } +#else +#include "gc.c" +#endif #endif /***************************** exceptions *****************************/ @@ -788,7 +792,7 @@ char* sexp_read_string(sexp ctx, sexp in) { } } - buf[i] = '\0'; + buf[i++] = '\0'; res = sexp_alloc(ctx, i); memcpy(res, buf, i); sexp_free(ctx, buf); @@ -819,7 +823,7 @@ char* sexp_read_symbol(sexp ctx, sexp in, int init) { } } - buf[i] = '\0'; + buf[i++] = '\0'; res = sexp_alloc(ctx, i); memcpy(res, buf, i); sexp_free(ctx, buf); @@ -1130,6 +1134,8 @@ void sexp_init() { GC_init(); GC_add_roots((char*)&symbol_table, ((char*)&symbol_table)+sizeof(symbol_table)+1); +#elif ! USE_MALLOC + sexp_gc_init(); #endif for (i=0; i #include +#include #include #include #include @@ -110,6 +111,11 @@ struct sexp_struct { struct { sexp kind, message, irritants, procedure, file, line; } exception; + struct { + char sign; + sexp_uint_t length; + sexp_uint_t *data; + } bignum; /* runtime types */ struct { char flags; @@ -168,6 +174,29 @@ struct sexp_struct { } value; }; +#if USE_BOEHM +#include "gc/include/gc.h" +#define sexp_alloc(ctx, size) GC_malloc(size) +#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) +#define sexp_realloc(ctx, x, size) GC_realloc(x, size) +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#elif USE_MALLOC +#define sexp_alloc(ctx, size) malloc(size) +#define sexp_alloc_atomic(ctx, size) malloc(size) +#define sexp_realloc(ctx, x, size) realloc(x, size) +#define sexp_free(ctx, x) free(x) +void sexp_deep_free(sexp ctx, sexp obj); +#else /* native gc */ +void *sexp_alloc(sexp ctx, size_t size); +#define sexp_alloc_atomic sexp_alloc +void *sexp_realloc(sexp ctx, sexp x, size_t size); +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#endif + +#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) + #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) @@ -196,6 +225,7 @@ struct sexp_struct { #define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) #define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))