gc allocation working, need to fix garbage collecting

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

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
-

gc.c

@@ -2,9 +2,9 @@
 /*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt  */
 
-#include <sexp.h>
+#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<sexp_heap_end) {
+  while ((char*)p<sexp_heap_end) {
     for (f2=sexp_cdr(f1); sexp_pairp(f2) && (f2 < p); f1=f2, f2=sexp_cdr(f2))
       ;
     size = sexp_allocated_bytes(p);
-    if (! sexp_mark(p)) {
+    if (! sexp_gc_mark(p)) {
       freed += size;
       sexp_car(p) = (sexp)size;
-      sexp_cdr(p) = f;
-      f = p;
+      sexp_cdr(p) = f2;
+      f1 = f2;
     } else {
-      sexp_mark(p) = 0;
+      sexp_gc_mark(p) = 0;
     }
     p += size;
   }
-  sexp_free_list = f;
   return sexp_make_integer(freed);
 }
 
 sexp sexp_gc (sexp ctx) {
   int i;
-  sexp ctx2, stack = sexp_context_stack(ctx);
+  sexp *stack = sexp_context_stack(ctx);
+  fprintf(stderr, "garbage collecting\n");
   for (i=0; i<sexp_context_top(ctx); i++)
     sexp_mark(stack[i]);
-  for ( ; ctx; ctx=sexp_context_(ctx)) {
-    sexp_gc_mark(ctx) = 1;
-    sexp_gc_mark(sexp_context_bc(ctx)) = 1;
-    sexp_mark(sexp_context_env(ctx));
-  }
+/*   for ( ; ctx; ctx=sexp_context_(ctx)) { */
+/*     sexp_gc_mark(ctx) = 1; */
+/*     sexp_gc_mark(sexp_context_bc(ctx)) = 1; */
+/*     sexp_mark(sexp_context_env(ctx)); */
+/*   } */
   return sexp_sweep();
 }
 
-void sexp_gc_init () {
-  sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE);
-  sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE;
-  sexp_free_list = sexp_heap;
-  sexp_car(sexp_free_list) = SEXP_INITIAL_HEAP_SIZE;
-  sexp_cdr(sexp_free_list) = SEXP_NULL;
+void *sexp_alloc (sexp ctx, size_t size) {
+  sexp ls1, ls2, ls3;
+  size = sexp_align(size, 3);
+ try_alloc:
+  ls1=sexp_free_list;
+  for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
+    if ((sexp_uint_t)sexp_car(ls2) >= 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;
 }
 

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<SEXP_SYMBOL_TABLE_SIZE; i++)
       symbol_table[i] = SEXP_NULL;

sexp.h

@@ -10,6 +10,7 @@
 
 #include <ctype.h>
 #include <stdio.h>
+#include <stddef.h>
 #include <stdlib.h>
 #include <string.h>
 #include <stdarg.h>
@@ -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)))