use aligned allocating so that finding objct's heap_page is O(1)

extlib/benz/gc.c

@@ -1,770 +1,7 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
 #include "picrin.h"
-#include "picrin/private/object.h"
-#include "picrin/private/khash.h"
-#include "picrin/private/state.h"
 
-enum {
+#ifdef PIC_USE_BITMAPGC
-  WHITE = 0,
+# include "./gc/bitmap.c"
-  BLACK = 1
+#else
-};
+# include "./gc/markandsweep.c"
-
-union header {
-  struct {
-    union header *ptr;
-    size_t size;
-  } s;
-};
-
-#define BITMAP_SIZE                                                     \
-  (PIC_HEAP_PAGE_SIZE / sizeof(union header)) / (sizeof(uint32_t) * CHAR_BIT)
-
-struct heap_page {
-  union header *basep, *endp;
-  uint32_t bitmap[BITMAP_SIZE];
-  struct heap_page *next;
-};
-
-struct object {
-  union {
-    struct basic basic;
-    struct identifier id;
-    struct string str;
-    struct blob blob;
-    struct pair pair;
-    struct vector vec;
-    struct dict dict;
-    struct weak weak;
-    struct data data;
-    struct record rec;
-    struct env env;
-    struct proc proc;
-    struct context cxt;
-    struct port port;
-    struct error err;
-    struct checkpoint cp;
-  } u;
-};
-
-struct heap {
-  union header base, *freep;
-  struct heap_page *pages;
-  struct weak *weaks;       /* weak map chain */
-};
-
-struct heap *
-pic_heap_open(pic_state *pic)
-{
-  struct heap *heap;
-
-  heap = pic_malloc(pic, sizeof(struct heap));
-
-  heap->base.s.ptr = &heap->base;
-  heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
-
-  heap->freep = &heap->base;
-  heap->pages = NULL;
-
-  heap->weaks = NULL;
-
-  return heap;
-}
-
-void
-pic_heap_close(pic_state *pic, struct heap *heap)
-{
-  struct heap_page *page;
-
-  while (heap->pages) {
-    page = heap->pages;
-    heap->pages = heap->pages->next;
-    pic_free(pic, page->basep);
-    pic_free(pic, page);
-  }
-  pic_free(pic, heap);
-}
-
-#if PIC_USE_LIBC
-void *
-pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size)
-{
-  if (size != 0) {
-    return realloc(ptr, size);
-  }
-  free(ptr);
-  return NULL;
-}
 #endif
