txr-011 2009-09-25txr-011

1 files changed, 368 insertions, 0 deletions

diff --git a/gc.c b/gc.c
new file mode 100644
index 00000000..2b98887b
--- /dev/null
+++ b/gc.c
@@ -0,0 +1,368 @@
+/* Copyright 2009
+ * Kaz Kylheku <kkylheku@gmail.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ *   1. Redistributions of source code must retain the above copyright
+ *      notice, this list of conditions and the following disclaimer.
+ *   2. Redistributions in binary form must reproduce the above copyright
+ *      notice, this list of conditions and the following disclaimer in
+ *      the documentation and/or other materials provided with the
+ *      distribution.
+ *   3. The name of the author may not be used to endorse or promote
+ *      products derived from this software without specific prior
+ *      written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <setjmp.h>
+#include <dirent.h>
+#include "lib.h"
+#include "gc.h"
+
+#define PROT_STACK_SIZE         1024
+#define HEAP_SIZE               16384
+#define REACHABLE               0x100
+#define FREE                    0x200
+
+typedef struct heap {
+  struct heap *next;
+  obj_t block[HEAP_SIZE];
+} heap_t;
+
+int opt_gc_debug;
+obj_t **gc_stack_top;
+
+static obj_t **prot_stack[PROT_STACK_SIZE];
+static obj_t ***prot_stack_limit = prot_stack + PROT_STACK_SIZE;
+static obj_t ***top = prot_stack;
+
+static obj_t *free_list, **free_tail = &free_list;
+static heap_t *heap_list;
+
+int gc_enabled = 1;
+
+obj_t *prot1(obj_t **loc)
+{
+  assert (top < prot_stack_limit);
+  *top++ = loc;
+  return nil; /* for use in macros */
+}
+
+void rel1(obj_t **loc)
+{
+  /* protect and release calls must nest. */
+  if (*--top != loc)
+    abort();
+}
+
+void protect(obj_t **first, ...)
+{
+  obj_t **next = first;
+  va_list vl;
+  va_start (vl, first);
+
+  while (next) {
+    prot1(next);
+    next = va_arg(vl, obj_t **);
+  }
+
+  va_end (vl);
+}
+
+void release(obj_t **last, ...)
+{
+  obj_t **next = last;
+  va_list vl;
+  va_start (vl, last);
+
+  while (next) {
+    rel1(next);
+    next = va_arg(vl, obj_t **);
+  }
+
+  va_end (vl);
+}
+
+static void more()
+{
+  heap_t *heap = (heap_t *) chk_malloc(sizeof *heap);
+  obj_t *block = heap->block, *end = heap->block + HEAP_SIZE;
+
+  while (block < end) {
+    block->t.next = free_list;
+    block->t.type = FREE;
+    free_list = block++;
+  }
+
+  free_tail = &block[-1].t.next;
+
+  heap->next = heap_list;
+  heap_list = heap;
+}
+
+obj_t *make_obj(void)
+{
+  int try;
+
+  if (opt_gc_debug)
+    gc();
+
+  for (try = 0; try < 3; try++) {
+    if (free_list) {
+      obj_t *ret = free_list;
+      free_list = free_list->t.next;
+      return ret;
+    }
+
+    free_tail = &free_list;
+
+    switch (try) {
+    case 0: gc(); break;
+    case 1: more(); break;
+    }
+  }
+
+  return 0;
+}
+
+static void finalize(obj_t *obj)
+{
+  switch (obj->t.type) {
+  case CONS:
+    break;
+  case STR:
+    if (!opt_gc_debug) {
+      free(obj->st.str);
+      obj->st.str = 0;
+    }
+    break;
+  case CHR:
+  case NUM:
+  case SYM:
+  case FUN:
+    break;
+  case VEC:
+    if (!opt_gc_debug) {
+      free(obj->v.vec-2);
+      obj->v.vec = 0;
+    }
+    break;
+  case STREAM:
+    stream_close(obj);
+    break;
+  case LCONS:
+    break;
+  case COBJ:
+    obj->co.ops->destroy(obj);
+    break;
+  default:
+    assert (0 && "corrupt type field");
+  }
+}
+
+static void mark_obj(obj_t *obj)
+{
+  type_t t;
+
+  if (obj == nil)
+    return;
+
+  t = obj->t.type;
+
+  if ((t & REACHABLE) != 0)
+    return;
+
+  if ((t & FREE) != 0)
+    abort();
+
+  obj->t.type |= REACHABLE;
+
+  switch (t) {
+  case CONS:
+    mark_obj(obj->c.car);
+    mark_obj(obj->c.cdr);
+    break;
+  case STR:
+    mark_obj(obj->st.len);
+    break;
+  case CHR:
+  case NUM:
+    break;
+  case SYM:
+    mark_obj(obj->s.name);
+    mark_obj(obj->s.val);
+    break;
+  case FUN:
+    mark_obj(obj->f.env);
+    if (obj->f.functype == FINTERP)
+      mark_obj(obj->f.f.interp_fun);
+    break;
+  case VEC:
+    {
+      obj_t *alloc_size = obj->v.vec[-2];
+      obj_t *fill_ptr = obj->v.vec[-1];
+      long i, fp = c_num(fill_ptr);
+
+      mark_obj(alloc_size);
+      mark_obj(fill_ptr);
+
+      for (i = 0; i < fp; i++)
+        mark_obj(obj->v.vec[i]);
+    }
+    break;
+  case STREAM:
+    mark_obj(obj->sm.label_pushback);
+    break;
+  case LCONS:
+    mark_obj(obj->lc.car);
+    mark_obj(obj->lc.cdr);
+    mark_obj(obj->lc.func);
+    break;
+  case COBJ:
+    mark_obj(obj->co.cls);
+    break;
+  default:
+    assert (0 && "corrupt type field");
+  }
+}
+
+static int in_heap(obj_t *ptr)
+{
+  heap_t *heap;
+
+  for (heap = heap_list; heap != 0; heap = heap->next) {
+    if (ptr >= heap->block && ptr < heap->block + HEAP_SIZE)
+      if (((char *) ptr - (char *) heap->block) % sizeof (obj_t) == 0)
+        return 1;
+  }
+
+  return 0;
+}
+
+static void mark_mem_region(obj_t **bottom, obj_t **top)
+{
+  if (bottom > top) {
+    obj_t **tmp = top;
+    top = bottom;
+    bottom = tmp;
+  }
+
+  while (bottom < top) {
+    obj_t *maybe_obj = *bottom;
+    if (in_heap(maybe_obj)) {
+      type_t t = maybe_obj->t.type;
+      if ((t & FREE) == 0)
+        mark_obj(maybe_obj);
+    }
+    bottom++;
+  }
+}
+
+static void mark(void)
+{
+  obj_t *gc_stack_bottom;
+  obj_t ***rootloc;
+
+  /*
+   * First, scan the officially registered locations.
+   */
+
+  for (rootloc = prot_stack; rootloc != top; rootloc++) {
+    if (*rootloc) /* stack may have nulls */
+      mark_obj(**rootloc);
+  }
+
+  mark_mem_region(&gc_stack_bottom, gc_stack_top);
+}
+
+static void sweep(void)
+{
+  heap_t *heap;
+  int dbg = opt_gc_debug;
+  long freed = 0;
+
+  for (heap = heap_list; heap != 0; heap = heap->next) {
+    obj_t *block, *end;
+    for (block = heap->block, end = heap->block + HEAP_SIZE;
+         block < end;
+         block++)
+    {
+      if (block->t.type & REACHABLE) {
+        block->t.type &= ~REACHABLE;
+        continue;
+      }
+
+      if (block->t.type & FREE)
+        continue;
+
+      if (0 && dbg) {
+        fprintf(stderr, "%s: finalizing: ", progname);
+        obj_print(block, stderr);
+        putc('\n', stderr);
+      }
+      finalize(block);
+      block->t.type |= FREE;
+      if (dbg) {
+        *free_tail = block;
+        block->t.next = nil;
+        free_tail = &block->t.next;
+      } else {
+        block->t.next = free_list;
+        free_list = block;
+      }
+      freed++;
+    }
+  }
+
+  if (dbg)
+    fprintf(stderr, "%s: gc freed %ld blocks\n", progname, freed);
+}
+
+void gc(void)
+{
+  if (gc_enabled) {
+    jmp_buf jmp;
+    setjmp(jmp);
+    mark();
+    sweep();
+  }
+}
+
+int gc_state(int enabled)
+{
+  int old = gc_enabled;
+  gc_enabled = enabled;
+  return old;
+}
+
+/*
+ * Useful functions for gdb'ing.
+ */
+void unmark(void)
+{
+  heap_t *heap;
+
+  for (heap = heap_list; heap != 0; heap = heap->next) {
+    obj_t *block, *end;
+    for (block = heap->block, end = heap->block + HEAP_SIZE;
+         block < end;
+         block++)
+    {
+      block->t.type &= ~(FREE | REACHABLE);
+    }
+  }
+}