From a24de22094429035d7a68f28441993256b5ac45c Mon Sep 17 00:00:00 2001
From: foof <ashinn@users.noreply.github.com>
Date: Mon, 21 Jun 2010 14:42:36 +0000
Subject: [PATCH] gc bug fixes, adding optional gc debugging utils

---
 eval.c                   | 26 ++++++++++++----------
 gc.c                     | 48 +++++++++++++++++++++++++++++++++-------
 include/chibi/features.h | 23 ++++++++++++++++++-
 include/chibi/sexp.h     | 28 ++++++++++++++++++-----
 lib/chibi/disasm.c       |  2 +-
 sexp.c                   | 16 ++++++++++----
 vm.c                     |  2 +-
 7 files changed, 113 insertions(+), 32 deletions(-)

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 <sys/mman.h>
 #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; p<stack_base; p++)
@@ -85,7 +114,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
   for ( ; h; h=h->next) {
     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