-
-void *
-pic_malloc(pic_state *pic, size_t size)
-{
-  void *ptr;
-
-  ptr = pic->allocf(pic->userdata, NULL, size);
-  if (ptr == NULL && size > 0) {
-    pic_panic(pic, "memory exhausted");
-  }
-  return ptr;
-}
-
-void *
-pic_realloc(pic_state *pic, void *ptr, size_t size)
-{
-  ptr = pic->allocf(pic->userdata, ptr, size);
-  if (ptr == NULL && size > 0) {
-    pic_panic(pic, "memory exhausted");
-  }
-  return ptr;
-}
-
-void *
-pic_calloc(pic_state *pic, size_t count, size_t size)
-{
-  void *ptr;
-
-  size *= count;
-  ptr = pic->allocf(pic->userdata, NULL, size);
-  if (ptr == NULL && size > 0) {
-    pic_panic(pic, "memory exhausted");
-  }
-  memset(ptr, 0, size);
-  return ptr;
-}
-
-void
-pic_free(pic_state *pic, void *ptr)
-{
-  pic->allocf(pic->userdata, ptr, 0);
-}
-
-static void
-gc_protect(pic_state *pic, struct object *obj)
-{
-  if (pic->arena_idx >= pic->arena_size) {
-    pic->arena_size = pic->arena_size * 2 + 1;
-    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
-  }
-  pic->arena[pic->arena_idx++] = obj;
-}
-
-pic_value
-pic_protect(pic_state *pic, pic_value v)
-{
-  if (! pic_obj_p(pic, v))
-    return v;
-
-  gc_protect(pic, pic_obj_ptr(v));
-
-  return v;
-}
-
-size_t
-pic_enter(pic_state *pic)
-{
-  return pic->arena_idx;
-}
-
-void
-pic_leave(pic_state *pic, size_t state)
-{
-  pic->arena_idx = state;
-}
-
-static void *
-heap_alloc(pic_state *pic, size_t size)
-{
-  union header *p, *prevp;
-  size_t nunits;
-
-  assert(size > 0);
-
-  nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
-
-  prevp = pic->heap->freep;
-  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
-    if (p->s.size >= nunits)
-      break;
-    if (p == pic->heap->freep) {
-      return NULL;
-    }
-  }
-
-  if (p->s.size == nunits) {
-    prevp->s.ptr = p->s.ptr;
-  }
-  else {
-    p->s.size -= nunits;
-    p += p->s.size;
-    p->s.size = nunits;
-  }
-  pic->heap->freep = prevp;
-
-  return (void *)(p + 1);
-}
-
-static void
-heap_free(pic_state *pic, void *ap)
-{
-  union header *bp, *p;
-
-  assert(ap != NULL);
-
-  bp = (union header *)ap - 1;
-
-  for (p = pic->heap->freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
-    if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
-      break;
-    }
-  }
-  if (bp + bp->s.size == p->s.ptr && p->s.ptr->s.size > 0) { /* don't melt base header */
-    bp->s.size += p->s.ptr->s.size;
-    bp->s.ptr = p->s.ptr->s.ptr;
-  } else {
-    bp->s.ptr = p->s.ptr;
-  }
-  if (p + p->s.size == bp && bp->s.size > 0) { /* don't melt base header */
-    p->s.size += bp->s.size;
-    p->s.ptr = bp->s.ptr;
-  } else {
-    p->s.ptr = bp;
-  }
-  pic->heap->freep = p;
-}
-
-static void
-heap_morecore(pic_state *pic)
-{
-  union header *bp, *np;
-  struct heap_page *page;
-  size_t nunits;
-
-  nunits = PIC_HEAP_PAGE_SIZE / sizeof(union header);
-
-  assert(nunits >= 2);
-
-  bp = pic_malloc(pic, PIC_HEAP_PAGE_SIZE);
-  bp->s.size = 0;               /* bp is never used for allocation */
-  heap_free(pic, bp + 1);
-
-  np = bp + 1;
-  np->s.size = nunits - 1;
-  heap_free(pic, np + 1);
-
-  page = pic_malloc(pic, sizeof(struct heap_page));
-  page->basep = bp;
-  page->endp = bp + nunits;
-  page->next = pic->heap->pages;
-
-  pic->heap->pages = page;
-}
-
-/* bitmap */
-
-static struct heap_page *
-obj2page(pic_state *pic, union header *h)
-{
-  struct heap_page *page;
-
-  page = pic->heap->pages;
-  while (page) {
-    if (page->basep <= h && h < page->endp)
-      return page;
-    page = page->next;
-  }
-  PIC_UNREACHABLE();
-}
-
-static bool
-is_marked(pic_state *pic, struct object *obj)
-{
-  union header *h = ((union header *)obj) - 1;
-  struct heap_page *page;
-  size_t i, unit_size = sizeof(uint32_t) * CHAR_BIT;
-
-  page = obj2page(pic, h);
-
-  i = h - page->basep;
-
-  return page->bitmap[i / unit_size] & (1 << (i % unit_size));
-}
-
-static void
-mark(pic_state *pic, struct object *obj)
-{
-  union header *h = ((union header *)obj) - 1;
-  struct heap_page *page;
-  size_t i, unit_size = sizeof(uint32_t) * CHAR_BIT;
-
-  page = obj2page(pic, h);
-
-  i = h - page->basep;
-
-  page->bitmap[i / unit_size] |= (1 << (i % unit_size));
-}
-
-/* MARK */
-
-static void gc_mark_object(pic_state *, struct object *);
-
-static void
-gc_mark(pic_state *pic, pic_value v)
-{
-  if (! pic_obj_p(pic, v))
-    return;
-
-  gc_mark_object(pic, pic_obj_ptr(v));
-}
-
-static void
-gc_mark_object(pic_state *pic, struct object *obj)
-{
- loop:
-
-  if (is_marked(pic, obj))
-    return;
-
-  mark(pic, obj);
-
-#define LOOP(o) obj = (struct object *)(o); goto loop
-
-  switch (obj->u.basic.tt) {
-  case PIC_TYPE_PAIR: {
-    gc_mark(pic, obj->u.pair.car);
-    if (pic_obj_p(pic, obj->u.pair.cdr)) {
-      LOOP(pic_obj_ptr(obj->u.pair.cdr));
-    }
-    break;
-  }
-  case PIC_TYPE_CXT: {
-    int i;
-
-    for (i = 0; i < obj->u.cxt.regc; ++i) {
-      gc_mark(pic, obj->u.cxt.regs[i]);
-    }
-    if (obj->u.cxt.up) {
-      LOOP(obj->u.cxt.up);
-    }
-    break;
-  }
-  case PIC_TYPE_FUNC: {
-    int i;
-    for (i = 0; i < obj->u.proc.u.f.localc; ++i) {
-      gc_mark(pic, obj->u.proc.locals[i]);
-    }
-    break;
-  }
-  case PIC_TYPE_IREP: {
-    if (obj->u.proc.u.i.cxt) {
-      LOOP(obj->u.proc.u.i.cxt);
-    }
-    break;
-  }
-  case PIC_TYPE_PORT: {
-    break;
-  }
-  case PIC_TYPE_ERROR: {
-    gc_mark_object(pic, (struct object *)obj->u.err.type);
-    gc_mark_object(pic, (struct object *)obj->u.err.msg);
-    gc_mark(pic, obj->u.err.irrs);
-    LOOP(obj->u.err.stack);
-    break;
-  }
-  case PIC_TYPE_STRING: {
-    break;
-  }
-  case PIC_TYPE_VECTOR: {
-    int i;
-    for (i = 0; i < obj->u.vec.len; ++i) {
-      gc_mark(pic, obj->u.vec.data[i]);
-    }
-    break;
-  }
-  case PIC_TYPE_BLOB: {
-    break;
-  }
-  case PIC_TYPE_ID: {
-    gc_mark_object(pic, (struct object *)obj->u.id.u.id);
-    LOOP(obj->u.id.env);
-    break;
-  }
-  case PIC_TYPE_ENV: {
-    khash_t(env) *h = &obj->u.env.map;
-    int it;
-
-    for (it = kh_begin(h); it != kh_end(h); ++it) {
-      if (kh_exist(h, it)) {
-        gc_mark_object(pic, (struct object *)kh_key(h, it));
-        gc_mark_object(pic, (struct object *)kh_val(h, it));
-      }
-    }
-    if (obj->u.env.up) {
-      LOOP(obj->u.env.up);
-    }
-    break;
-  }
-  case PIC_TYPE_DATA: {
-    if (obj->u.data.type->mark) {
-      obj->u.data.type->mark(pic, obj->u.data.data, gc_mark);
-    }
-    break;
-  }
-  case PIC_TYPE_DICT: {
-    pic_value key, val;
-    int it = 0;
-
-    while (pic_dict_next(pic, pic_obj_value(&obj->u.dict), &it, &key, &val)) {
-      gc_mark(pic, key);
-      gc_mark(pic, val);
-    }
-    break;
-  }
-  case PIC_TYPE_RECORD: {
-    gc_mark(pic, obj->u.rec.type);
-    if (pic_obj_p(pic, obj->u.rec.datum)) {
-      LOOP(pic_obj_ptr(obj->u.rec.datum));
-    }
-    break;
-  }
-  case PIC_TYPE_SYMBOL: {
-    LOOP(obj->u.id.u.str);
-    break;
-  }
-  case PIC_TYPE_WEAK: {
-    struct weak *weak = (struct weak *)obj;
-
-    weak->prev = pic->heap->weaks;
-    pic->heap->weaks = weak;
-    break;
-  }
-  case PIC_TYPE_CP: {
-    if (obj->u.cp.prev) {
-      gc_mark_object(pic, (struct object *)obj->u.cp.prev);
-    }
-    if (obj->u.cp.in) {
-      gc_mark_object(pic, (struct object *)obj->u.cp.in);
-    }
-    if (obj->u.cp.out) {
-      LOOP((struct object *)obj->u.cp.out);
-    }
-    break;
-  }
-  default:
-    PIC_UNREACHABLE();
-  }
-}
-
-static void
-gc_mark_phase(pic_state *pic)
-{
-  pic_value *stack;
-  struct callinfo *ci;
-  struct list_head *list;
-  int it;
-  size_t j;
-
-  assert(pic->heap->weaks == NULL);
-
-  /* checkpoint */
-  if (pic->cp) {
-    gc_mark_object(pic, (struct object *)pic->cp);
-  }
-
-  /* stack */
-  for (stack = pic->stbase; stack != pic->sp; ++stack) {
-    gc_mark(pic, *stack);
-  }
-
-  /* callinfo */
-  for (ci = pic->ci; ci != pic->cibase; --ci) {
-    if (ci->cxt) {
-      gc_mark_object(pic, (struct object *)ci->cxt);
-    }
-  }
-
-  /* arena */
-  for (j = 0; j < pic->arena_idx; ++j) {
-    gc_mark_object(pic, (struct object *)pic->arena[j]);
-  }
-
-  /* ireps */
-  for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
-    struct irep *irep = (struct irep *)list;
-    for (j = 0; j < irep->npool; ++j) {
-      gc_mark_object(pic, irep->pool[j]);
-    }
-  }
-
-  /* global variables */
-  gc_mark(pic, pic->globals);
-
-  /* macro objects */
-  gc_mark(pic, pic->macros);
-
-  /* error object */
-  gc_mark(pic, pic->err);
-
-  /* features */
-  gc_mark(pic, pic->features);
-
-  /* library table */
-  for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
-    if (! kh_exist(&pic->ltable, it)) {
-      continue;
-    }
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name);
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env);
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports);
-  }
-
-  /* weak maps */
-  do {
-    struct object *key;
-    pic_value val;
-    int it;
-    khash_t(weak) *h;
-    struct weak *weak;
-
-    j = 0;
-    weak = pic->heap->weaks;
-
-    while (weak != NULL) {
-      h = &weak->hash;
-      for (it = kh_begin(h); it != kh_end(h); ++it) {
-        if (! kh_exist(h, it))
-          continue;
-        key = kh_key(h, it);
-        val = kh_val(h, it);
-        if (is_marked(pic, key)) {
-          if (pic_obj_p(pic, val) && ! is_marked(pic, pic_obj_ptr(val))) {
-            gc_mark(pic, val);
-            ++j;
-          }
-        }
-      }
-      weak = weak->prev;
-    }
-  } while (j > 0);
-}
-
-/* SWEEP */
-
-static void
-gc_finalize_object(pic_state *pic, struct object *obj)
-{
-  switch (obj->u.basic.tt) {
-  case PIC_TYPE_VECTOR: {
-    pic_free(pic, obj->u.vec.data);
-    break;
-  }
-  case PIC_TYPE_BLOB: {
-    pic_free(pic, obj->u.blob.data);
-    break;
-  }
-  case PIC_TYPE_STRING: {
-    pic_rope_decref(pic, obj->u.str.rope);
-    break;
-  }
-  case PIC_TYPE_ENV: {
-    kh_destroy(env, &obj->u.env.map);
-    break;
-  }
-  case PIC_TYPE_DATA: {
-    if (obj->u.data.type->dtor) {
-      obj->u.data.type->dtor(pic, obj->u.data.data);
-    }
-    break;
-  }
-  case PIC_TYPE_DICT: {
-    kh_destroy(dict, &obj->u.dict.hash);
-    break;
-  }
-  case PIC_TYPE_SYMBOL: {
-    /* TODO: remove this symbol's entry from pic->syms immediately */
-    break;
-  }
-  case PIC_TYPE_WEAK: {
-    kh_destroy(weak, &obj->u.weak.hash);
-    break;
-  }
-  case PIC_TYPE_IREP: {
-    pic_irep_decref(pic, obj->u.proc.u.i.irep);
-    break;
-  }
-
-  case PIC_TYPE_PAIR:
-  case PIC_TYPE_CXT:
-  case PIC_TYPE_PORT:
-  case PIC_TYPE_ERROR:
-  case PIC_TYPE_ID:
-  case PIC_TYPE_RECORD:
-  case PIC_TYPE_CP:
-  case PIC_TYPE_FUNC:
-    break;
-
-  default:
-    PIC_UNREACHABLE();
-  }
-}
-
-static size_t
-gc_sweep_page(pic_state *pic, struct heap_page *page)
-{
-  union header *bp, *p, *head = NULL, *tail = NULL;
-  struct object *obj;
-  size_t alive = 0;
-
-  for (bp = page->basep; ; bp = bp->s.ptr) {
-    p = bp + (bp->s.size ? bp->s.size : 1); /* first bp's size is 0, so force advnce */
-    for (; p != bp->s.ptr; p += p->s.size) {
-      if (p < page->basep || page->endp <= p) {
-        goto escape;
-      }
-      obj = (struct object *)(p + 1);
-      if (is_marked(pic, obj)) {
-        alive += p->s.size;
-      } else {
-        if (head == NULL) {
-          head = p;
-        }
-        if (tail != NULL) {
-          tail->s.ptr = p;
-        }
-        tail = p;
-        tail->s.ptr = NULL; /* We can safely reuse ptr field of dead object */
-      }
-    }
-  }
- escape:
-
-  /* free! */
-  while (head != NULL) {
-    p = head;
-    head = head->s.ptr;
-    gc_finalize_object(pic, (struct object *)(p + 1));
-    heap_free(pic, p + 1);
-  }
-
-  return alive;
-}
-
-static void
-gc_sweep_phase(pic_state *pic)
-{
-  struct heap_page *page;
-  int it;
-  khash_t(weak) *h;
-  khash_t(oblist) *s = &pic->oblist;
-  symbol *sym;
-  struct object *obj;
-  size_t total = 0, inuse = 0;
-
-  /* weak maps */
-  while (pic->heap->weaks != NULL) {
-    h = &pic->heap->weaks->hash;
-    for (it = kh_begin(h); it != kh_end(h); ++it) {
-      if (! kh_exist(h, it))
-        continue;
-      obj = kh_key(h, it);
-      if (! is_marked(pic, obj)) {
-        kh_del(weak, h, it);
-      }
-    }
-    pic->heap->weaks = pic->heap->weaks->prev;
-  }
-
-  /* symbol table */
-  for (it = kh_begin(s); it != kh_end(s); ++it) {
-    if (! kh_exist(s, it))
-      continue;
-    sym = kh_val(s, it);
-    if (! is_marked(pic, (struct object *)sym)) {
-      kh_del(oblist, s, it);
-    }
-  }
-
-  page = pic->heap->pages;
-  while (page) {
-    inuse += gc_sweep_page(pic, page);
-    total += page->endp - page->basep;
-    page = page->next;
-  }
-
-  if (PIC_PAGE_REQUEST_THRESHOLD(total) <= inuse) {
-    heap_morecore(pic);
-  }
-}
-
-void
-gc_init(pic_state *pic)
-{
-  struct heap_page *page;
-
-  page = pic->heap->pages;
-  while (page) {
-    /* clear mark bits */
-    memset(page->bitmap, 0, sizeof(page->bitmap));
-    page = page->next;
-  }
-}
-
-void
-pic_gc(pic_state *pic)
-{
-  if (! pic->gc_enable) {
-    return;
-  }
-
-  gc_init(pic);
-
-  gc_mark_phase(pic);
-  gc_sweep_phase(pic);
-}
-
-void *
-pic_alloca(pic_state *pic, size_t n)
-{
-  static const pic_data_type t = { "pic_alloca", pic_free, 0 };
-
-  /* TODO: optimize */
-  return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
-}
-
-struct object *
-pic_obj_alloc_unsafe(pic_state *pic, size_t size, int type)
-{
-  struct object *obj;
-
-#if GC_STRESS
-  pic_gc(pic);
-#endif
-
-  obj = (struct object *)heap_alloc(pic, size);
-  if (obj == NULL) {
-    pic_gc(pic);
-    obj = (struct object *)heap_alloc(pic, size);
-    if (obj == NULL) {
-      heap_morecore(pic);
-      obj = (struct object *)heap_alloc(pic, size);
-      if (obj == NULL)
-	pic_panic(pic, "GC memory exhausted");
-    }
-  }
-  obj->u.basic.tt = type;
-
-  return obj;
-}
-
-struct object *
-pic_obj_alloc(pic_state *pic, size_t size, int type)
-{
-  struct object *obj;
-
-  obj = pic_obj_alloc_unsafe(pic, size, type);
-
-  gc_protect(pic, obj);
-  return obj;
-}

