gc and cons pairs

gc.c

@@ -0,0 +1,138 @@
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "inttypes.h"
+#include "stdlib.h"
+#include "wscm.h"
+
+E heap;
+
+#define ALIGN(n) (((n) + 7) & ~7)
+#define INFROM(x)                                                              \
+  (((const U8 *)x) >= heap.from.start && ((const U8 *)x) < heap.from.end)
+
+// roots management
+void addroot(O *ptr) {
+  if (heap.root_count >= heap.root_capacity) {
+    Z cap = heap.root_capacity == 0 ? 16 : heap.root_capacity * 2;
+    O **roots = realloc(heap.roots, cap * sizeof(O *));
+    if (!roots)
+      abort();
+    heap.roots = roots;
+    heap.root_capacity = cap;
+  }
+  heap.roots[heap.root_count++] = ptr;
+}
+
+I rootmark(void) { return heap.root_count; }
+void rootreset(I mark) { heap.root_count = mark; }
+
+// garbage collection
+static O copy(H *obj, U8 **freep) {
+  assert(INFROM(obj));
+  assert(obj->type != OBJ_FWD);
+
+  Z sz = ALIGN(obj->size);
+  H *new = (H *)*freep;
+  *freep += sz;
+  memcpy(new, obj, sz);
+  obj->type = OBJ_FWD;
+  O *o = (O *)(obj + 1);
+  *o = BOX(new);
+  return *o;
+}
+
+static O forward(O obj, U8 **freep) {
+  if (obj == NIL)
+    return NIL;
+  if (IMM(obj))
+    return obj;
+
+  H *h = UNBOX(obj);
+  if (!INFROM(h))
+    return obj;
+
+  if (h->type == OBJ_FWD) {
+    O *o = (O *)(h + 1);
+    return *o;
+  } else {
+    return copy(h, freep);
+  }
+}
+
+void collect(void) {
+  U8 *freep = heap.to.start;
+  U8 *scan = freep;
+
+  for (I i = 0; i < heap.root_count; i++) {
+    O *o = heap.roots[i];
+    *o = forward(*o, &freep);
+  }
+
+  while (scan < freep) {
+    H *h = (H *)scan;
+    switch (h->type) {
+    case OBJ_CONS: {
+      C *c = (C *)(h + 1);
+      c->head = forward(c->head, &freep);
+      c->tail = forward(c->tail, &freep);
+      break;
+    }
+    case OBJ_SYM:
+      break;
+    case OBJ_FWD:
+      fprintf(stderr, "gc internal error: forwarding pointer in to-space\n");
+      abort();
+    default:
+      fprintf(stderr, "gc internal error: junk object type %" PRIdPTR "\n",
+              h->type);
+      abort();
+    }
+    scan += ALIGN(h->size);
+  }
+
+  U8 *tmp_start, *tmp_end;
+  tmp_start = heap.from.start;
+  tmp_end = heap.from.end;
+
+  heap.from = heap.to;
+  heap.from.free = freep;
+
+  heap.to.start = tmp_start;
+  heap.to.end = tmp_end;
+  heap.to.free = tmp_start;
+}
+
+// allocation
+H *alloc(Z sz) {
+  sz = ALIGN(sz);
+  if (heap.from.free + sz > heap.from.end) {
+    collect();
+    if (heap.from.free + sz > heap.from.end) {
+      fprintf(stderr, "out of memory (requested %zu bytes)\n", sz);
+      abort();
+    }
+  }
+  H *p = (H *)heap.from.free;
+  heap.from.free += sz;
+  p->size = sz;
+  return p;
+}
+
+void gcinit(void) {
+  heap.from.start = malloc(GC_HEAP_BYTES);
+  if (!heap.from.start) abort();
+  heap.from.free = heap.from.start;
+  heap.from.end = heap.from.start + GC_HEAP_BYTES;
+
+  heap.to.start = malloc(GC_HEAP_BYTES);
+  if (!heap.to.start) abort();
+  heap.to.free = heap.to.start;
+  heap.to.end = heap.to.start + GC_HEAP_BYTES;
+}
+
+void gcfinalize(void) {
+  free(heap.from.start);
+  free(heap.to.start);
+}