adding interoperability with boehm gc if BOEHM_GC is defined

femtolisp/aliases.scm

@@ -295,3 +295,6 @@
   (let ((b (buffer)))
     (with-output-to b (thunk))
     (io.tostring! b)))
+
+(define (read-u8) (io.read *input-stream* 'uint8))
+(define modulo mod)

femtolisp/cvalues.c

@@ -43,6 +43,7 @@ static size_t nfinalizers=0;
 static size_t maxfinalizers=0;
 static size_t malloc_pressure = 0;
 
+#ifndef BOEHM_GC
 void add_finalizer(cvalue_t *cv)
 {
     if (nfinalizers == maxfinalizers) {
@@ -81,7 +82,7 @@ static void sweep_finalizers()
 #ifndef NDEBUG
                 memset(cv_data(tmp), 0xbb, cv_len(tmp));
 #endif
-                free(cv_data(tmp));
+                LLT_FREE(cv_data(tmp));
             }
             ndel++;
         }
@@ -95,6 +96,12 @@ static void sweep_finalizers()
 
     malloc_pressure = 0;
 }
+#else // BOEHM_GC
+void add_finalizer(cvalue_t *cv)
+{
+    (void)cv;
+}
+#endif // BOEHM_GC
 
 // compute the size of the metadata object for a cvalue
 static size_t cv_nwords(cvalue_t *cv)
@@ -153,7 +160,7 @@ value_t cvalue(fltype_t *type, size_t sz)
             gc(0);
         pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
         pcv->type = type;
-        pcv->data = malloc(sz);
+        pcv->data = LLT_ALLOC(sz);
         autorelease(pcv);
         malloc_pressure += sz;
     }
@@ -232,7 +239,7 @@ void cv_pin(cvalue_t *cv)
         return;
     size_t sz = cv_len(cv);
     if (cv_isstr(cv)) sz++;
-    void *data = malloc(sz);
+    void *data = LLT_ALLOC(sz);
     memcpy(data, cv_data(cv), sz);
     cv->data = data;
     autorelease(cv);
@@ -664,6 +671,9 @@ value_t cvalue_relocate(value_t v)
     if (t->vtable != NULL && t->vtable->relocate != NULL)
         t->vtable->relocate(v, ncv);
     forward(v, ncv);
+#ifdef BOEHM_GC
+    cv->data = NULL;
+#endif
     return ncv;
 }
 