extlib/benz/gc/bitmap.c

@@ -0,0 +1,766 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/private/object.h"
+#include "picrin/private/khash.h"
+#include "picrin/private/state.h"
+
+enum {
+  WHITE = 0,
+  BLACK = 1
+};
+
+union header {
+  struct {
+    union header *ptr;
+    size_t size;
+  } s;
+};
+
+#define BITMAP_SIZE                                                     \
+  (PIC_HEAP_PAGE_SIZE / sizeof(union header)) / (sizeof(uint32_t) * CHAR_BIT)
+
+
+struct heap_page {
+  union header *basep, *endp;
+  struct heap_page *next;
+  uint32_t bitmap[BITMAP_SIZE];
+};
+
+struct object {
+  union {
+    struct basic basic;
+    struct identifier id;
+    struct string str;
+    struct blob blob;
+    struct pair pair;
+    struct vector vec;
+    struct dict dict;
+    struct weak weak;
+    struct data data;
+    struct record rec;
+    struct env env;
+    struct proc proc;
+    struct context cxt;
+    struct port port;
+    struct error err;
+    struct checkpoint cp;
+  } u;
+};
+
+struct heap {
+  union header base, *freep;
+  struct heap_page *pages;
+  struct weak *weaks;       /* weak map chain */
+};
+
+struct heap *
+pic_heap_open(pic_state *pic)
+{
+  struct heap *heap;
+
+  heap = pic_malloc(pic, sizeof(struct heap));
+
+  heap->base.s.ptr = &heap->base;
+  heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
+
+  heap->freep = &heap->base;
+  heap->pages = NULL;
+
+  heap->weaks = NULL;
+
+  return heap;
+}
+
+void
+pic_heap_close(pic_state *pic, struct heap *heap)
+{
+  struct heap_page *page;
+
+  while (heap->pages) {
+    page = heap->pages;
+    heap->pages = heap->pages->next;
+    pic_free(pic, page);
+  }
+  pic_free(pic, heap);
+}
+
+#if PIC_USE_LIBC
+void *
+pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size)
+{
+  if (size != 0) {
+    return realloc(ptr, size);
+  }
+  free(ptr);
+  return NULL;
+}
+#endif
+
+void *
+pic_malloc(pic_state *pic, size_t size)
+{
+  void *ptr;
+
+  ptr = pic->allocf(pic->userdata, NULL, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  return ptr;
+}
+
+void *
+pic_realloc(pic_state *pic, void *ptr, size_t size)
+{
+  ptr = pic->allocf(pic->userdata, ptr, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  return ptr;
+}
+
+void *
+pic_calloc(pic_state *pic, size_t count, size_t size)
+{
+  void *ptr;
+
+  size *= count;
+  ptr = pic->allocf(pic->userdata, NULL, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  memset(ptr, 0, size);
+  return ptr;
+}
+
+void
+pic_free(pic_state *pic, void *ptr)
+{
+  pic->allocf(pic->userdata, ptr, 0);
+}
+
+static void
+gc_protect(pic_state *pic, struct object *obj)
+{
+  if (pic->arena_idx >= pic->arena_size) {
+    pic->arena_size = pic->arena_size * 2 + 1;
+    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
+  }
+  pic->arena[pic->arena_idx++] = obj;
+}
+
+pic_value
+pic_protect(pic_state *pic, pic_value v)
+{
+  if (! pic_obj_p(pic, v))
+    return v;
+
+  gc_protect(pic, pic_obj_ptr(v));
+
+  return v;
+}
+
+size_t
+pic_enter(pic_state *pic)
+{
+  return pic->arena_idx;
+}
+
+void
+pic_leave(pic_state *pic, size_t state)
+{
+  pic->arena_idx = state;
+}
+
+static void *
+heap_alloc(pic_state *pic, size_t size)
+{
+  union header *p, *prevp;
+  size_t nunits;
+
+  assert(size > 0);
+
+  nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
+
+  prevp = pic->heap->freep;
+  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
+    if (p->s.size >= nunits)
+      break;
+    if (p == pic->heap->freep) {
+      return NULL;
+    }
+  }
+
+  if (p->s.size == nunits) {
+    prevp->s.ptr = p->s.ptr;
+  }
+  else {
+    p->s.size -= nunits;
+    p += p->s.size;
+    p->s.size = nunits;
+  }
+  pic->heap->freep = prevp;
+
+  return (void *)(p + 1);
+}
+
+static void
+heap_free(pic_state *pic, void *ap)
+{
+  union header *bp, *p;
+
+  assert(ap != NULL);
+
+  bp = (union header *)ap - 1;
+
+  for (p = pic->heap->freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
+    if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
+      break;
+    }
+  }
+  if (bp + bp->s.size == p->s.ptr && p->s.ptr->s.size > 0) { /* don't melt base header */
+    bp->s.size += p->s.ptr->s.size;
+    bp->s.ptr = p->s.ptr->s.ptr;
+  } else {
+    bp->s.ptr = p->s.ptr;
+  }
+  if (p + p->s.size == bp && bp->s.size > 0) { /* don't melt base header */
+    p->s.size += bp->s.size;
+    p->s.ptr = bp->s.ptr;
+  } else {
+    p->s.ptr = bp;
+  }
+  pic->heap->freep = p;
+}
+
+static void
+heap_morecore(pic_state *pic)
+{
+  union header *bp, *np;
+  struct heap_page *page;
+  size_t nunits;
+
+  nunits = (PIC_HEAP_PAGE_SIZE - sizeof(struct heap_page)) / sizeof(union header);
+
+  assert(nunits >= 2);
+
+  if(PIC_MEMALIGN(pic, (void **)&page, PIC_HEAP_PAGE_SIZE, PIC_HEAP_PAGE_SIZE) != 0)
+    pic_panic(pic, "memory exhausted");
+
+  bp = (union header*)(page + 1);
+  bp->s.size = 0;               /* bp is never used for allocation */
+  heap_free(pic, bp + 1);
+
+  np = bp + 1;
+  np->s.size = nunits - 1;
+  heap_free(pic, np + 1);
+
+  page->basep = bp;
+  page->endp = bp + nunits;
+  page->next = pic->heap->pages;
+
+  pic->heap->pages = page;
+}
+
+/* bitmap */
+
+struct heap_page *
+obj2page(pic_state *PIC_UNUSED(pic), union header *h)
+{
+  unsigned long int mask = ~(PIC_HEAP_PAGE_SIZE - 1);
+
+  return (struct heap_page *)(((unsigned long int) h) & mask);
+}
+
+static bool
+is_marked(pic_state *pic, struct object *obj)
+{
+  union header *h = ((union header *)obj) - 1;
+  struct heap_page *page;
+  size_t i, unit_size = sizeof(uint32_t) * CHAR_BIT;
+
+  page = obj2page(pic, h);
+
+  i = h - page->basep;
+
+  return page->bitmap[i / unit_size] & (1 << (i % unit_size));
+}
+
+static void
+mark(pic_state *pic, struct object *obj)
+{
+  union header *h = ((union header *)obj) - 1;
+  struct heap_page *page;
+  size_t i, unit_size = sizeof(uint32_t) * CHAR_BIT;
+
+  page = obj2page(pic, h);
+
+  i = h - page->basep;
+
+  page->bitmap[i / unit_size] |= (1 << (i % unit_size));
+}
+
+/* MARK */
+
+static void gc_mark_object(pic_state *, struct object *);
+
+static void
+gc_mark(pic_state *pic, pic_value v)
+{
+  if (! pic_obj_p(pic, v))
+    return;
+
+  gc_mark_object(pic, pic_obj_ptr(v));
+}
+
+static void
+gc_mark_object(pic_state *pic, struct object *obj)
+{
+ loop:
+
+  if (is_marked(pic, obj))
+    return;
+
+  mark(pic, obj);
+
+#define LOOP(o) obj = (struct object *)(o); goto loop
+
+  switch (obj->u.basic.tt) {
+  case PIC_TYPE_PAIR: {
+    gc_mark(pic, obj->u.pair.car);
+    if (pic_obj_p(pic, obj->u.pair.cdr)) {
+      LOOP(pic_obj_ptr(obj->u.pair.cdr));
+    }
+    break;
+  }
+  case PIC_TYPE_CXT: {
+    int i;
+
+    for (i = 0; i < obj->u.cxt.regc; ++i) {
+      gc_mark(pic, obj->u.cxt.regs[i]);
+    }
+    if (obj->u.cxt.up) {
+      LOOP(obj->u.cxt.up);
+    }
+    break;
+  }
+  case PIC_TYPE_FUNC: {
+    int i;
+    for (i = 0; i < obj->u.proc.u.f.localc; ++i) {
+      gc_mark(pic, obj->u.proc.locals[i]);
+    }
+    break;
+  }
+  case PIC_TYPE_IREP: {
+    if (obj->u.proc.u.i.cxt) {
+      LOOP(obj->u.proc.u.i.cxt);
+    }
+    break;
+  }
+  case PIC_TYPE_PORT: {
+    break;
+  }
+  case PIC_TYPE_ERROR: {
+    gc_mark_object(pic, (struct object *)obj->u.err.type);
+    gc_mark_object(pic, (struct object *)obj->u.err.msg);
+    gc_mark(pic, obj->u.err.irrs);
+    LOOP(obj->u.err.stack);
+    break;
+  }
+  case PIC_TYPE_STRING: {
+    break;
+  }
+  case PIC_TYPE_VECTOR: {
+    int i;
+    for (i = 0; i < obj->u.vec.len; ++i) {
+      gc_mark(pic, obj->u.vec.data[i]);
+    }
+    break;
+  }
+  case PIC_TYPE_BLOB: {
+    break;
+  }
+  case PIC_TYPE_ID: {
+    gc_mark_object(pic, (struct object *)obj->u.id.u.id);
+    LOOP(obj->u.id.env);
+    break;
+  }
+  case PIC_TYPE_ENV: {
+    khash_t(env) *h = &obj->u.env.map;
+    int it;
+
+    for (it = kh_begin(h); it != kh_end(h); ++it) {
+      if (kh_exist(h, it)) {
+        gc_mark_object(pic, (struct object *)kh_key(h, it));
+        gc_mark_object(pic, (struct object *)kh_val(h, it));
+      }
+    }
+    if (obj->u.env.up) {
+      LOOP(obj->u.env.up);
+    }
+    break;
+  }
+  case PIC_TYPE_DATA: {
+    if (obj->u.data.type->mark) {
+      obj->u.data.type->mark(pic, obj->u.data.data, gc_mark);
+    }
+    break;
+  }
+  case PIC_TYPE_DICT: {
+    pic_value key, val;
+    int it = 0;
+
+    while (pic_dict_next(pic, pic_obj_value(&obj->u.dict), &it, &key, &val)) {
+      gc_mark(pic, key);
+      gc_mark(pic, val);
+    }
+    break;
+  }
+  case PIC_TYPE_RECORD: {
+    gc_mark(pic, obj->u.rec.type);
+    if (pic_obj_p(pic, obj->u.rec.datum)) {
+      LOOP(pic_obj_ptr(obj->u.rec.datum));
+    }
+    break;
+  }
+  case PIC_TYPE_SYMBOL: {
+    LOOP(obj->u.id.u.str);
+    break;
+  }
+  case PIC_TYPE_WEAK: {
+    struct weak *weak = (struct weak *)obj;
+
+    weak->prev = pic->heap->weaks;
+    pic->heap->weaks = weak;
+    break;
+  }
+  case PIC_TYPE_CP: {
+    if (obj->u.cp.prev) {
+      gc_mark_object(pic, (struct object *)obj->u.cp.prev);
+    }
+    if (obj->u.cp.in) {
+      gc_mark_object(pic, (struct object *)obj->u.cp.in);
+    }
+    if (obj->u.cp.out) {
+      LOOP((struct object *)obj->u.cp.out);
+    }
+    break;
+  }
+  default:
+    PIC_UNREACHABLE();
+  }
+}
+
+static void
+gc_mark_phase(pic_state *pic)
+{
+  pic_value *stack;
+  struct callinfo *ci;
+  struct list_head *list;
+  int it;
+  size_t j;
+
+  assert(pic->heap->weaks == NULL);
+
+  /* checkpoint */
+  if (pic->cp) {
+    gc_mark_object(pic, (struct object *)pic->cp);
+  }
+
+  /* stack */
+  for (stack = pic->stbase; stack != pic->sp; ++stack) {
+    gc_mark(pic, *stack);
+  }
+
+  /* callinfo */
+  for (ci = pic->ci; ci != pic->cibase; --ci) {
+    if (ci->cxt) {
+      gc_mark_object(pic, (struct object *)ci->cxt);
+    }
+  }
+
+  /* arena */
+  for (j = 0; j < pic->arena_idx; ++j) {
+    gc_mark_object(pic, (struct object *)pic->arena[j]);
+  }
+
+  /* ireps */
+  for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
+    struct irep *irep = (struct irep *)list;
+    for (j = 0; j < irep->npool; ++j) {
+      gc_mark_object(pic, irep->pool[j]);
+    }
+  }
+
+  /* global variables */
+  gc_mark(pic, pic->globals);
+
+  /* macro objects */
+  gc_mark(pic, pic->macros);
+
+  /* error object */
+  gc_mark(pic, pic->err);
+
+  /* features */
+  gc_mark(pic, pic->features);
+
+  /* library table */
+  for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
+    if (! kh_exist(&pic->ltable, it)) {
+      continue;
+    }
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name);
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env);
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports);
+  }
+
+  /* weak maps */
+  do {
+    struct object *key;
+    pic_value val;
+    int it;
+    khash_t(weak) *h;
+    struct weak *weak;
+
+    j = 0;
+    weak = pic->heap->weaks;
+
+    while (weak != NULL) {
+      h = &weak->hash;
+      for (it = kh_begin(h); it != kh_end(h); ++it) {
+        if (! kh_exist(h, it))
+          continue;
+        key = kh_key(h, it);
+        val = kh_val(h, it);
+        if (is_marked(pic, key)) {
+          if (pic_obj_p(pic, val) && ! is_marked(pic, pic_obj_ptr(val))) {
+            gc_mark(pic, val);
+            ++j;
+          }
+        }
+      }
+      weak = weak->prev;
+    }
+  } while (j > 0);
+}
+
+/* SWEEP */
+
+static void
+gc_finalize_object(pic_state *pic, struct object *obj)
+{
+  switch (obj->u.basic.tt) {
+  case PIC_TYPE_VECTOR: {
+    pic_free(pic, obj->u.vec.data);
+    break;
+  }
+  case PIC_TYPE_BLOB: {
+    pic_free(pic, obj->u.blob.data);
+    break;
+  }
+  case PIC_TYPE_STRING: {
+    pic_rope_decref(pic, obj->u.str.rope);
+    break;
+  }
+  case PIC_TYPE_ENV: {
+    kh_destroy(env, &obj->u.env.map);
+    break;
+  }
+  case PIC_TYPE_DATA: {
+    if (obj->u.data.type->dtor) {
+      obj->u.data.type->dtor(pic, obj->u.data.data);
+    }
+    break;
+  }
+  case PIC_TYPE_DICT: {
+    kh_destroy(dict, &obj->u.dict.hash);
+    break;
+  }
+  case PIC_TYPE_SYMBOL: {
+    /* TODO: remove this symbol's entry from pic->syms immediately */
+    break;
+  }
+  case PIC_TYPE_WEAK: {
+    kh_destroy(weak, &obj->u.weak.hash);
+    break;
+  }
+  case PIC_TYPE_IREP: {
+    pic_irep_decref(pic, obj->u.proc.u.i.irep);
+    break;
+  }
+
+  case PIC_TYPE_PAIR:
+  case PIC_TYPE_CXT:
+  case PIC_TYPE_PORT:
+  case PIC_TYPE_ERROR:
+  case PIC_TYPE_ID:
+  case PIC_TYPE_RECORD:
+  case PIC_TYPE_CP:
+  case PIC_TYPE_FUNC:
+    break;
+
+  default:
+    PIC_UNREACHABLE();
+  }
+}
+
+static size_t
+gc_sweep_page(pic_state *pic, struct heap_page *page)
+{
+  union header *bp, *p, *head = NULL, *tail = NULL;
+  struct object *obj;
+  size_t alive = 0;
+
+  for (bp = page->basep; ; bp = bp->s.ptr) {
+    p = bp + (bp->s.size ? bp->s.size : 1); /* first bp's size is 0, so force advnce */
+    for (; p != bp->s.ptr; p += p->s.size) {
+      if (p < page->basep || page->endp <= p) {
+        goto escape;
+      }
+      obj = (struct object *)(p + 1);
+      if (is_marked(pic, obj)) {
+        alive += p->s.size;
+      } else {
+        if (head == NULL) {
+          head = p;
+        }
+        if (tail != NULL) {
+          tail->s.ptr = p;
+        }
+        tail = p;
+        tail->s.ptr = NULL; /* We can safely reuse ptr field of dead object */
+      }
+    }
+  }
+ escape:
+
+  /* free! */
+  while (head != NULL) {
+    p = head;
+    head = head->s.ptr;
+    gc_finalize_object(pic, (struct object *)(p + 1));
+    heap_free(pic, p + 1);
+  }
+
+  return alive;
+}
+
+static void
+gc_sweep_phase(pic_state *pic)
+{
+  struct heap_page *page;
+  int it;
+  khash_t(weak) *h;
+  khash_t(oblist) *s = &pic->oblist;
+  symbol *sym;
+  struct object *obj;
+  size_t total = 0, inuse = 0;
+
+  /* weak maps */
+  while (pic->heap->weaks != NULL) {
+    h = &pic->heap->weaks->hash;
+    for (it = kh_begin(h); it != kh_end(h); ++it) {
+      if (! kh_exist(h, it))
+        continue;
+      obj = kh_key(h, it);
+      if (! is_marked(pic, obj)) {
+        kh_del(weak, h, it);
+      }
+    }
+    pic->heap->weaks = pic->heap->weaks->prev;
+  }
+
+  /* symbol table */
+  for (it = kh_begin(s); it != kh_end(s); ++it) {
+    if (! kh_exist(s, it))
+      continue;
+    sym = kh_val(s, it);
+    if (! is_marked(pic, (struct object *)sym)) {
+      kh_del(oblist, s, it);
+    }
+  }
+
+  page = pic->heap->pages;
+  while (page) {
+    inuse += gc_sweep_page(pic, page);
+    total += page->endp - page->basep;
+    page = page->next;
+  }
+
+  if (PIC_PAGE_REQUEST_THRESHOLD(total) <= inuse) {
+    heap_morecore(pic);
+  }
+}
+
+void
+gc_init(pic_state *pic)
+{
+  struct heap_page *page;
+
+  page = pic->heap->pages;
+  while (page) {
+    /* clear mark bits */
+    memset(page->bitmap, 0, sizeof(page->bitmap));
+    page = page->next;
+  }
+}
+
+void
+pic_gc(pic_state *pic)
+{
+  if (! pic->gc_enable) {
+    return;
+  }
+
+  gc_init(pic);
+
+  gc_mark_phase(pic);
+  gc_sweep_phase(pic);
+}
+
+void *
+pic_alloca(pic_state *pic, size_t n)
+{
+  static const pic_data_type t = { "pic_alloca", pic_free, 0 };
+
+  /* TODO: optimize */
+  return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
+}
+
+struct object *
+pic_obj_alloc_unsafe(pic_state *pic, size_t size, int type)
+{
+  struct object *obj;
+
+#if GC_STRESS
+  pic_gc(pic);
+#endif
+
+  obj = (struct object *)heap_alloc(pic, size);
+  if (obj == NULL) {
+    pic_gc(pic);
+    obj = (struct object *)heap_alloc(pic, size);
+    if (obj == NULL) {
+      heap_morecore(pic);
+      obj = (struct object *)heap_alloc(pic, size);
+      if (obj == NULL)
+	pic_panic(pic, "GC memory exhausted");
+    }
+  }
+  obj->u.basic.tt = type;
+
+  return obj;
+}
+
+struct object *
+pic_obj_alloc(pic_state *pic, size_t size, int type)
+{
+  struct object *obj;
+
+  obj = pic_obj_alloc_unsafe(pic, size, type);
+
+  gc_protect(pic, obj);
+  return obj;
+}

