Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix (I hope) reference counting and garbage collecting

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-07-11 02:53:57 +09:00
parent 2d4b963199
commit a38fef7857
4 changed files with 434 additions and 163 deletions
Download Patch File Download Diff File Expand all files Collapse all files

438
src/lisp.c
View File

@ -64,82 +64,16 @@ LispSymbol _Qt = {
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
void _internal_lisp_delete_object(LispVal *val) {
switch (TYPEOF(val)) {
case TYPE_INTEGER:
case TYPE_FLOAT:
lisp_free(val);
break;
case TYPE_STRING: {
LispString *str = (LispString *) val;
if (!str->is_static) {
lisp_free(str->data);
}
lisp_free(val);
} break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) val;
lisp_unref(sym->name);
lisp_unref(sym->plist);
lisp_unref(sym->function);
lisp_unref(sym->value);
lisp_free(val);
} break;
case TYPE_PAIR:
lisp_unref(((LispPair *) val)->head);
lisp_unref(((LispPair *) val)->tail);
lisp_free(val);
break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) val;
for (size_t i = 0; i < vec->length; ++i) {
lisp_unref(vec->data[i]);
}
lisp_free(vec->data);
lisp_free(val);
} break;
case TYPE_FUNCTION: {
LispFunction *fn = (LispFunction *) val;
lisp_unref(fn->doc);
lisp_unref(fn->args);
lisp_unref(fn->rargs);
lisp_unref(fn->oargs);
lisp_unref(fn->rest_arg);
lisp_unref(fn->kwargs);
if (!fn->is_builtin) {
lisp_unref(fn->body);
}
lisp_unref(fn->lexenv);
lisp_free(val);
} break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) val;
for (size_t i = 0; i < tbl->table_size; ++i) {
struct HashtableBucket *cur = tbl->data[i];
while (cur) {
lisp_unref(cur->key);
lisp_unref(cur->value);
struct HashtableBucket *next = cur->next;
lisp_free(cur);
cur = next;
}
}
lisp_free(tbl->data);
lisp_unref(tbl->eq_fn);
lisp_unref(tbl->hash_fn);
lisp_free(val);
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = (LispUserPointer *) val;
if (ptr->free_func) {
ptr->free_func(ptr->data);
}
lisp_free(val);
} break;
default:
abort();
};
}
struct GCRoot {
struct GCRoot *next;
struct GCRoot *prev;
LispVal *object;
};
static struct GCRoot *gc_roots = NULL;
static size_t bytes_allocated = 0;
static size_t last_gc = 0;
static bool is_doing_gc;
void *lisp_malloc(size_t size) {
return lisp_realloc(NULL, size);
@ -149,6 +83,9 @@ void *lisp_realloc(void *old_ptr, size_t size) {
if (!size) {
return NULL;
}
if (!is_doing_gc) {
bytes_allocated += size;
}
void *new_ptr = realloc(old_ptr, size);
if (!new_ptr) {
abort();
@ -156,11 +93,300 @@ void *lisp_realloc(void *old_ptr, size_t size) {
return new_ptr;
}
void *lisp_ref(void *val) {
if (!STATICP(val)) {
++((LispVal *) val)->ref_count;
}
return val;
}
static void track_as_gc_root(LispVal *obj) {
if (!obj->gc_root) {
struct GCRoot *nr = lisp_malloc(sizeof(struct GCRoot));
nr->object = obj;
nr->next = gc_roots;
nr->prev = NULL;
if (gc_roots) {
gc_roots->prev = nr;
}
gc_roots = nr;
obj->gc_root = nr;
}
}
void *lisp_float_ref(void *val) {
if (LISPVAL(val)->ref_count > 0) {
--LISPVAL(val)->ref_count;
}
return val;
}
struct ToCheck {
struct ToCheck *next;
LispVal *obj;
};
#define CHECK(no) \
if (!STATICP(no)) { \
struct ToCheck *new = lisp_malloc(sizeof(struct ToCheck)); \
new->obj = no; \
new->next = queue; \
queue = new; \
}
static struct ToCheck *check_object(LispVal *obj, struct ToCheck *queue) {
switch (TYPEOF(obj)) {
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_STRING:
case TYPE_USER_POINTER:
// can't hold references, do nothing
break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) obj;
CHECK(LISPVAL(sym->name));
CHECK(LISPVAL(sym->function));
CHECK(LISPVAL(sym->value));
CHECK(LISPVAL(sym->plist));
} break;
case TYPE_PAIR:
CHECK(((LispPair *) obj)->head);
CHECK(((LispPair *) obj)->tail);
break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) obj;
for (size_t i = 0; i > vec->length; ++i) {
CHECK(vec->data[i]);
}
} break;
case TYPE_FUNCTION: {
LispFunction *func = (LispFunction *) obj;
CHECK(func->body);
CHECK(func->args);
CHECK(func->doc);
CHECK(func->kwargs);
CHECK(func->oargs);
CHECK(func->rargs);
CHECK(func->lexenv);
CHECK(func->rest_arg);
} break;
case TYPE_HASHTABLE: {
HASHTABLE_FOREACH(key, val, obj, {
CHECK(key);
CHECK(val);
});
} break;
default:
abort();
}
return queue;
}
static void lisp_free_object(LispVal *val, bool is_static) {
struct GCRoot *root = val->gc_root;
if (!STATICP(val) && (root = val->gc_root)) {
if (root->next) {
root->next->prev = root->prev;
}
if (root->prev) {
root->prev->next = root->next;
} else {
gc_roots = gc_roots->next;
if (gc_roots) {
gc_roots->prev = NULL;
}
}
lisp_free(root);
}
switch (TYPEOF(val)) {
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_SYMBOL:
case TYPE_PAIR:
case TYPE_FUNCTION:
break;
case TYPE_STRING: {
LispString *str = (LispString *) val;
if (!str->is_static) {
lisp_free(str->data);
}
} break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) val;
lisp_free(vec->data);
} break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) val;
for (size_t i = 0; i < tbl->table_size; ++i) {
struct HashtableBucket *cur = tbl->data[i];
while (cur) {
struct HashtableBucket *next = cur->next;
lisp_free(cur);
cur = next;
}
}
lisp_free(tbl->data);
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = (LispUserPointer *) val;
if (ptr->free_func) {
ptr->free_func(ptr->data);
}
} break;
default:
abort();
};
if (!is_static) {
lisp_free(val);
}
}
static bool check_gc_root(struct GCRoot *root) {
LispVal *found = make_lisp_hashtable(Qnil, Qnil);
struct ToCheck *queue = NULL;
CHECK(root->object);
size_t num_at_zero = 0;
bool first_pass = true;
while (queue) {
LispVal *obj = queue->obj;
struct ToCheck *next = queue->next;
lisp_free(queue);
queue = next;
LispVal *index = Fgethash(found, obj, Qnil);
if (!NILP(index)) {
if (((LispInteger *) index)->value > 0
&& !--((LispInteger *) index)->value) {
++num_at_zero;
}
// we already searched this object, don't dereference everything
// again!
continue;
} else {
Fputhash(found, obj,
make_lisp_integer(obj->ref_count
&& obj->ref_count - !first_pass));
}
first_pass = false;
queue = check_object(obj, queue);
}
if (num_at_zero == ((LispHashtable *) found)->count) {
LispHashtable *tbl = (LispHashtable *) found;
for (size_t i = 0; i < tbl->count; ++i) {
for (struct HashtableBucket *bucket = tbl->data[i]; bucket;
bucket = bucket->next) {
lisp_free_object(bucket->key, false);
bucket->key = Qnil;
}
}
}
lisp_unref(found);
return false;
}
void garbage_collect() {
if (is_doing_gc) {
return;
}
is_doing_gc = true;
struct GCRoot *root = gc_roots;
while (root) {
if (check_gc_root(root)) {
root = gc_roots;
} else {
root = root->next;
}
}
is_doing_gc = false;
}
struct ToFree {
struct ToFree *next;
LispVal *obj;
};
#define FREE(l, no) \
{ \
struct ToFree *new = lisp_malloc(sizeof(struct ToFree)); \
new->obj = no; \
new->next = l; \
l = new; \
}
static struct ToFree *lisp_unref_recursive(LispVal *val) {
struct ToFree *to_free = NULL;
struct ToCheck *queue = NULL;
CHECK(val);
val->ref_count = 0; // prevent double free
FREE(to_free, val);
while (queue) {
LispVal *obj = queue->obj;
struct ToCheck *next = queue->next;
lisp_free(queue);
queue = next;
if (STATICP(obj) || obj->finalizing) {
continue;
} else if (obj->ref_count >= 2) {
--obj->ref_count;
} else {
if (obj->ref_count) {
--obj->ref_count;
// don't check multiple times
FREE(to_free, obj);
}
obj->finalizing = true;
queue = check_object(obj, queue);
}
}
return to_free;
}
#undef CHECK
#undef FREE
static void *lisp_unref_extended(void *val, bool even_if_static) {
if (!even_if_static && STATICP(val)) {
return val;
} else if (LISPVAL(val)->ref_count > 1) {
--LISPVAL(val)->ref_count;
if (!is_doing_gc) {
track_as_gc_root(val);
}
if (bytes_allocated - last_gc > GC_EVERY_N_BYTES) {
garbage_collect();
last_gc = bytes_allocated;
}
return val;
} else {
struct ToFree *to_free = lisp_unref_recursive(val);
while (to_free) {
LispVal *obj = to_free->obj;
struct ToFree *next = to_free->next;
lisp_free(to_free);
to_free = next;
lisp_free_object(obj, false);
}
return Qnil;
}
}
void *lisp_unref(void *val) {
return lisp_unref_extended(val, false);
}
void lisp_unref_double_ptr(void **val) {
lisp_unref(*val);
}
#define CONSTRUCT_OBJECT(var, Type, TYPE) \
Type *var = lisp_malloc(sizeof(Type)); \
var->type = TYPE; \
var->ref_count = 0; \
var->gc_root = NULL; \
var->finalizing = false;
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static) {
LispString *self = lisp_malloc(sizeof(LispString));
self->type = TYPE_STRING;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispString, TYPE_STRING);
if (take) {
self->data = (char *) data;
} else {
@ -188,9 +414,7 @@ LispVal *sprintf_lisp(const char *format, ...) {
}
LispVal *make_lisp_symbol(LispVal *name) {
LispSymbol *self = lisp_malloc(sizeof(LispSymbol));
self->type = TYPE_SYMBOL;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
self->name = (LispString *) lisp_ref(name);
self->plist = Qnil;
self->function = Qunbound;
@ -200,16 +424,14 @@ LispVal *make_lisp_symbol(LispVal *name) {
}
LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
LispPair *self = lisp_malloc(sizeof(LispPair));
self->type = TYPE_PAIR;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR);
self->head = lisp_ref(head);
self->tail = lisp_ref(tail);
return LISPVAL(self);
}
LispVal *make_lisp_integer(intmax_t value) {
LispInteger *self = lisp_malloc(sizeof(LispInteger));
CONSTRUCT_OBJECT(self, LispInteger, TYPE_INTEGER);
self->type = TYPE_INTEGER;
self->ref_count = 0;
self->value = value;
@ -217,17 +439,13 @@ LispVal *make_lisp_integer(intmax_t value) {
}
LispVal *make_lisp_float(long double value) {
LispFloat *self = lisp_malloc(sizeof(LispFloat));
self->type = TYPE_FLOAT;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispFloat, TYPE_FLOAT);
self->value = value;
return LISPVAL(self);
}
LispVal *make_lisp_vector(LispVal **data, size_t length) {
LispVector *self = lisp_malloc(sizeof(LispVector));
self->type = TYPE_VECTOR;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispVector, TYPE_VECTOR);
self->data = data;
self->length = length;
return LISPVAL(self);
@ -435,9 +653,7 @@ malformed:
LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
LispVal *body, bool is_macro) {
LispFunction *self = lisp_malloc(sizeof(LispFunction));
self->type = TYPE_FUNCTION;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
self->is_builtin = false;
self->is_macro = is_macro;
self->args = Qnil;
@ -457,9 +673,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
}
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
LispHashtable *self = lisp_malloc(sizeof(LispHashtable));
self->type = TYPE_HASHTABLE;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispHashtable, TYPE_HASHTABLE);
self->table_size = LISP_HASHTABLE_INITIAL_SIZE;
self->data =
lisp_malloc(sizeof(struct HashtableBucket *) * self->table_size);
@ -471,9 +685,7 @@ LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
}
LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
LispUserPointer *self = lisp_malloc(sizeof(LispUserPointer));
self->type = TYPE_USER_POINTER;
self->ref_count = 0;
CONSTRUCT_OBJECT(self, LispUserPointer, TYPE_USER_POINTER);
self->data = data;
self->free_func = free_func;
return LISPVAL(self);
@ -906,6 +1118,15 @@ DEF_STATIC_SYMBOL(circular_error, "circular-error");
DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error");
struct StaticReference *static_references = NULL;
void add_static_reference(LispVal *obj) {
struct StaticReference *sr = lisp_malloc(sizeof(struct StaticReference));
sr->next = static_references;
sr->obj = obj;
static_references = sr;
}
LispVal *Vobarray = Qnil;
void lisp_init() {
@ -941,7 +1162,7 @@ void lisp_init() {
if, "(cond then &rest else)",
"Evaluate THEN if COND is non-nil, otherwise evaluate ELSE.");
REGISTER_FUNCTION(
setq, "(&rest args)",
setq, "(var val)",
"Set each of a number of variables to their respective values.");
REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
@ -951,10 +1172,21 @@ void lisp_init() {
REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR");
REGISTER_FUNCTION(read, "(source)",
"Read and return the next s-expr from SOURCE.");
REGISTER_FUNCTION(eq, "(obj1 obj2)",
"Return non-nil if OBJ1 and OBJ2 are equal");
}
void lisp_shutdown() {
while (static_references) {
struct StaticReference *next = static_references->next;
lisp_unref_extended(static_references->obj, false);
lisp_free(static_references);
static_references = next;
}
UNREF_INPLACE(Vobarray);
garbage_collect();
}
void register_static_function(LispVal *func) {}
@ -1523,7 +1755,7 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
fputc(']', stream);
} break;
case TYPE_FUNCTION:
if (((LispFunction *) obj)->builtin) {
if (((LispFunction *) obj)->is_builtin) {
fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj);
} else {
fprintf(stream, "<function at %#jx>", (uintmax_t) obj);

59
src/lisp.h
View File

@ -41,7 +41,9 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
#define LISP_OBJECT_HEADER \
LispType type; \
ptrdiff_t ref_count;
void *gc_root; \
ptrdiff_t ref_count; \
bool finalizing;
typedef struct {
LISP_OBJECT_HEADER;
@ -270,7 +272,7 @@ inline static bool NUMBERP(LispVal *v) {
{ \
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \
for (size_t __hashtable_foreach_i = 0; \
__hashtable_foreach_i < __hashtable_foreach_table->count; \
__hashtable_foreach_i < __hashtable_foreach_table->table_size; \
++__hashtable_foreach_i) { \
struct HashtableBucket *__hashtable_foreach_cur = \
__hashtable_foreach_table->data[__hashtable_foreach_i]; \
@ -292,43 +294,21 @@ inline static bool NUMBERP(LispVal *v) {
// #############################
// # Allocation and references #
// #############################
#define GC_EVERY_N_BYTES 1024 * 80
void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size);
#define lisp_free free
inline static void *lisp_ref(void *val) {
if (!STATICP(val)) {
++((LispVal *) val)->ref_count;
}
return val;
}
inline static void *lisp_float_ref(void *val) {
if (LISPVAL(val)->ref_count > 0) {
--LISPVAL(val)->ref_count;
}
return val;
}
void _internal_lisp_delete_object(LispVal *val);
inline static void *lisp_unref(void *val) {
if (STATICP(val)) {
return val;
} else if (LISPVAL(val)->ref_count > 1) {
--LISPVAL(val)->ref_count;
return val;
} else {
_internal_lisp_delete_object(val);
return Qnil;
}
}
void *lisp_ref(void *val);
void *lisp_float_ref(void *val);
void garbage_collect();
void *lisp_unref(void *val);
#define UNREF_INPLACE(variable) \
{ \
variable = lisp_unref(variable); \
}
inline static void lisp_unref_double_ptr(void **val) {
lisp_unref(*val);
}
void lisp_unref_double_ptr(void **val);
#define IGNORE_REF(val) (lisp_unref(lisp_ref(val)))
// ################
@ -481,10 +461,22 @@ extern LispVal *Qargument_error;
Fthrow(Qtype_error, Qnil); \
}
struct StaticReference {
struct StaticReference *next;
LispVal *obj;
};
extern struct StaticReference *static_references;
void add_static_reference(LispVal *obj);
extern LispVal *Vobarray;
#define REGISTER_SYMBOL(sym) \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym)
#define REGISTER_SYMBOL(sym) \
{ \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym); \
add_static_reference(Q##sym); \
}
#define REGISTER_STATIC_FUNCTION(obj, args, docstr) \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
{ \
@ -492,6 +484,7 @@ extern LispVal *Vobarray;
lisp_ref(src); \
set_function_args((LispFunction *) (obj), Fread(src)); \
lisp_unref(src); \
add_static_reference(obj); \
}
#define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_SYMBOL(fn); \

98
src/main.c
View File

@ -88,30 +88,76 @@ int main(int argc, const char **argv) {
REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", "");
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", "");
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
LispVal *err_var = INTERN_STATIC("err-var");
Fputhash(
the_stack->handlers, Qt,
// simply call the above function
const_list(3, err_var, Ftoplevel_error_handler_function, err_var));
Fputhash(
the_stack->handlers, Qshutdown_signal,
// simply call the above function
const_list(3, err_var, Ftoplevel_exit_handler_function, err_var));
Fputhash(the_stack->handlers, Qeof_error,
// ignore
Fpair(Qnil, Qnil));
while (pos < file_len) {
LispVal *tv;
WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, {
pos += read_from_buffer(buffer + pos, file_len - pos, &tv);
});
WITH_CLEANUP(tv, {
IGNORE_REF(Feval(tv)); //
})
}
});
lisp_shutdown();
return exit_status;
// WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
// the_stack->hidden = true;
// LispVal *err_var = INTERN_STATIC("err-var");
// Fputhash(
// the_stack->handlers, Qt,
// // simply call the above function
// const_list(3, err_var, Ftoplevel_error_handler_function,
// err_var));
// Fputhash(
// the_stack->handlers, Qshutdown_signal,
// // simply call the above function
// const_list(3, err_var, Ftoplevel_exit_handler_function,
// err_var));
// Fputhash(the_stack->handlers, Qeof_error,
// // ignore
// Fpair(Qnil, Qnil));
// while (pos < file_len) {
// LispVal *tv;
// WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, {
// pos += read_from_buffer(buffer + pos, file_len - pos, &tv);
// });
// WITH_CLEANUP(tv, {
// IGNORE_REF(Feval(tv)); //
// });
// }
// });
stack_enter(Qtoplevel, (((LispVal *) (&_Qnil))), 0);
if (_setjmp(the_stack->start) == 0) {
{
the_stack->hidden = 1;
LispVal *err_var =
(_internal_INTERN_STATIC(("err-var"), sizeof("err-var") - 1));
Fputhash(
the_stack->handlers, (((LispVal *) (&_Qt))),
const_list(3, err_var,
((LispVal *) (&_Ftoplevel_error_handler_function)),
err_var));
Fputhash(
the_stack->handlers, Qshutdown_signal,
const_list(3, err_var,
((LispVal *) (&_Ftoplevel_exit_handler_function)),
err_var));
Fputhash(the_stack->handlers, Qeof_error,
Fpair((((LispVal *) (&_Qnil))), (((LispVal *) (&_Qnil)))));
while (pos < file_len) {
LispVal *tv;
stack_enter(Qtoplevel_read, (((LispVal *) (&_Qnil))), 0);
if (_setjmp(the_stack->start) == 0) {
{
pos +=
read_from_buffer(buffer + pos, file_len - pos, &tv);
}
}
stack_leave();
;
lisp_ref(tv);
{
void *__with_cleanup_cleanup = register_cleanup(
(lisp_cleanup_func_t) &lisp_unref_double_ptr, &(tv));
{{(lisp_unref(lisp_ref(Feval(tv))));
}
};
cancel_cleanup(__with_cleanup_cleanup);
lisp_unref(tv);
};
}
}
}
stack_leave();
;
lisp_shutdown();
return exit_status;
}

2
src/read.c
View File

@ -79,8 +79,8 @@ static LispVal *read_list(struct ReadState *state) {
int c;
while ((c = peekc(state)) != ')') {
if (c == EOS) {
EOF_ERROR(state);
UNREF_INPLACE(list);
EOF_ERROR(state);
return Qnil;
}
LispVal *elt = read_internal(state);