@@ -679,7 +689,7 @@ value_t cvalue_copy(value_t v)
     if (!isinlined(cv)) {
         size_t len = cv_len(cv);
         if (cv_isstr(cv)) len++;
-        ncv->data = malloc(len);
+        ncv->data = LLT_ALLOC(len);
         memcpy(ncv->data, cv_data(cv), len);
         autorelease(ncv);
         if (hasparent(cv)) {
@@ -888,7 +898,7 @@ value_t fl_builtin(value_t *args, u_int32_t nargs)
 
 value_t cbuiltin(char *name, builtin_t f)
 {
-    cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));
+    cvalue_t *cv = (cvalue_t*)LLT_ALLOC(CVALUE_NWORDS * sizeof(value_t));
     cv->type = builtintype;
     cv->data = &cv->_space[0];
     cv->len = sizeof(value_t);

femtolisp/flisp.c

@@ -121,7 +121,7 @@ static unsigned char *fromspace;
 static unsigned char *tospace;
 static unsigned char *curheap;
 static unsigned char *lim;
-static uint32_t heapsize = 512*1024;//bytes
+static uint32_t heapsize;//bytes
 static uint32_t *consflags;
 
 // error utilities ------------------------------------------------------------
@@ -245,7 +245,7 @@ static symbol_t *mk_symbol(char *str)
     symbol_t *sym;
     size_t len = strlen(str);
 
-    sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
+    sym = (symbol_t*)LLT_ALLOC(sizeof(symbol_t)-sizeof(void*) + len + 1);
     assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
     sym->left = sym->right = NULL;
     sym->flags = 0;
@@ -564,7 +564,9 @@ void gc(int mustgrow)
     memory_exception_value = relocate(memory_exception_value);
     the_empty_vector = relocate(the_empty_vector);
 
+#ifndef BOEHM_GC
     sweep_finalizers();
+#endif
 
 #ifdef VERBOSEGC
     printf("GC: found %d/%d live conses\n",
@@ -578,7 +580,7 @@ void gc(int mustgrow)
     // more space to fill next time. if we grew tospace last time,
     // grow the other half of the heap this time to catch up.
     if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {
-        temp = realloc(tospace, grew ? heapsize : heapsize*2);
+        temp = LLT_REALLOC(tospace, grew ? heapsize : heapsize*2);
         if (temp == NULL)
             fl_raise(memory_exception_value);
         tospace = temp;
@@ -600,7 +602,7 @@ void gc(int mustgrow)
 static void grow_stack()
 {
     size_t newsz = N_STACK + (N_STACK>>1);
-    value_t *ns = realloc(Stack, newsz*sizeof(value_t));
+    value_t *ns = LLT_REALLOC(Stack, newsz*sizeof(value_t));
     if (ns == NULL)
         lerror(MemoryError, "stack overflow");
     Stack = ns;
@@ -2145,21 +2147,23 @@ static builtinspec_t core_builtin_info[] = {
 extern void builtins_init();
 extern void comparehash_init();
 
-static void lisp_init(void)
+static void lisp_init(size_t initial_heapsize)
 {
     int i;
 
     llt_init();
 
-    fromspace = malloc(heapsize);
-    tospace   = malloc(heapsize);
+    heapsize = initial_heapsize;
+
+    fromspace = LLT_ALLOC(heapsize);
+    tospace   = LLT_ALLOC(heapsize);
     curheap = fromspace;
     lim = curheap+heapsize-sizeof(cons_t);
     consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
     htable_new(&printconses, 32);
     comparehash_init();
     N_STACK = 262144;
-    Stack = malloc(N_STACK*sizeof(value_t));
+    Stack = LLT_ALLOC(N_STACK*sizeof(value_t));
 
     FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
     FL_T = builtin(OP_BOOL_CONST_T);
@@ -2243,9 +2247,9 @@ value_t fl_toplevel_eval(value_t expr)
     return fl_applyn(1, symbol_value(evalsym), expr);
 }
 
-void fl_init()
+void fl_init(size_t initial_heapsize)
 {
-    lisp_init();
+    lisp_init(initial_heapsize);
 }
 
 int fl_load_system_image(value_t sys_image_iostream)

femtolisp/flisp.h

@@ -354,7 +354,7 @@ value_t fl_hash(value_t *args, u_int32_t nargs);
 value_t cvalue_byte(value_t *args, uint32_t nargs);
 value_t cvalue_wchar(value_t *args, uint32_t nargs);
 
-void fl_init();
+void fl_init(size_t initial_heapsize);
 int fl_load_system_image(value_t ios);
 
 #endif

femtolisp/flmain.c

@@ -35,7 +35,7 @@ int main(int argc, char *argv[])
 {
     char fname_buf[1024];
 
-    fl_init();
+    fl_init(512*1024);
 
     fname_buf[0] = '\0';
     value_t str = symbol_value(symbol("*install-dir*"));

femtolisp/read.c

@@ -426,20 +426,20 @@ static value_t read_string()
     value_t s;
     u_int32_t wc;
 
-    buf = malloc(sz);
+    buf = LLT_ALLOC(sz);
     while (1) {
         if (i >= sz-4) {  // -4: leaves room for longest utf8 sequence
             sz *= 2;
-            temp = realloc(buf, sz);
+            temp = LLT_REALLOC(buf, sz);
             if (temp == NULL) {
-                free(buf);
+                LLT_FREE(buf);
                 lerror(ParseError, "read: out of memory reading string");
             }
             buf = temp;
         }
         c = ios_getc(F);
         if (c == IOS_EOF) {
-            free(buf);
+            LLT_FREE(buf);
             lerror(ParseError, "read: unexpected end of input in string");
         }
         if (c == '"')
@@ -447,7 +447,7 @@ static value_t read_string()
         else if (c == '\\') {
             c = ios_getc(F);
             if (c == IOS_EOF) {
-                free(buf);
+                LLT_FREE(buf);
                 lerror(ParseError, "read: end of input in escape sequence");
             }
             j=0;
@@ -474,7 +474,7 @@ static value_t read_string()
                 eseq[j] = '\0';
                 if (j) wc = strtol(eseq, NULL, 16);
                 else {
-                    free(buf);
+                    LLT_FREE(buf);
                     lerror(ParseError, "read: invalid escape sequence");
                 }
                 if (ndig == 2)
@@ -492,7 +492,7 @@ static value_t read_string()
     }
     s = cvalue_string(i);
     memcpy(cvalue_data(s), buf, i);
-    free(buf);
+    LLT_FREE(buf);
     return s;
 }
 

femtolisp/types.c

@@ -22,7 +22,7 @@ fltype_t *get_type(value_t t)
         sz = ctype_sizeof(t, &align);
     }
 
-    ft = (fltype_t*)malloc(sizeof(fltype_t));
+    ft = (fltype_t*)LLT_ALLOC(sizeof(fltype_t));
     ft->type = t;
     if (issymbol(t)) {
         ft->numtype = sym_to_numtype(t);
@@ -42,7 +42,7 @@ fltype_t *get_type(value_t t)
         if (isarray) {
             fltype_t *eltype = get_type(car_(cdr_(t)));
             if (eltype->size == 0) {
-                free(ft);
+                LLT_FREE(ft);
                 lerror(ArgError, "invalid array element type");
             }
             ft->elsz = eltype->size;
@@ -70,7 +70,7 @@ fltype_t *get_array_type(value_t eltype)
 fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
                              cvinitfunc_t init)
 {
-    fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
+    fltype_t *ft = (fltype_t*)LLT_ALLOC(sizeof(fltype_t));
     ft->type = sym;
     ft->size = sz;
     ft->numtype = N_NUMTYPES;

llt/dtypes.h

@@ -16,7 +16,7 @@
   We assume the LP64 convention for 64-bit platforms.
 */
 
-#if 0
+#ifdef BOEHM_GC
 // boehm GC allocator
 #include <gc.h>
 #define LLT_ALLOC(n) GC_MALLOC(n)