extlib/benz/gc/markandsweep.c

@@ -0,0 +1,708 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/private/object.h"
+#include "picrin/private/state.h"
+
+enum {
+  WHITE = 0,
+  BLACK = 1
+};
+
+union header {
+  struct {
+    union header *ptr;
+    size_t size;
+  } s;
+};
+
+struct heap_page {
+  union header *basep, *endp;
+  struct heap_page *next;
+};
+
+struct object {
+  union {
+    struct basic basic;
+    struct identifier id;
+    struct string str;
+    struct blob blob;
+    struct pair pair;
+    struct vector vec;
+    struct dict dict;
+    struct weak weak;
+    struct data data;
+    struct record rec;
+    struct env env;
+    struct proc proc;
+    struct context cxt;
+    struct port port;
+    struct error err;
+    struct checkpoint cp;
+  } u;
+};
+
+struct heap {
+  union header base, *freep;
+  struct heap_page *pages;
+  struct weak *weaks;       /* weak map chain */
+};
+
+struct heap *
+pic_heap_open(pic_state *pic)
+{
+  struct heap *heap;
+
+  heap = pic_malloc(pic, sizeof(struct heap));
+
+  heap->base.s.ptr = &heap->base;
+  heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
+
+  heap->freep = &heap->base;
+  heap->pages = NULL;
+
+  heap->weaks = NULL;
+
+  return heap;
+}
+
+void
+pic_heap_close(pic_state *pic, struct heap *heap)
+{
+  struct heap_page *page;
+
+  while (heap->pages) {
+    page = heap->pages;
+    heap->pages = heap->pages->next;
+    pic_free(pic, page->basep);
+    pic_free(pic, page);
+  }
+  pic_free(pic, heap);
+}
+
+#if PIC_USE_LIBC
+void *
+pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size)
+{
+  if (size != 0) {
+    return realloc(ptr, size);
+  }
+  free(ptr);
+  return NULL;
+}
+#endif
+
+void *
+pic_malloc(pic_state *pic, size_t size)
+{
+  void *ptr;
+
+  ptr = pic->allocf(pic->userdata, NULL, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  return ptr;
+}
+
+void *
+pic_realloc(pic_state *pic, void *ptr, size_t size)
+{
+  ptr = pic->allocf(pic->userdata, ptr, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  return ptr;
+}
+
+void *
+pic_calloc(pic_state *pic, size_t count, size_t size)
+{
+  void *ptr;
+
+  size *= count;
+  ptr = pic->allocf(pic->userdata, NULL, size);
+  if (ptr == NULL && size > 0) {
+    pic_panic(pic, "memory exhausted");
+  }
+  memset(ptr, 0, size);
+  return ptr;
+}
+
+void
+pic_free(pic_state *pic, void *ptr)
+{
+  pic->allocf(pic->userdata, ptr, 0);
+}
+
+static void
+gc_protect(pic_state *pic, struct object *obj)
+{
+  if (pic->arena_idx >= pic->arena_size) {
+    pic->arena_size = pic->arena_size * 2 + 1;
+    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
+  }
+  pic->arena[pic->arena_idx++] = obj;
+}
+
+pic_value
+pic_protect(pic_state *pic, pic_value v)
+{
+  if (! pic_obj_p(pic, v))
+    return v;
+
+  gc_protect(pic, pic_obj_ptr(v));
+
+  return v;
+}
+
+size_t
+pic_enter(pic_state *pic)
+{
+  return pic->arena_idx;
+}
+
+void
+pic_leave(pic_state *pic, size_t state)
+{
+  pic->arena_idx = state;
+}
+
+static void *
+heap_alloc(pic_state *pic, size_t size)
+{
+  union header *p, *prevp;
+  size_t nunits;
+
+  assert(size > 0);
+
+  nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
+
+  prevp = pic->heap->freep;
+  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
+    if (p->s.size >= nunits)
+      break;
+    if (p == pic->heap->freep) {
+      return NULL;
+    }
+  }
+
+  if (p->s.size == nunits) {
+    prevp->s.ptr = p->s.ptr;
+  }
+  else {
+    p->s.size -= nunits;
+    p += p->s.size;
+    p->s.size = nunits;
+  }
+  pic->heap->freep = prevp;
+
+  return (void *)(p + 1);
+}
+
+static void
+heap_free(pic_state *pic, void *ap)
+{
+  union header *bp, *p;
+
+  assert(ap != NULL);
+
+  bp = (union header *)ap - 1;
+
+  for (p = pic->heap->freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
+    if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
+      break;
+    }
+  }
+  if (bp + bp->s.size == p->s.ptr && p->s.ptr->s.size > 0) { /* don't melt base header */
+    bp->s.size += p->s.ptr->s.size;
+    bp->s.ptr = p->s.ptr->s.ptr;
+  } else {
+    bp->s.ptr = p->s.ptr;
+  }
+  if (p + p->s.size == bp && bp->s.size > 0) { /* don't melt base header */
+    p->s.size += bp->s.size;
+    p->s.ptr = bp->s.ptr;
+  } else {
+    p->s.ptr = bp;
+  }
+  pic->heap->freep = p;
+}
+
+static void
+heap_morecore(pic_state *pic)
+{
+  union header *bp, *np;
+  struct heap_page *page;
+  size_t nunits;
+
+  nunits = PIC_HEAP_PAGE_SIZE / sizeof(union header);
+
+  assert(nunits >= 2);
+
+  bp = pic_malloc(pic, PIC_HEAP_PAGE_SIZE);
+  bp->s.size = 0;               /* bp is never used for allocation */
+  heap_free(pic, bp + 1);
+
+  np = bp + 1;
+  np->s.size = nunits - 1;
+  heap_free(pic, np + 1);
+
+  page = pic_malloc(pic, sizeof(struct heap_page));
+  page->basep = bp;
+  page->endp = bp + nunits;
+  page->next = pic->heap->pages;
+
+  pic->heap->pages = page;
+}
+
+/* MARK */
+
+static void gc_mark_object(pic_state *, struct object *);
+
+static void
+gc_mark(pic_state *pic, pic_value v)
+{
+  if (! pic_obj_p(pic, v))
+    return;
+
+  gc_mark_object(pic, pic_obj_ptr(v));
+}
+
+static void
+gc_mark_object(pic_state *pic, struct object *obj)
+{
+ loop:
+
+  if (obj->u.basic.gc_mark == BLACK)
+    return;
+
+  obj->u.basic.gc_mark = BLACK;
+
+#define LOOP(o) obj = (struct object *)(o); goto loop
+
+  switch (obj->u.basic.tt) {
+  case PIC_TYPE_PAIR: {
+    gc_mark(pic, obj->u.pair.car);
+    if (pic_obj_p(pic, obj->u.pair.cdr)) {
+      LOOP(pic_obj_ptr(obj->u.pair.cdr));
+    }
+    break;
+  }
+  case PIC_TYPE_CXT: {
+    int i;
+
+    for (i = 0; i < obj->u.cxt.regc; ++i) {
+      gc_mark(pic, obj->u.cxt.regs[i]);
+    }
+    if (obj->u.cxt.up) {
+      LOOP(obj->u.cxt.up);
+    }
+    break;
+  }
+  case PIC_TYPE_FUNC: {
+    int i;
+    for (i = 0; i < obj->u.proc.u.f.localc; ++i) {
+      gc_mark(pic, obj->u.proc.locals[i]);
+    }
+    break;
+  }
+  case PIC_TYPE_IREP: {
+    if (obj->u.proc.u.i.cxt) {
+      LOOP(obj->u.proc.u.i.cxt);
+    }
+    break;
+  }
+  case PIC_TYPE_PORT: {
+    break;
+  }
+  case PIC_TYPE_ERROR: {
+    gc_mark_object(pic, (struct object *)obj->u.err.type);
+    gc_mark_object(pic, (struct object *)obj->u.err.msg);
+    gc_mark(pic, obj->u.err.irrs);
+    LOOP(obj->u.err.stack);
+    break;
+  }
+  case PIC_TYPE_STRING: {
+    break;
+  }
+  case PIC_TYPE_VECTOR: {
+    int i;
+    for (i = 0; i < obj->u.vec.len; ++i) {
+      gc_mark(pic, obj->u.vec.data[i]);
+    }
+    break;
+  }
+  case PIC_TYPE_BLOB: {
+    break;
+  }
+  case PIC_TYPE_ID: {
+    gc_mark_object(pic, (struct object *)obj->u.id.u.id);
+    LOOP(obj->u.id.env);
+    break;
+  }
+  case PIC_TYPE_ENV: {
+    khash_t(env) *h = &obj->u.env.map;
+    int it;
+
+    for (it = kh_begin(h); it != kh_end(h); ++it) {
+      if (kh_exist(h, it)) {
+        gc_mark_object(pic, (struct object *)kh_key(h, it));
+        gc_mark_object(pic, (struct object *)kh_val(h, it));
+      }
+    }
+    if (obj->u.env.up) {
+      LOOP(obj->u.env.up);
+    }
+    break;
+  }
+  case PIC_TYPE_DATA: {
+    if (obj->u.data.type->mark) {
+      obj->u.data.type->mark(pic, obj->u.data.data, gc_mark);
+    }
+    break;
+  }
+  case PIC_TYPE_DICT: {
+    pic_value key, val;
+    int it = 0;
+
+    while (pic_dict_next(pic, pic_obj_value(&obj->u.dict), &it, &key, &val)) {
+      gc_mark(pic, key);
+      gc_mark(pic, val);
+    }
+    break;
+  }
+  case PIC_TYPE_RECORD: {
+    gc_mark(pic, obj->u.rec.type);
+    if (pic_obj_p(pic, obj->u.rec.datum)) {
+      LOOP(pic_obj_ptr(obj->u.rec.datum));
+    }
+    break;
+  }
+  case PIC_TYPE_SYMBOL: {
+    LOOP(obj->u.id.u.str);
+    break;
+  }
+  case PIC_TYPE_WEAK: {
+    struct weak *weak = (struct weak *)obj;
+
+    weak->prev = pic->heap->weaks;
+    pic->heap->weaks = weak;
+    break;
+  }
+  case PIC_TYPE_CP: {
+    if (obj->u.cp.prev) {
+      gc_mark_object(pic, (struct object *)obj->u.cp.prev);
+    }
+    if (obj->u.cp.in) {
+      gc_mark_object(pic, (struct object *)obj->u.cp.in);
+    }
+    if (obj->u.cp.out) {
+      LOOP((struct object *)obj->u.cp.out);
+    }
+    break;
+  }
+  default:
+    PIC_UNREACHABLE();
+  }
+}
+
+static void
+gc_mark_phase(pic_state *pic)
+{
+  pic_value *stack;
+  struct callinfo *ci;
+  struct list_head *list;
+  int it;
+  size_t j;
+
+  assert(pic->heap->weaks == NULL);
+
+  /* checkpoint */
+  if (pic->cp) {
+    gc_mark_object(pic, (struct object *)pic->cp);
+  }
+
+  /* stack */
+  for (stack = pic->stbase; stack != pic->sp; ++stack) {
+    gc_mark(pic, *stack);
+  }
+
+  /* callinfo */
+  for (ci = pic->ci; ci != pic->cibase; --ci) {
+    if (ci->cxt) {
+      gc_mark_object(pic, (struct object *)ci->cxt);
+    }
+  }
+
+  /* arena */
+  for (j = 0; j < pic->arena_idx; ++j) {
+    gc_mark_object(pic, (struct object *)pic->arena[j]);
+  }
+
+  /* ireps */
+  for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
+    struct irep *irep = (struct irep *)list;
+    for (j = 0; j < irep->npool; ++j) {
+      gc_mark_object(pic, irep->pool[j]);
+    }
+  }
+
+  /* global variables */
+  gc_mark(pic, pic->globals);
+
+  /* macro objects */
+  gc_mark(pic, pic->macros);
+
+  /* error object */
+  gc_mark(pic, pic->err);
+
+  /* features */
+  gc_mark(pic, pic->features);
+
+  /* library table */
+  for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
+    if (! kh_exist(&pic->ltable, it)) {
+      continue;
+    }
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name);
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env);
+    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports);
+  }
+
+  /* weak maps */
+  do {
+    struct object *key;
+    pic_value val;
+    int it;
+    khash_t(weak) *h;
+    struct weak *weak;
+
+    j = 0;
+    weak = pic->heap->weaks;
+
+    while (weak != NULL) {
+      h = &weak->hash;
+      for (it = kh_begin(h); it != kh_end(h); ++it) {
+        if (! kh_exist(h, it))
+          continue;
+        key = kh_key(h, it);
+        val = kh_val(h, it);
+        if (key->u.basic.gc_mark == BLACK) {
+          if (pic_obj_p(pic, val) && pic_obj_ptr(val)->u.basic.gc_mark == WHITE) {
+            gc_mark(pic, val);
+            ++j;
+          }
+        }
+      }
+      weak = weak->prev;
+    }
+  } while (j > 0);
+}
+
+/* SWEEP */
+
+static void
+gc_finalize_object(pic_state *pic, struct object *obj)
+{
+  switch (obj->u.basic.tt) {
+  case PIC_TYPE_VECTOR: {
+    pic_free(pic, obj->u.vec.data);
+    break;
+  }
+  case PIC_TYPE_BLOB: {
+    pic_free(pic, obj->u.blob.data);
+    break;
+  }
+  case PIC_TYPE_STRING: {
+    pic_rope_decref(pic, obj->u.str.rope);
+    break;
+  }
+  case PIC_TYPE_ENV: {
+    kh_destroy(env, &obj->u.env.map);
+    break;
+  }
+  case PIC_TYPE_DATA: {
+    if (obj->u.data.type->dtor) {
+      obj->u.data.type->dtor(pic, obj->u.data.data);
+    }
+    break;
+  }
+  case PIC_TYPE_DICT: {
+    kh_destroy(dict, &obj->u.dict.hash);
+    break;
+  }
+  case PIC_TYPE_SYMBOL: {
+    /* TODO: remove this symbol's entry from pic->syms immediately */
+    break;
+  }
+  case PIC_TYPE_WEAK: {
+    kh_destroy(weak, &obj->u.weak.hash);
+    break;
+  }
+  case PIC_TYPE_IREP: {
+    pic_irep_decref(pic, obj->u.proc.u.i.irep);
+    break;
+  }
+
+  case PIC_TYPE_PAIR:
+  case PIC_TYPE_CXT:
+  case PIC_TYPE_PORT:
+  case PIC_TYPE_ERROR:
+  case PIC_TYPE_ID:
+  case PIC_TYPE_RECORD:
+  case PIC_TYPE_CP:
+  case PIC_TYPE_FUNC:
+    break;
+
+  default:
+    PIC_UNREACHABLE();
+  }
+}
+
+static size_t
+gc_sweep_page(pic_state *pic, struct heap_page *page)
+{
+  union header *bp, *p, *head = NULL, *tail = NULL;
+  struct object *obj;
+  size_t alive = 0;
+
+  for (bp = page->basep; ; bp = bp->s.ptr) {
+    p = bp + (bp->s.size ? bp->s.size : 1); /* first bp's size is 0, so force advnce */
+    for (; p != bp->s.ptr; p += p->s.size) {
+      if (p < page->basep || page->endp <= p) {
+        goto escape;
+      }
+      obj = (struct object *)(p + 1);
+      if (obj->u.basic.gc_mark == BLACK) {
+        obj->u.basic.gc_mark = WHITE;
+        alive += p->s.size;
+      } else {
+        if (head == NULL) {
+          head = p;
+        }
+        if (tail != NULL) {
+          tail->s.ptr = p;
+        }
+        tail = p;
+        tail->s.ptr = NULL; /* We can safely reuse ptr field of dead object */
+      }
+    }
+  }
+ escape:
+
+  /* free! */
+  while (head != NULL) {
+    p = head;
+    head = head->s.ptr;
+    gc_finalize_object(pic, (struct object *)(p + 1));
+    heap_free(pic, p + 1);
+  }
+
+  return alive;
+}
+
+static void
+gc_sweep_phase(pic_state *pic)
+{
+  struct heap_page *page;
+  int it;
+  khash_t(weak) *h;
+  khash_t(oblist) *s = &pic->oblist;
+  symbol *sym;
+  struct object *obj;
+  size_t total = 0, inuse = 0;
+
+  /* weak maps */
+  while (pic->heap->weaks != NULL) {
+    h = &pic->heap->weaks->hash;
+    for (it = kh_begin(h); it != kh_end(h); ++it) {
+      if (! kh_exist(h, it))
+        continue;
+      obj = kh_key(h, it);
+      if (obj->u.basic.gc_mark == WHITE) {
+        kh_del(weak, h, it);
+      }
+    }
+    pic->heap->weaks = pic->heap->weaks->prev;
+  }
+
+  /* symbol table */
+  for (it = kh_begin(s); it != kh_end(s); ++it) {
+    if (! kh_exist(s, it))
+      continue;
+    sym = kh_val(s, it);
+    if (sym && sym->gc_mark == WHITE) {
+      kh_del(oblist, s, it);
+    }
+  }
+
+  page = pic->heap->pages;
+  while (page) {
+    inuse += gc_sweep_page(pic, page);
+    total += page->endp - page->basep;
+    page = page->next;
+  }
+
+  if (PIC_PAGE_REQUEST_THRESHOLD(total) <= inuse) {
+    heap_morecore(pic);
+  }
+}
+
+void
+pic_gc(pic_state *pic)
+{
+  if (! pic->gc_enable) {
+    return;
+  }
+
+  gc_mark_phase(pic);
+  gc_sweep_phase(pic);
+}
+
+void *
+pic_alloca(pic_state *pic, size_t n)
+{
+  static const pic_data_type t = { "pic_alloca", pic_free, 0 };
+
+  /* TODO: optimize */
+  return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
+}
+
+struct object *
+pic_obj_alloc_unsafe(pic_state *pic, size_t size, int type)
+{
+  struct object *obj;
+
+#if GC_STRESS
+  pic_gc(pic);
+#endif
+
+  obj = (struct object *)heap_alloc(pic, size);
+  if (obj == NULL) {
+    pic_gc(pic);
+    obj = (struct object *)heap_alloc(pic, size);
+    if (obj == NULL) {
+      heap_morecore(pic);
+      obj = (struct object *)heap_alloc(pic, size);
+      if (obj == NULL)
+	pic_panic(pic, "GC memory exhausted");
+    }
+  }
+  obj->u.basic.gc_mark = WHITE;
+  obj->u.basic.tt = type;
+
+  return obj;
+}
+
+struct object *
+pic_obj_alloc(pic_state *pic, size_t size, int type)
+{
+  struct object *obj;
+
+  obj = pic_obj_alloc_unsafe(pic, size, type);
+
+  gc_protect(pic, obj);
+  return obj;
+}

