diff --git a/eval.c b/eval.c index e395ea57..9123cd60 100644 --- a/eval.c +++ b/eval.c @@ -337,18 +337,18 @@ static void sexp_add_path (sexp ctx, const char *str) { } void sexp_init_eval_context_globals (sexp ctx) { - sexp_gc_var2(tmp, vec); + sexp_gc_var3(tmp, vec, ctx2); ctx = sexp_make_child_context(ctx, NULL); - sexp_gc_preserve2(ctx, tmp, vec); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); vec = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); #if ! SEXP_USE_NATIVE_X86 emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); - ctx = sexp_make_child_context(ctx, NULL); - emit(ctx, SEXP_OP_DONE); - tmp = finalize_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + emit(ctx2, SEXP_OP_DONE); + tmp = finalize_bytecode(ctx2); vec = sexp_make_vector(ctx, 0, SEXP_VOID); sexp_global(ctx, SEXP_G_FINAL_RESUMER) = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); @@ -362,7 +362,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); tmp = sexp_c_string(ctx, ".", 1); sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp); - sexp_gc_release2(ctx); + sexp_gc_release3(ctx); } sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) { @@ -390,10 +390,12 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) { sexp_context_stack(ctx), sexp_context_env(ctx), 0); - sexp_context_lambda(res) = lambda; - sexp_context_top(res) = sexp_context_top(ctx); - sexp_context_fv(res) = sexp_context_fv(ctx); - sexp_context_tracep(res) = sexp_context_tracep(ctx); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } return res; } @@ -547,7 +549,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ - res = sexp_make_lambda(ctx, sexp_copy_list(ctx, sexp_cadr(x))); + res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); @@ -581,7 +583,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } sexp_lambda_body(res) = body; cleanup: - sexp_gc_release1(ctx); + sexp_gc_release6(ctx); return res; } diff --git a/gc.c b/gc.c index bb5e7b87..fb15ec13 100644 --- a/gc.c +++ b/gc.c @@ -8,21 +8,21 @@ #include #endif -#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) - #if SEXP_64_BIT #define sexp_heap_align(n) sexp_align(n, 5) #else #define sexp_heap_align(n) sexp_align(n, 4) #endif +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair))) + #define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) #if SEXP_USE_GLOBAL_HEAP sexp_heap sexp_global_heap; #endif -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC static sexp* stack_base; #endif @@ -41,6 +41,25 @@ sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) { return res; } +#if SEXP_USE_SAFE_GC_MARK +static int sexp_in_heap(sexp ctx, sexp_uint_t x) { + sexp_heap h; + if (x & (sexp_heap_align(1)-1)) { + fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size))) + return 1; + fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x)); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC +#include "opt/gc_debug.c" +#endif + void sexp_mark (sexp ctx, sexp x) { sexp_sint_t i, len; sexp t, *p; @@ -48,6 +67,16 @@ void sexp_mark (sexp ctx, sexp x) { loop: if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; +#if SEXP_USE_SAFE_GC_MARK + if (! sexp_in_heap(ctx, (sexp_uint_t)x)) + return; +#endif +#if SEXP_USE_HEADER_MAGIC + if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE + && sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE + && sexp_pointer_tag(x) != SEXP_STACK) + return; +#endif sexp_gc_mark(x) = 1; if (sexp_contextp(x)) for (saves=sexp_context_saves(x); saves; saves=saves->next) @@ -63,7 +92,7 @@ void sexp_mark (sexp ctx, sexp x) { } } -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=(&x)+1; pnext) { p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); q = h->free_list; - end = (sexp) ((char*)h->data + h->size); + end = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair))); while (p < end) { /* find the preceding and succeeding free list pointers */ for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) @@ -148,6 +177,9 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_mark(ctx, sexp_symbol_table[i]); #endif sexp_mark(ctx, ctx); +#if SEXP_USE_DEBUG_GC + sexp_sweep_stats(ctx, 2, NULL, "* \x1B[31mFREE:\x1B[0m "); +#endif res = sexp_sweep(ctx, sum_freed); return res; } @@ -166,7 +198,7 @@ sexp_heap sexp_make_heap (size_t size) { h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); free = h->free_list = (sexp_free_list) h->data; h->next = NULL; - next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); + next = (sexp_free_list) (((char*)free) + sexp_heap_align(sexp_sizeof(pair))); free->size = 0; /* actually sexp_sizeof(pair) */ free->next = next; next->size = size - sexp_heap_align(sexp_sizeof(pair)); @@ -308,13 +340,13 @@ sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { #endif void sexp_gc_init (void) { -#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC +#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); #endif #if SEXP_USE_GLOBAL_HEAP sexp_global_heap = sexp_make_heap(size); #endif -#if SEXP_USE_DEBUG_GC +#if SEXP_USE_CONSERVATIVE_GC /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; #endif diff --git a/include/chibi/features.h b/include/chibi/features.h index a3a7d7b2..562d0d49 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -66,6 +66,15 @@ /* uncomment this to add conservative checks to the native GC */ /* Please mail the author if enabling this makes a bug */ /* go away and you're not working on your own C extension. */ +/* #define SEXP_USE_CONSERVATIVE_GC 1 */ + +/* uncomment this to add additional native checks to only mark objects in the heap */ +/* #define SEXP_USE_SAFE_GC_MARK 1 */ + +/* uncomment this to add additional native gc checks to verify a magic header */ +/* #define SEXP_USE_HEADER_MAGIC 1 */ + +/* uncomment this to add very verbose debugging stats to the native GC */ /* #define SEXP_USE_DEBUG_GC 1 */ /* uncomment this to make the heap common to all contexts */ @@ -175,7 +184,7 @@ #define SEXP_MAXIMUM_HEAP_SIZE 0 #endif #ifndef SEXP_MINIMUM_HEAP_SIZE -#define SEXP_MINIMUM_HEAP_SIZE 512*1024 +#define SEXP_MINIMUM_HEAP_SIZE 8*1024 #endif /* if after GC more than this percentage of memory is still in use, */ @@ -257,6 +266,18 @@ #define SEXP_USE_DEBUG_GC 0 #endif +#ifndef SEXP_USE_SAFE_GC_MARK +#define SEXP_USE_SAFE_GC_MARK 0 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + #ifndef SEXP_USE_GLOBAL_HEAP #if SEXP_USE_BOEHM || SEXP_USE_MALLOC #define SEXP_USE_GLOBAL_HEAP 1 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 9cd0807f..004b1c6a 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -64,6 +64,10 @@ typedef unsigned long size_t; #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 +#ifndef SEXP_POINTER_MAGIC +#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */ +#endif + #if SEXP_USE_HASH_SYMS #define SEXP_SYMBOL_TABLE_SIZE 389 #else @@ -105,8 +109,8 @@ enum sexp_types { SEXP_NUM_CORE_TYPES }; -typedef unsigned long sexp_uint_t; -typedef long sexp_sint_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; #if SEXP_64_BIT typedef unsigned int sexp_tag_t; #else @@ -154,12 +158,16 @@ struct sexp_heap_t { sexp_uint_t size; sexp_free_list free_list; sexp_heap next; + /* note this must be aligned on a proper heap boundary, */ + /* so we can't just use char data[] */ char *data; }; struct sexp_gc_var_t { sexp *var; - /* char *name; */ +#if SEXP_USE_CONSERVATIVE_GC + char *name; +#endif struct sexp_gc_var_t *next; }; @@ -168,6 +176,9 @@ struct sexp_struct { char gc_mark; unsigned int immutablep:1; unsigned int freep:1; +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif union { /* basic types */ double flonum; @@ -314,10 +325,16 @@ struct sexp_struct { sexp x = SEXP_VOID; \ struct sexp_gc_var_t y = {NULL, NULL}; +#if SEXP_USE_CONSERVATIVE_GC +#define sexp_gc_preserve_name(ctx, x, y) (y).name = #x +#else +#define sexp_gc_preserve_name(ctx, x, y) +#endif + #define sexp_gc_preserve(ctx, x, y) \ do { \ + sexp_gc_preserve_name(ctx, x, y); \ (y).var = &(x); \ - /* (y).name = #x; */ \ (y).next = sexp_context_saves(ctx); \ sexp_context_saves(ctx) = &(y); \ } while (0) @@ -403,6 +420,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_flags(x) ((x)->flags) #define sexp_immutablep(x) ((x)->immutablep) #define sexp_freep(x) ((x)->freep) +#define sexp_pointer_magic(x) ((x)->magic) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) @@ -829,7 +847,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size); +SEXP_API sexp sexp_make_context(sexp ctx, size_t size); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 57dcf94d..21262128 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -74,7 +74,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_FCALL4: case SEXP_OP_FCALL5: case SEXP_OP_FCALL6: - sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + sexp_printf(ctx, out, "%d", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case SEXP_OP_SLOT_REF: diff --git a/sexp.c b/sexp.c index 35861be0..9ed7c016 100644 --- a/sexp.c +++ b/sexp.c @@ -49,7 +49,12 @@ sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE]; sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { sexp res = (sexp) sexp_alloc(ctx, size); - if (res && ! sexp_exceptionp(res)) sexp_pointer_tag(res) = tag; + if (res && ! sexp_exceptionp(res)) { + sexp_pointer_tag(res) = tag; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(res) = SEXP_POINTER_MAGIC; +#endif + } return res; } @@ -266,7 +271,7 @@ sexp sexp_bootstrap_context (sexp_uint_t size) { } #endif -sexp sexp_make_context (sexp ctx, sexp_uint_t size) { +sexp sexp_make_context (sexp ctx, size_t size) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); #if ! SEXP_USE_GLOBAL_HEAP @@ -550,8 +555,8 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { sexp tmp; sexp_gc_var1(res); - sexp_gc_preserve1(ctx, res); if (! sexp_pairp(ls)) return ls; + sexp_gc_preserve1(ctx, res); tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); @@ -664,6 +669,9 @@ sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch) s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); if (sexp_exceptionp(s)) return s; sexp_pointer_tag(s) = SEXP_STRING; +#if SEXP_USE_HEADER_MAGIC + sexp_pointer_magic(s) = SEXP_POINTER_MAGIC; +#endif sexp_string_length(s) = clen; if (sexp_charp(ch)) memset(sexp_string_data(s), sexp_unbox_character(ch), clen); @@ -1205,7 +1213,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { break; } } else if (sexp_fixnump(obj)) { - snprintf(numbuf, NUMBUF_LEN, "%ld", sexp_unbox_fixnum(obj)); + snprintf(numbuf, NUMBUF_LEN, "%d", sexp_unbox_fixnum(obj)); sexp_write_string(ctx, numbuf, out); #if SEXP_USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { diff --git a/vm.c b/vm.c index 6a53e941..88bf4fcc 100644 --- a/vm.c +++ b/vm.c @@ -421,7 +421,7 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { #define _PUSH(x) (stack[top++]=(x)) #if SEXP_USE_ALIGNED_BYTECODE -#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((unsigned long)ip) +#define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip) #else #define _ALIGN_IP() #endif