Initial (bad) gc

.clangd

@@ -0,0 +1,15 @@
+CompileFlags:
+  Add: [-std=c11, -Wall, -Wpedantic, -xc, -D_POSIX_C_SOURCE=199309L]
+  Compiler: gcc
+---
+If:
+  PathMatch: .*\.h
+CompileFlags:
+  Remove: -xc
+  Add: [-std=c11, -Wall, -Wpedantic, -xc-header]
+  Compiler: gcc
+---
+If:
+  PathMatch: bin/.*\.c
+CompileFlags:
+  Add: -Isrc

Makefile

@@ -1,7 +1,15 @@
+DEBUG=1
+
+ifeq ($(DEBUG),1)
+DEBUG_CFLAGS=-g
+else
+DEBUG_CFLAGS=-D_NDEBUG
+endif
+
 CC=gcc
-CFLAGS=-g -std=c11 -Wall -Wpedantic
+CFLAGS=$(DEBUG_CFLAGS) -std=c11 -Wall -Wpedantic -D_POSIX_C_SOURCE=199309L
 LD=gcc
-LDFLAGS=-g
+LDFLAGS=
 
 SRCS:=$(wildcard src/*.c)
 OBJS:=$(SRCS:src/%.c=bin/%.o)

src/base.c

@@ -1,7 +1,9 @@
 #include "base.h"
 
+#include "gc.h"
 #include "hashtable.h"
 #include "lisp.h"
+#include "stack.h"
 
 #include <stdio.h>
 #include <string.h>
@@ -17,17 +19,32 @@ const char *LISP_TYPE_NAMES[N_LISP_TYPES] = {
     [TYPE_FUNCTION] = "function",
 };
 
-void *lisp_alloc_object(size_t size, LispValType type) {
+void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
     assert(size >= sizeof(LispObject));
     LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size);
+    memset(obj, 0, size);
     obj->type = type;
     obj->gc.mark = false;
-    obj->gc.has_local_ref = false;
+    tss_create(&obj->gc.has_local_ref, NULL);
-    // TODO set the below
-    obj->gc.entry = NULL;
     return obj;
 }
 
+void *lisp_alloc_object(size_t size, LispValType type) {
+    LispObject *obj = lisp_alloc_object_no_gc(size, type);
+    if (the_stack.depth > 0) {
+        add_local_reference_no_recurse(obj);
+    }
+    lisp_gc_register_object(obj);
+    return obj;
+}
+
+void lisp_release_object(LispVal *val) {
+    assert(OBJECTP(val));
+    LispObject *obj = val;
+    tss_delete(obj->gc.has_local_ref);
+    lisp_free(val);
+}
+
 void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                            const LispValType types[count]) {
     // TODO actually throw an error

src/base.h

@@ -89,14 +89,16 @@ typedef enum {
 } LispValType;
 extern const char *LISP_TYPE_NAMES[N_LISP_TYPES];
 
-#define LISP_OBJECT_ALIGNMENT (1 << LISP_TAG_BITS)
-void *lisp_alloc_object(size_t size, LispValType type);
-
 typedef struct {
     LispValType type;
     ObjectGCInfo gc;
 } LispObject;
 
+#define LISP_OBJECT_ALIGNMENT (1 << LISP_TAG_BITS)
+LispVal *lisp_alloc_object_no_gc(size_t size, LispValType type);
+LispVal *lisp_alloc_object(size_t size, LispValType type);
+void lisp_release_object(LispVal *val);
+
 static ALWAYS_INLINE bool OBJECTP(LispVal *val) {
     return EXTRACT_TAG(val) == LISP_OBJECT_TAG;
 }
@@ -111,15 +113,19 @@ static ALWAYS_INLINE bool OBJECT_MARKED_P(LispVal *val) {
     return ((LispObject *) val)->gc.mark;
 }
 
+// ONLY APPLIES TO THE CALLING THREAD
+static ALWAYS_INLINE bool OBJECT_HAS_LOCAL_REFERENCE_P(LispVal *val) {
+    assert(OBJECTP(val));
+    LispObject *obj = val;
+    return tss_get(obj->gc.has_local_ref);
+}
+
 static ALWAYS_INLINE void SET_OBJECT_HAS_LOCAL_REFERENCE(LispVal *val,
                                                          bool has_local_ref) {
     assert(OBJECTP(val));
-    ((LispObject *) val)->gc.has_local_ref = has_local_ref;
+    LispObject *obj = val;
-}
+    tss_set(obj->gc.has_local_ref,
-
+            (void *) (uintptr_t) (has_local_ref ? 1 : 0));
-static ALWAYS_INLINE bool OBJECT_HAS_LOCAL_REFERENCE_P(LispVal *val) {
-    assert(OBJECTP(val));
-    return ((LispObject *) val)->gc.has_local_ref;
 }
 
 static ALWAYS_INLINE LispValType TYPE_OF(LispVal *val) {
@@ -240,6 +246,7 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
         Q##cname = Fintern(make_lisp_string(internal_Q##cname##_name,     \
                                             internal_Q##cname##_name_len, \
                                             false, false));               \
+        lisp_gc_register_static_object(Q##cname);                         \
     }
 #define REGISTER_GLOBAL_FUNCTION(cname)                                    \
     {                                                                      \

src/function.c

@@ -1,8 +1,10 @@
 #include "function.h"
 
+#include "hashtable.h"
 #include "lisp.h"
 #include "list.h"
 #include "read.h"
+#include "stack.h"
 
 #include <stdio.h>
 #include <stdlib.h>

src/function.h

@@ -77,14 +77,14 @@ void parse_lambda_list(LambdaListParseResult *out, LispVal *list);
 
 // This will cause the program to exit if an error occurs while parsing
 // LISP_ARGS!
-LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(),
+LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
                                const char *lisp_args, size_t args_len,
                                LispVal *docstr);
-#define BUILTIN_FUNCTION_OBJ(cname)                                        \
+#define BUILTIN_FUNCTION_OBJ(cname)                                 \
-    make_builtin_function(                                                 \
+    make_builtin_function(                                          \
-        Q##cname, (LispVal * (*) ()) F##cname, internal_F##cname##_argstr, \
+        Q##cname, (LispVal * (*) (void) ) F##cname,                 \
-        internal_F##cname##_argstr_len,                                    \
+        internal_F##cname##_argstr, internal_F##cname##_argstr_len, \
-        make_lisp_string(internal_F##cname##_docstr,                       \
+        make_lisp_string(internal_F##cname##_docstr,                \
                          internal_F##cname##_docstr_len, false, false))
 
 DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));

src/gc.c

@@ -1,5 +1,365 @@
 #include "gc.h"
 
+#include "function.h"
+#include "hashtable.h"
 #include "lisp.h"
+#include "list.h"
+#include "stack.h"
 
-void lisp_gc_register_object(void *obj) {}
+#include <stdlib.h>
+
+bool lisp_doing_gc;
+struct timespec total_gc_time;
+size_t total_gc_count;
+
+#define GC_OBJECTS_BLOCK_SIZE 128
+struct GCObjectsBlock {
+    LispVal *objs[GC_OBJECTS_BLOCK_SIZE];
+};
+struct GCObjects {
+    size_t num_blocks;
+    size_t num_objs;
+    struct GCObjectsBlock **blocks;
+};
+
+static struct GCObjects gc_objects;
+static struct GCObjects static_objects;
+
+static void init_gc_objects(struct GCObjects *restrict objects) {
+    objects->num_blocks = 0;
+    objects->num_objs = 0;
+    objects->blocks = NULL;
+}
+
+static void gc_objects_register(struct GCObjects *restrict objects,
+                                LispVal *obj) {
+    assert(OBJECTP(obj));
+    if (objects->num_blocks * GC_OBJECTS_BLOCK_SIZE == objects->num_objs) {
+        objects->blocks =
+            lisp_realloc(objects->blocks, sizeof(struct GCObjectsBlock *)
+                                              * ++objects->num_blocks);
+        objects->blocks[objects->num_blocks - 1] =
+            lisp_malloc(sizeof(struct GCObjectsBlock));
+        objects->blocks[objects->num_blocks - 1]->objs[0] = obj;
+    } else {
+        size_t block_idx = objects->num_objs / GC_OBJECTS_BLOCK_SIZE;
+        size_t small_idx = objects->num_objs % GC_OBJECTS_BLOCK_SIZE;
+        objects->blocks[block_idx]->objs[small_idx] = obj;
+    }
+    ++objects->num_objs;
+}
+
+void lisp_init_gc(void) {
+    init_gc_objects(&gc_objects);
+    init_gc_objects(&static_objects);
+}
+
+void lisp_gc_register_object(void *obj) {
+    gc_objects_register(&gc_objects, obj);
+}
+
+// we don't have to put static objects into all_objects because they will never
+// be GCed
+void lisp_gc_register_static_object(void *obj) {
+    gc_objects_register(&static_objects, obj);
+}
+
+void free_object_process_stack(ObjectProcessStack *restrict stack) {
+    for (size_t i = 0; i < stack->num_blocks; ++i) {
+        lisp_free(stack->blocks[i]);
+    }
+    lisp_free(stack->blocks);
+}
+
+// Ensure STACK can hold at least NEW_ENTS more entries
+static void ensure_object_process_stack_size(ObjectProcessStack *restrict stack,
+                                             size_t new_ents) {
+    size_t total_spaces = stack->num_blocks * OBJECT_PROCESS_STACK_BLOCK_SIZE;
+    size_t ents_left = total_spaces - stack->num_objs;
+    if (ents_left < new_ents) {
+        // grow the stack
+        size_t need_to_alloc =
+            (new_ents - ents_left) / OBJECT_PROCESS_STACK_BLOCK_SIZE;
+        if ((new_ents - ents_left) % OBJECT_PROCESS_STACK_BLOCK_SIZE != 0) {
+            ++need_to_alloc;
+        }
+        stack->blocks = lisp_realloc(stack->blocks,
+                                     sizeof(struct ObjectProcessStackBlock *)
+                                         * (stack->num_blocks + need_to_alloc));
+        for (size_t i = 0; i < need_to_alloc; ++i) {
+            stack->blocks[i + stack->num_blocks] =
+                lisp_malloc(sizeof(struct ObjectProcessStackBlock));
+        }
+        stack->num_blocks += need_to_alloc;
+    }
+}
+
+// this does NOT check if there is actually space to push the object, so make
+// sure to expand the stack with the above function before pushing
+static ALWAYS_INLINE void
+add_to_object_process_stack(ObjectProcessStack *restrict stack, void *obj) {
+    if (OBJECTP(obj)) {
+        size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
+        size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
+        stack->blocks[block_idx]->objs[small_idx] = obj;
+        ++stack->num_objs;
+    }
+}
+
+void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
+                                            void *obj) {
+    if (!OBJECTP(obj)) {
+        return;
+    }
+    switch (((LispObject *) obj)->type) {
+    case TYPE_CONS:
+        ensure_object_process_stack_size(stack, 2);
+        add_to_object_process_stack(stack, XCAR(obj));
+        add_to_object_process_stack(stack, XCDR(obj));
+        break;
+    case TYPE_SYMBOL: {
+        LispSymbol *sym = obj;
+        ensure_object_process_stack_size(stack, 4);
+        add_to_object_process_stack(stack, sym->name);
+        add_to_object_process_stack(stack, sym->value);
+        add_to_object_process_stack(stack, sym->function);
+        add_to_object_process_stack(stack, sym->plist);
+        break;
+    }
+    case TYPE_VECTOR: {
+        LispVector *vec = obj;
+        for (size_t i = 0; i < vec->length; ++i) {
+            if (OBJECTP(vec->data[i])) {
+                ensure_object_process_stack_size(stack, 1);
+            }
+            add_to_object_process_stack(stack, vec->data[i]);
+        }
+        break;
+    }
+    case TYPE_FUNCTION: {
+        LispFunction *fobj = obj;
+        ensure_object_process_stack_size(stack, 6);
+        add_to_object_process_stack(stack, fobj->name);
+        add_to_object_process_stack(stack, fobj->docstr);
+        add_to_object_process_stack(stack, fobj->args.req);
+        add_to_object_process_stack(stack, fobj->args.opt);
+        add_to_object_process_stack(stack, fobj->args.kw);
+        add_to_object_process_stack(stack, fobj->args.rest);
+        // TODO when other function types are added, record their held
+        // references
+        break;
+    }
+    case TYPE_HASH_TABLE: {
+        HT_FOREACH_INDEX(obj, i) {
+            if (OBJECTP(HASH_KEY(obj, i)) || OBJECTP(HASH_VALUE(obj, i))) {
+                ensure_object_process_stack_size(stack, 2);
+            }
+            add_to_object_process_stack(stack, HASH_KEY(obj, i));
+            add_to_object_process_stack(stack, HASH_VALUE(obj, i));
+        }
+        break;
+    }
+    case TYPE_STRING:
+        // holds no references break;
+        break;
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    default:
+        abort();
+    }
+}
+
+void *object_process_stack_pop(ObjectProcessStack *restrict stack) {
+    assert(stack->num_objs > 0);
+    --stack->num_objs;
+    size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
+    size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
+    return stack->blocks[block_idx]->objs[small_idx];
+}
+
+void gc_recursively_mark_object(void *obj) {
+    if (!OBJECTP(obj) || OBJECT_MARKED_P(obj)) {
+        return;
+    }
+    SET_OBJECT_MARKED(obj, true);
+    ObjectProcessStack stack;
+    init_object_process_stack(&stack);
+    object_process_stack_push_held_objects(&stack, obj);
+    while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
+        LispVal *top = object_process_stack_pop(&stack);
+        if (!OBJECT_MARKED_P(top)) {
+            SET_OBJECT_MARKED(top, true);
+            object_process_stack_push_held_objects(&stack, top);
+        }
+    }
+    free_object_process_stack(&stack);
+}
+
+// as we never delete static objects, all but the last block of the static
+// objects array is filled
+static void gc_mark_static_roots(void) {
+    for (size_t i = 0; i < static_objects.num_blocks - 1; ++i) {
+        for (size_t j = 0; j < GC_OBJECTS_BLOCK_SIZE; ++j) {
+            gc_recursively_mark_object(static_objects.blocks[i]->objs[j]);
+        }
+    }
+    for (size_t i = 0; i < static_objects.num_objs % GC_OBJECTS_BLOCK_SIZE;
+         ++i) {
+        gc_recursively_mark_object(
+            static_objects.blocks[static_objects.num_blocks - 1]->objs[i]);
+    }
+}
+
+static void gc_mark_stack_local_refs(struct LocalReferences *restrict refs) {
+    size_t full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
+    size_t last_block_len = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH;
+    for (size_t i = 0; i < full_blocks; ++i) {
+        for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
+            gc_recursively_mark_object(refs->blocks[i]->refs[j]);
+        }
+    }
+    for (size_t i = 0; i < last_block_len; ++i) {
+        gc_recursively_mark_object(refs->blocks[full_blocks]->refs[i]);
+    }
+}
+
+static void gc_mark_stack_frame(struct StackFrame *restrict frame) {
+    gc_recursively_mark_object(frame->name);
+    gc_recursively_mark_object(frame->args);
+    gc_recursively_mark_object(frame->lexenv);
+    gc_recursively_mark_object(frame->fobj);
+    gc_mark_stack_local_refs(&frame->local_refs);
+}
+
+static void gc_mark_and_compact_the_stack(void) {
+    size_t i;
+    for (i = 0; i < the_stack.depth; ++i) {
+        gc_mark_stack_frame(&the_stack.frames[i]);
+    }
+    for (; i < the_stack.first_clear_local_refs; ++i) {
+        compact_stack_frame(&the_stack.frames[i]);
+    }
+    the_stack.first_clear_local_refs = the_stack.depth;
+}
+
+static void free_object(LispVal *val) {
+    switch (((LispObject *) val)->type) {
+    case TYPE_HASH_TABLE: {
+        LispHashTable *ht = val;
+        lisp_free(ht->data);
+        break;
+    }
+    case TYPE_STRING: {
+        LispString *str = val;
+        if (str->owned) {
+            lisp_free(str->data);
+        }
+        break;
+    }
+    case TYPE_VECTOR: {
+        LispVector *vec = val;
+        lisp_free(vec->data);
+        break;
+    }
+    case TYPE_CONS:
+    case TYPE_SYMBOL:
+    case TYPE_FUNCTION:
+        // nothing to do
+        break;
+    case TYPE_FIXNUM:
+    case TYPE_FLOAT:
+    default:
+        abort();
+    }
+    lisp_release_object(val);
+}
+
+static ALWAYS_INLINE void do_sweep_object(LispGCStats *restrict stats,
+                                          LispVal *cur_obj,
+                                          size_t *restrict free_block,
+                                          size_t *restrict free_idx) {
+#ifndef _NDEBUG
+    ++stats->total_objects_searched;
+#endif
+    if (!OBJECT_MARKED_P(cur_obj)) {
+        ++stats->total_objects_cleaned;
+        free_object(cur_obj);
+        --gc_objects.num_objs;
+    } else {
+        SET_OBJECT_MARKED(cur_obj, false);
+        gc_objects.blocks[*free_block]->objs[*free_idx] = cur_obj;
+        if (++*free_idx == GC_OBJECTS_BLOCK_SIZE) {
+            ++*free_block;
+            free_idx = 0;
+        }
+    }
+}
+
+static void gc_sweep_objects(LispGCStats *restrict stats) {
+#ifdef _NDEBUG
+    stats->total_objects_searched = gc_objects.num_objs;
+#else
+    stats->total_objects_searched = 0;
+#endif
+    size_t free_block = 0;
+    size_t free_idx = 0;
+    size_t n_full_blocks = gc_objects.num_blocks - 1;
+    size_t small_idx = gc_objects.num_objs % GC_OBJECTS_BLOCK_SIZE;
+    if (small_idx == 0) {
+        ++n_full_blocks;
+    }
+    for (size_t search_block = 0; search_block < n_full_blocks;
+         ++search_block) {
+        for (size_t search_idx = 0; search_idx < GC_OBJECTS_BLOCK_SIZE;
+             ++search_idx) {
+            LispVal *cur_obj =
+                gc_objects.blocks[search_block]->objs[search_idx];
+            do_sweep_object(stats, cur_obj, &free_block, &free_idx);
+        }
+    }
+    for (size_t i = 0; i < small_idx; ++i) {
+        do_sweep_object(stats,
+                        gc_objects.blocks[gc_objects.num_blocks - 1]->objs[i],
+                        &free_block, &free_idx);
+    }
+    // clean up the now empty blocks
+    size_t non_empty_blocks = gc_objects.num_objs / GC_OBJECTS_BLOCK_SIZE;
+    if (gc_objects.num_objs % GC_OBJECTS_BLOCK_SIZE != 0) {
+        ++non_empty_blocks;
+    }
+    for (size_t i = non_empty_blocks; i < gc_objects.num_blocks; ++i) {
+        lisp_free(gc_objects.blocks[i]);
+    }
+    gc_objects.num_blocks = non_empty_blocks;
+    gc_objects.blocks = lisp_realloc(
+        gc_objects.blocks, sizeof(struct GCObjectsBlock *) * non_empty_blocks);
+}
+
+void lisp_gc_now(LispGCStats *restrict stats) {
+    lisp_doing_gc = true;
+    LispGCStats backup_stats;
+    if (!stats) {
+        stats = &backup_stats;
+    }
+    stats->total_objects_cleaned = 0;
+    struct timespec start_time;
+    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &start_time);
+    gc_mark_static_roots();
+    gc_recursively_mark_object(obarray);
+    gc_mark_and_compact_the_stack();
+    gc_sweep_objects(stats);
+    struct timespec end_time;
+    clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &end_time);
+    sub_timespecs(&end_time, &start_time, &stats->ellapsed_time);
+    add_timespecs(&stats->ellapsed_time, &total_gc_time, &total_gc_time);
+    ++total_gc_count;
+    lisp_doing_gc = false;
+}
+
+void debug_print_gc_stats(FILE *stream, const LispGCStats *stats) {
+    fprintf(stream, "Objects Searched: %zu\n", stats->total_objects_searched);
+    fprintf(stream, "Objects Cleaned: %zu\n", stats->total_objects_cleaned);
+    double time = stats->ellapsed_time.tv_sec * 1000
+                  + (stats->ellapsed_time.tv_nsec / 1000000.0);
+    fprintf(stream, "Time Ellapsed (ms): %f\n", time);
+}

src/gc.h

@@ -1,23 +1,67 @@
 #ifndef INCLUDED_GC_H
 #define INCLUDED_GC_H
 
-#include <stddef.h>
+#include "memory.h"
 
-typedef struct GCEntry {
+#include <stddef.h>
-    void *obj;
+#include <stdio.h>
-    struct GCEntry *prev;
+#include <threads.h>
-    struct GCEntry *next;
+
-} GCEntry;
+extern bool lisp_doing_gc;
+extern struct timespec total_gc_time;
+extern size_t total_gc_count;
+
+typedef struct {
+    size_t total_objects_searched;
+    size_t total_objects_cleaned;
+    struct timespec ellapsed_time;
+} LispGCStats;
 
 typedef struct {
     unsigned int mark : 1;
-    unsigned int has_local_ref : 1;
+    tss_t has_local_ref;
-    GCEntry *entry;
 } ObjectGCInfo;
 
+void lisp_init_gc(void);
+
 // the argument is a LispVal *
 void lisp_gc_register_object(void *obj);
+void lisp_gc_register_static_object(void *obj);
 
-size_t lisp_gc_now(void);
+// note that the argument is restrict!
+void lisp_gc_now(LispGCStats *restrict status);
+
+#define OBJECT_PROCESS_STACK_BLOCK_SIZE 64
+struct ObjectProcessStackBlock {
+    void *objs[OBJECT_PROCESS_STACK_BLOCK_SIZE];
+};
+typedef struct {
+    size_t num_blocks;
+    size_t num_objs;
+    struct ObjectProcessStackBlock **blocks;
+} ObjectProcessStack;
+
+static ALWAYS_INLINE bool
+OBJECT_PROCESS_STACK_EMPTY_P(ObjectProcessStack *restrict stack) {
+    return !stack->num_objs;
+}
+
+static ALWAYS_INLINE void
+init_object_process_stack(ObjectProcessStack *restrict stack) {
+    stack->num_blocks = 0;
+    stack->num_objs = 0;
+    stack->blocks = NULL;
+}
+
+void free_object_process_stack(ObjectProcessStack *restrict stack);
+
+void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
+                                            void *obj);
+void *object_process_stack_pop(ObjectProcessStack *restrict stack);
+
+void gc_recursively_mark_object(void *obj);
+
+// Debug
+void debug_print_gc_stats(FILE *stream, const LispGCStats *stats);
 
 #endif

src/hashtable.c

@@ -6,14 +6,28 @@
 #define GROWTH_THRESHOLD 0.5
 #define GROWTH_FACTOR    2
 
-static ALWAYS_INLINE bool BUCKET_EMPTY_P(struct HashTableBucket *b) {
-    return !b->key;
-}
-
 static ALWAYS_INLINE float TABLE_LOAD(LispHashTable *ht) {
     return ((float) ht->count) / ht->size;
 }
 
+LispVal *make_hash_table_no_gc(LispVal *hash_fn, LispVal *eq_fn) {
+    LispHashTable *obj =
+        lisp_alloc_object_no_gc(sizeof(LispHashTable), TYPE_HASH_TABLE);
+    obj->eq_fn = eq_fn;
+    obj->hash_fn = hash_fn;
+    obj->count = 0;
+    obj->size = INITIAL_SIZE;
+    obj->data = lisp_malloc0(sizeof(struct HashTableBucket) * obj->size);
+    return obj;
+}
+
+void release_hash_table_no_gc(LispVal *val) {
+    assert(HASH_TABLE_P(val));
+    LispHashTable *ht = val;
+    lisp_free(ht->data);
+    lisp_free(ht);
+}
+
 DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn),
       "(hash-fn eq-fn)", "") {
     LispHashTable *obj =
@@ -51,7 +65,7 @@ find_bucket_for_key(LispHashTable *ht, LispVal *key, uintptr_t hash) {
     assert(TABLE_LOAD(ht) < 0.95f);
     for (uintptr_t i = hash % ht->size; true; i = (i + 1) % ht->size) {
         struct HashTableBucket *cb = &ht->data[i];
-        if (BUCKET_EMPTY_P(cb)
+        if (HT_BUCKET_EMPTY_P(cb)
             || (cb->hash == hash && compare_keys(ht, key, cb->key))) {
             return cb;
         }
@@ -59,13 +73,14 @@ find_bucket_for_key(LispHashTable *ht, LispVal *key, uintptr_t hash) {
 }
 
 static void rehash(LispHashTable *ht, size_t new_size) {
+    ht->cache_bucket = NULL;
     struct HashTableBucket *old_data = ht->data;
     size_t old_size = ht->size;
     ht->size = new_size;
     ht->data = lisp_malloc0(sizeof(struct HashTableBucket) * new_size);
     for (size_t i = 0; i < old_size; ++i) {
         struct HashTableBucket *cob = &old_data[i];
-        if (!BUCKET_EMPTY_P(cob)) {
+        if (!HT_BUCKET_EMPTY_P(cob)) {
             struct HashTableBucket *nb =
                 find_bucket_for_key(ht, cob->key, cob->hash);
             nb->hash = cob->hash;
@@ -84,37 +99,53 @@ static void maybe_rehash(LispHashTable *ht) {
 // TODO type checking
 DEFUN(gethash, "gethash", (LispVal * ht, LispVal *key, LispVal *def),
       "(ht key &optional def)", "") {
-    uintptr_t hash = hash_key_for_table(ht, key);
+    LispHashTable *obj = ht;
-    struct HashTableBucket *b = find_bucket_for_key(ht, key, hash);
+    if (obj->cache_bucket && key == obj->cache_bucket->key) {
-    return BUCKET_EMPTY_P(b) ? def : b->value;
+        return obj->cache_bucket->value;
+    }
+    uintptr_t hash = hash_key_for_table(obj, key);
+    struct HashTableBucket *b = find_bucket_for_key(obj, key, hash);
+    obj->cache_bucket = b;
+    return HT_BUCKET_EMPTY_P(b) ? def : b->value;
 }
 
 DEFUN(puthash, "puthash", (LispVal * ht, LispVal *key, LispVal *val),
       "(ht key val)", "") {
+    LispHashTable *obj = ht;
+    if (obj->cache_bucket && key == obj->cache_bucket->key) {
+        obj->cache_bucket->value = val;
+        return Qnil;
+    }
     maybe_rehash(ht);
     uintptr_t hash = hash_key_for_table(ht, key);
     struct HashTableBucket *b = find_bucket_for_key(ht, key, hash);
-    if (BUCKET_EMPTY_P(b)) {
+    if (HT_BUCKET_EMPTY_P(b)) {
         b->hash = hash;
         b->key = key;
     }
     b->value = val;
     ++((LispHashTable *) ht)->count;
+    obj->cache_bucket = b;
     return Qnil;
 }
 
 DEFUN(remhash, "remhash", (LispVal * ht, LispVal *key), "(ht key)", "") {
+    LispHashTable *obj = ht;
     uintptr_t hash = hash_key_for_table(ht, key);
-    struct HashTableBucket *b = find_bucket_for_key(ht, key, hash);
+    struct HashTableBucket *b;
-    if (BUCKET_EMPTY_P(b)) {
+    if (obj->cache_bucket && obj->cache_bucket->key == key) {
+        b = obj->cache_bucket;
+    } else {
+        b = find_bucket_for_key(ht, key, hash);
+    }
+    if (HT_BUCKET_EMPTY_P(b)) {
         return Qnil;
     }
     b->key = NULL;
-    b->value = NULL; // just because
     LispHashTable *tobj = ht;
     --tobj->count;
     size_t k = hash % tobj->size;
-    for (size_t i = (k + 1) % tobj->size; !BUCKET_EMPTY_P(&tobj->data[i]);
+    for (size_t i = (k + 1) % tobj->size; !HT_BUCKET_EMPTY_P(&tobj->data[i]);
          i = (i + 1) % tobj->size) {
         size_t target = tobj->data[i].hash % tobj->size;
         if ((i > k && target >= k && target < i)
@@ -123,10 +154,10 @@ DEFUN(remhash, "remhash", (LispVal * ht, LispVal *key), "(ht key)", "") {
             tobj->data[k].key = tobj->data[i].key;
             tobj->data[k].value = tobj->data[i].value;
             tobj->data[i].key = NULL;
-            tobj->data[i].value = NULL;
             k = i;
         }
     }
+    obj->cache_bucket = NULL;
     return Qt;
 }
 

src/hashtable.h

@@ -15,8 +15,14 @@ DEFOBJTYPE(HashTable, HASH_TABLE, HASH_TABLE_P, {
     struct HashTableBucket *data;
     size_t size;
     size_t count;
+
+    struct HashTableBucket *cache_bucket;
 });
 
+// makes no effort to ensure its values are not GCed!!!
+LispVal *make_hash_table_no_gc(LispVal *hash_fn, LispVal *eq_fn);
+void release_hash_table_no_gc(LispVal *val);
+
 DECLARE_FUNCTION(make_hash_table, (LispVal * hash_fn, LispVal *eq_fn));
 DECLARE_FUNCTION(gethash, (LispVal * ht, LispVal *key, LispVal *def));
 DECLARE_FUNCTION(puthash, (LispVal * ht, LispVal *key, LispVal *val));
@@ -28,4 +34,22 @@ static ALWAYS_INLINE size_t HASH_TABLE_COUNT(LispVal *ht) {
     return ((LispHashTable *) ht)->count;
 }
 
+static ALWAYS_INLINE bool HT_BUCKET_EMPTY_P(struct HashTableBucket *b) {
+    return !b->key;
+}
+
+static ALWAYS_INLINE LispVal *HASH_KEY(LispVal *ht, size_t i) {
+    assert(HASH_TABLE_P(ht));
+    return ((LispHashTable *) ht)->data[i].key;
+}
+
+static ALWAYS_INLINE LispVal *HASH_VALUE(LispVal *ht, size_t i) {
+    assert(HASH_TABLE_P(ht));
+    return ((LispHashTable *) ht)->data[i].value;
+}
+
+#define HT_FOREACH_INDEX(ht, i)                               \
+    for (size_t i = 0; i < ((LispHashTable *) ht)->size; ++i) \
+        if (!HT_BUCKET_EMPTY_P(&((LispHashTable *) ht)->data[i]))
+
 #endif

src/lisp.c

@@ -6,23 +6,28 @@
 
 LispVal *obarray;
 
-static void construct_manual_symbols() {
+static void construct_manual_symbols(void) {
     // IMPORTANT: the symbols listed here need to also be set as special in
     // gen-init-globals.awk
     Qnil = Fmake_symbol(LISP_LITSTR("nil"));
     ((LispSymbol *) Qnil)->function = Qnil;
     ((LispSymbol *) Qnil)->plist = Qnil;
+    lisp_gc_register_static_object(Qnil);
     Qt = Fmake_symbol(LISP_LITSTR("t"));
     ((LispSymbol *) Qt)->value = Qt;
+    lisp_gc_register_static_object(Qt);
     Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
     ((LispSymbol *) Qunbound)->value = Qunbound;
     ((LispSymbol *) Qnil)->value = Qunbound;
+    lisp_gc_register_static_object(Qunbound);
 
     Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
+    lisp_gc_register_static_object(Qhash_string);
     Qstrings_equal = Fmake_symbol(LISP_LITSTR("strings-equal"));
+    lisp_gc_register_static_object(Qstrings_equal);
 }
 
-static void register_manual_symbols() {
+static void register_manual_symbols(void) {
 #define INTERN(cname) \
     Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname);
     INTERN(nil);
@@ -33,7 +38,8 @@ static void register_manual_symbols() {
 #undef INTERN
 }
 
-void lisp_init() {
+void lisp_init(void) {
+    lisp_init_gc();
     construct_manual_symbols();
     obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
     // these call Fintern, so they need to have obarray constructed
@@ -47,7 +53,7 @@ void lisp_init() {
     lisp_init_stack();
 }
 
-void lisp_shutdown() {}
+void lisp_shutdown(void) {}
 
 DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
     if (!OBJECTP(form)) {

src/lisp.h

@@ -2,11 +2,11 @@
 #define INCLUDED_LISP_H
 
 #include "base.h"
-#include "function.h"
+#include "function.h" // IWYU pragma: export
-#include "hashtable.h"
+#include "hashtable.h" // IWYU pragma: export
-#include "lisp_string.h"
+#include "lisp_string.h" // IWYU pragma: export
-#include "list.h"
+#include "list.h" // IWYU pragma: export
-#include "stack.h"
+#include "stack.h" // IWYU pragma: export
 
 #include <stdio.h>
 

src/main.c

@@ -13,14 +13,22 @@ DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)",
 }
 
 int main(int argc, const char **argv) {
+    LispGCStats gc_stats;
     lisp_init();
     REGISTER_GLOBAL_FUNCTION(cool_func);
     push_stack_frame(Qnil, Qnil, Qnil);
     ReadStream s;
-    const char BUF[] = "(1 'a)";
+    const char BUF[] = "(cool-func 1 (cons 1 2))";
     read_stream_init(&s, BUF, sizeof(BUF) - 1);
     LispVal *l = read(&s);
-    Ffuncall(Qcool_func, l);
+    Feval(l);
+    push_stack_frame(Qnil, Qnil, Qnil);
+    for (size_t i = 0; i < 100; ++i) {
+        Fcons(MAKE_FIXNUM(0x1234), LISP_LITSTR("a"));
+    }
+    pop_stack_frame();
+    lisp_gc_now(&gc_stats);
+    debug_print_gc_stats(stdout, &gc_stats);
     pop_stack_frame();
     lisp_shutdown();
     return 0;

src/memory.h

@@ -5,13 +5,14 @@
 #include <stdbool.h>
 #include <stdint.h>
 #include <stdlib.h>
+#include <time.h>
 
 // Geneal macros
 #ifndef __has_attribute
 #    define __has_attribute(attr) 0
 #endif
 
-#if __has_attribute(always_inline)
+#if __has_attribute(always_inline) && defined(_NDEBUG)
 #    define ALWAYS_INLINE inline __attribute__((always_inline))
 #else
 #    define ALWAYS_INLINE inline
@@ -95,5 +96,31 @@ void *lisp_realloc(void *oldptr, size_t size);
 void *lisp_malloc(size_t size);
 void *lisp_malloc0(size_t size);
 void *lisp_aligned_alloc(size_t alignment, size_t size);
+#define lisp_free free
+
+// other useful things
+static ALWAYS_INLINE void sub_timespecs(const struct timespec *t1,
+                                        const struct timespec *t2,
+                                        struct timespec *out) {
+    out->tv_sec = t1->tv_sec - t2->tv_sec;
+    int32_t nsec = t1->tv_nsec - t2->tv_nsec;
+    if (nsec < 0) {
+        --out->tv_sec;
+        nsec += 1000000000;
+    }
+    out->tv_nsec = nsec;
+}
+
+static ALWAYS_INLINE void add_timespecs(const struct timespec *t1,
+                                        const struct timespec *t2,
+                                        struct timespec *out) {
+    out->tv_sec = t1->tv_sec + t2->tv_sec;
+    int32_t nsec = t1->tv_nsec + t2->tv_nsec;
+    if (nsec > 1000000000) {
+        ++out->tv_sec;
+        nsec -= 1000000000;
+    }
+    out->tv_nsec = nsec;
+}
 
 #endif

src/stack.c

@@ -1,12 +1,13 @@
 #include "stack.h"
 
+#include "hashtable.h"
 #include "memory.h"
 
 #include <assert.h>
 
 struct LispStack the_stack;
 
-void lisp_init_stack() {
+void lisp_init_stack(void) {
     the_stack.max_depth = DEFAULT_MAX_LISP_EVAL_DEPTH;
     the_stack.depth = 0;
     the_stack.first_clear_local_refs = 0;
@@ -23,13 +24,6 @@ void lisp_init_stack() {
     the_stack.nogc_retval = Qnil;
 }
 
-static ALWAYS_INLINE void init_stack_frame(struct StackFrame *frame,
-                                           LispVal *name, LispVal *args) {
-    frame->name = name;
-    frame->args = args;
-    frame->lexenv = Qnil;
-}
-
 void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
     assert(the_stack.depth < the_stack.max_depth);
     struct StackFrame *frame = &the_stack.frames[the_stack.depth++];
@@ -37,6 +31,7 @@ void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
     frame->fobj = fobj;
     frame->args = args;
     frame->lexenv = Qnil;
+    frame->local_refs.num_refs = 0;
 }
 
 static void reset_local_refs(struct LocalReferences *refs) {
@@ -45,13 +40,11 @@ static void reset_local_refs(struct LocalReferences *refs) {
     for (size_t i = 0; i < num_full_blocks; ++i) {
         for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
             assert(OBJECTP(refs->blocks[i]->refs[j]));
-            // TODO recurse into object
             SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[i]->refs[j], false);
         }
     }
     for (size_t i = 0; i < last_block_size; ++i) {
         assert(OBJECTP(refs->blocks[num_full_blocks]->refs[i]));
-        // TODO recurse into object
         SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[num_full_blocks]->refs[i],
                                        false);
     }
@@ -63,8 +56,7 @@ void pop_stack_frame(void) {
     reset_local_refs(&frame->local_refs);
 }
 
-// return true if we allocated a block
+static void store_local_reference_in_frame(struct StackFrame *frame,
-static bool store_local_reference_in_frame(struct StackFrame *frame,
                                            LispVal *obj) {
     struct LocalReferences *refs = &frame->local_refs;
     size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
@@ -76,21 +68,47 @@ static bool store_local_reference_in_frame(struct StackFrame *frame,
             lisp_malloc(sizeof(struct LocalReferencesBlock));
         refs->blocks[refs->num_blocks - 1]->refs[0] = obj;
         refs->num_refs += 1;
-        return true;
+        the_stack.first_clear_local_refs = the_stack.depth;
     } else {
         refs->blocks[num_full_blocks]
             ->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj;
-        return false;
+    }
+}
+
+void add_local_reference_no_recurse(LispVal *obj) {
+    assert(the_stack.depth > 0);
+    if (OBJECTP(obj) && !OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
+        store_local_reference_in_frame(LISP_STACK_TOP(), obj);
     }
 }
 
 void add_local_reference(LispVal *obj) {
-    assert(the_stack.depth > 0);
+    add_local_reference_no_recurse(obj);
-    if (OBJECTP(obj) && OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
+    LispVal *seen_objs = make_hash_table_no_gc(Qnil, Qnil);
-        if (store_local_reference_in_frame(LISP_STACK_TOP(), obj)) {
+    ObjectProcessStack stack;
-            the_stack.first_clear_local_refs = the_stack.depth;
+    init_object_process_stack(&stack);
+    object_process_stack_push_held_objects(&stack, obj);
+    while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
+        LispVal *top = object_process_stack_pop(&stack);
+        assert(OBJECTP(top));
+        if (!OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
+            store_local_reference_in_frame(LISP_STACK_TOP(), top);
+            SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
+        }
+        if (NILP(Fgethash(seen_objs, obj, Qnil))) {
+            object_process_stack_push_held_objects(&stack, top);
+            Fputhash(seen_objs, obj, Qt);
         }
-        // TODO recurse into object
-        SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
     }
+    free_object_process_stack(&stack);
+    release_hash_table_no_gc(seen_objs);
+}
+
+void compact_stack_frame(struct StackFrame *restrict frame) {
+    struct LocalReferences *restrict refs = &frame->local_refs;
+    for (size_t i = 1; i < refs->num_blocks; ++i) {
+        lisp_free(refs->blocks[i]);
+    }
+    lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *));
+    refs->num_blocks = 1;
 }

src/stack.h

@@ -36,13 +36,17 @@ struct LispStack {
 
 extern struct LispStack the_stack;
 
-static ALWAYS_INLINE struct StackFrame *LISP_STACK_TOP() {
+static ALWAYS_INLINE struct StackFrame *LISP_STACK_TOP(void) {
     return the_stack.depth ? &the_stack.frames[the_stack.depth - 1] : NULL;
 }
 
 void lisp_init_stack(void);
 void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args);
 void pop_stack_frame(void);
+void add_local_reference_no_recurse(LispVal *obj);
 void add_local_reference(LispVal *obj);
 
+// used by the GC
+void compact_stack_frame(struct StackFrame *restrict frame);
+
 #endif