extlib/benz/include/picrin/private/object.h

@@ -17,8 +17,14 @@ KHASH_DECLARE(env, struct identifier *, symbol *)
 KHASH_DECLARE(dict, symbol *, pic_value)
 KHASH_DECLARE(weak, struct object *, pic_value)
 
-#define OBJECT_HEADER                           \
+#ifdef PIC_USE_BITMAPGC
+# define OBJECT_HEADER                           \
   unsigned char tt;
+#else
+# define OBJECT_HEADER                           \
+  unsigned char tt;                              \
+  char gc_mark;
+#endif
 
 struct object;              /* defined in gc.c */
 

extlib/benz/include/picrin/setup.h

@@ -167,6 +167,14 @@ typedef unsigned long uint32_t;
 #include <assert.h>
 #include <stdlib.h>
 
+# ifndef PIC_MEMALIGN
+#   include <unistd.h>
+#   define PIC_MEMALIGN(pic, buf, alignment, size) posix_memalign(buf, alignment, size)
+#   define PIC_ALIGNMENT() sysconf(_SC_PAGESIZE)
+#   define PIC_USE_BITMAPGC
+# endif
+
+
 #else
 
 # define assert(v) (void)0

extlib/benz/read.c

@@ -25,7 +25,7 @@ typedef pic_value (*pic_reader_t)(pic_state *, xFILE *file, int c, struct reader
 static pic_reader_t reader_table[256];
 static pic_reader_t reader_dispatch[256];
 
-static pic_value read(pic_state *pic, xFILE *file, int c, struct reader_control *p);
+static pic_value read_safe(pic_state *pic, xFILE *file, int c, struct reader_control *p);
 static pic_value read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p);
 
 PIC_NORETURN static void
