ref: a2b57453cbe3926e4e0425893bbc4565683fdf25
parent: 8d7576250d2dbb5e95cba9cfba453e6ae75fab98
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sun May 2 16:36:39 EDT 2010
adding interoperability with boehm gc if BOEHM_GC is defined
--- a/femtolisp/aliases.scm
+++ b/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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -43,6 +43,7 @@
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 @@
#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 @@
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 @@
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 @@
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 @@
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 @@
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 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);
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -121,7 +121,7 @@
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 @@
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 @@
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 @@
// 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 @@
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,14 +2147,16 @@
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);
@@ -2159,7 +2163,7 @@
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 @@
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)
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -354,7 +354,7 @@
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
--- a/femtolisp/flmain.c
+++ b/femtolisp/flmain.c
@@ -35,7 +35,7 @@
{
char fname_buf[1024];
- fl_init();
+ fl_init(512*1024);
fname_buf[0] = '\0';
value_t str = symbol_value(symbol("*install-dir*"));
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -426,13 +426,13 @@
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;
@@ -439,7 +439,7 @@
}
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 @@
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 @@
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 @@
}
s = cvalue_string(i);
memcpy(cvalue_data(s), buf, i);
- free(buf);
+ LLT_FREE(buf);
return s;
}
--- a/femtolisp/types.c
+++ b/femtolisp/types.c
@@ -22,7 +22,7 @@
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 @@
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 *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;
--- a/llt/dtypes.h
+++ b/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)