@@ -123,7 +123,7 @@ read_block_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader
 static pic_value
 read_datum_comment(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
 {
-  read(pic, file, next(pic, file), p);
+  read_safe(pic, file, next(pic, file), p);
 
   return pic_invalid_value(pic);
 }
@@ -152,13 +152,13 @@ read_directive(pic_state *pic, xFILE *file, int c, struct reader_control *p)
 static pic_value
 read_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
 read_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
@@ -172,19 +172,19 @@ read_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_contr
   } else {
     tag = pic_intern_lit(pic, "unquote");
   }
-  return pic_list(pic, 2, tag, read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, tag, read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
 read_syntax_quote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
 read_syntax_quasiquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reader_control *p)
 {
-  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
@@ -198,7 +198,7 @@ read_syntax_unquote(pic_state *pic, xFILE *file, int PIC_UNUSED(c), struct reade
   } else {
     tag = pic_intern_lit(pic, "syntax-unquote");
   }
-  return pic_list(pic, 2, tag, read(pic, file, next(pic, file), p));
+  return pic_list(pic, 2, tag, read_safe(pic, file, next(pic, file), p));
 }
 
 static pic_value
@@ -474,7 +474,7 @@ read_pair(pic_state *pic, xFILE *file, int c, struct reader_control *p)
     return pic_nil_value(pic);
   }
   if (c == '.' && isdelim(peek(pic, file))) {
-    cdr = read(pic, file, next(pic, file), p);
+    cdr = read_safe(pic, file, next(pic, file), p);
 
   closing:
     if ((c = skip(pic, file, ' ')) != tCLOSE) {
@@ -503,7 +503,7 @@ read_vector(pic_state *pic, xFILE *file, int c, struct reader_control *p)
   pic_value list, it, elem, vec;
   int i = 0;
 
-  list = read(pic, file, c, p);
+  list = read_safe(pic, file, c, p);
 
   vec = pic_make_vec(pic, pic_length(pic, list), NULL);
 
@@ -530,7 +530,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
 
       kh_val(h, it) = val = pic_cons(pic, pic_undef_value(pic), pic_undef_value(pic));
 
-      tmp = read(pic, file, c, p);
+      tmp = read_safe(pic, file, c, p);
       pic_pair_ptr(pic, val)->car = pic_car(pic, tmp);
       pic_pair_ptr(pic, val)->cdr = pic_cdr(pic, tmp);
 
@@ -551,7 +551,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
 
         kh_val(h, it) = val = pic_make_vec(pic, 0, NULL);
 
-        tmp = read(pic, file, c, p);
+        tmp = read_safe(pic, file, c, p);
         PIC_SWAP(pic_value *, pic_vec_ptr(pic, tmp)->data, pic_vec_ptr(pic, val)->data);
         PIC_SWAP(int, pic_vec_ptr(pic, tmp)->len, pic_vec_ptr(pic, val)->len);
 
@@ -562,7 +562,7 @@ read_label_set(pic_state *pic, xFILE *file, int i, struct reader_control *p)
     }
   default:
     {
-      kh_val(h, it) = val = read(pic, file, c, p);
+      kh_val(h, it) = val = read_safe(pic, file, c, p);
 
       return val;
     }
@@ -640,7 +640,7 @@ read_nullable(pic_state *pic, xFILE *file, int c, struct reader_control *p)
 }
 
 static pic_value
-read(pic_state *pic, xFILE *file, int c, struct reader_control *p)
+read_safe(pic_state *pic, xFILE *file, int c, struct reader_control *p)
 {
   pic_value val;
 

extlib/benz/write.c

@@ -357,7 +357,7 @@ write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p)
 }
 
 static void
-write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op)
+write_value(pic_state *pic, pic_value obj, xFILE *file, int mode, int op)
 {
   struct writer_control p;
 
@@ -422,10 +422,10 @@ pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap)
         xfputc(pic, '\n', file);
         break;
       case 'a':
-        write(pic, va_arg(ap, pic_value), file, DISPLAY_MODE, OP_WRITE);
+        write_value(pic, va_arg(ap, pic_value), file, DISPLAY_MODE, OP_WRITE);
         break;
       case 's':
-        write(pic, va_arg(ap, pic_value), file, WRITE_MODE, OP_WRITE);
+        write_value(pic, va_arg(ap, pic_value), file, WRITE_MODE, OP_WRITE);
         break;
       }
       break;
@@ -461,7 +461,7 @@ pic_write_write(pic_state *pic)
   pic_value v, port = pic_stdout(pic);
 
   pic_get_args(pic, "o|p", &v, &port);
-  write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE);
+  write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE);
   return pic_undef_value(pic);
 }
 
@@ -471,7 +471,7 @@ pic_write_write_simple(pic_state *pic)
   pic_value v, port = pic_stdout(pic);
 
   pic_get_args(pic, "o|p", &v, &port);
-  write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SIMPLE);
+  write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SIMPLE);
   return pic_undef_value(pic);
 }
 
@@ -481,7 +481,7 @@ pic_write_write_shared(pic_state *pic)
   pic_value v, port = pic_stdout(pic);
 
   pic_get_args(pic, "o|p", &v, &port);
-  write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SHARED);
+  write_value(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SHARED);
   return pic_undef_value(pic);
 }
 
@@ -491,7 +491,7 @@ pic_write_display(pic_state *pic)
   pic_value v, port = pic_stdout(pic);
 
   pic_get_args(pic, "o|p", &v, &port);
-  write(pic, v, pic_fileno(pic, port), DISPLAY_MODE, OP_WRITE);
+  write_value(pic, v, pic_fileno(pic, port), DISPLAY_MODE, OP_WRITE);
   return pic_undef_value(pic);
 }