picrin/src/gc.c

#include <stdlib.h>

#include "picrin.h"
#include "picrin/gc.h"
#include "picrin/irep.h"

#if GC_DEBUG
# include <stdio.h>
#endif

void
init_heap_page(struct heap_page *heap)
{
  union header *base, *freep;
  void *p;

  p = (union header *)malloc(PIC_HEAP_SIZE);

  heap->base = base = (union header *)
    (((unsigned long)p + sizeof(union header) -1) & ~(sizeof(union header) - 1));
  base->s.ptr = base + 1;
  base->s.size = 0;

  heap->freep = freep = base->s.ptr;
  freep->s.ptr = base;
  freep->s.size = ((char *)p + PIC_HEAP_SIZE - (char *)freep) / sizeof(union header);

  heap->endp = freep + freep->s.size;
}

void *
pic_alloc(pic_state *pic, size_t size)
{
  void *ptr;

  ptr = malloc(size);
  if (ptr == NULL) {
    pic_raise(pic, "memory exhausted");
  }
  return ptr;
}

void
pic_free(pic_state *pic, void *ptr)
{
  free(ptr);
}

static void
gc_protect(pic_state *pic, struct pic_object *obj)
{
  if (pic->arena_idx >= PIC_ARENA_SIZE) {
    pic_raise(pic, "arena overflow");
  }
  pic->arena[pic->arena_idx++] = obj;
}

void
pic_gc_protect(pic_state *pic, pic_value v)
{
  struct pic_object *obj;

  if (v.type != PIC_VTYPE_HEAP) {
    return;
  }
  obj = pic_object_ptr(v);

  gc_protect(pic, obj);
}

int
pic_gc_arena_preserve(pic_state *pic)
{
  return pic->arena_idx;
}

void
pic_gc_arena_restore(pic_state *pic, int state)
{
  pic->arena_idx = state;
}

static void *
gc_alloc(pic_state *pic, size_t size)
{
  union header *freep, *p, *prevp;
  size_t nunits;

  nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;

  freep = pic->heap->freep;
  prevp = freep;
  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
    if (p->s.size >= nunits)
      break;
    if (p == freep) {
      return 0;
    }
  }
  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;

  p->s.mark = PIC_GC_UNMARK;
  return (void *)(p + 1);
}

static void gc_mark(pic_state *, pic_value);

static void
gc_mark_object(pic_state *pic, struct pic_object *obj)
{
  union header *p;

  p = (union header *)obj - 1;
  p->s.mark = PIC_GC_MARK;

  switch (obj->tt) {
  case PIC_TT_PAIR: {
    gc_mark(pic, ((struct pic_pair *)obj)->car);
    gc_mark(pic, ((struct pic_pair *)obj)->cdr);
    break;
  }
  case PIC_TT_SYMBOL: {
    break;
  }
  case PIC_TT_PROC: {
    break;
  }
  default:
    pic_raise(pic, "logic flaw");
  }
}

static void
gc_mark(pic_state *pic, pic_value v)
{
  struct pic_object *obj;

  if (v.type != PIC_VTYPE_HEAP)
    return;
  obj = pic_object_ptr(v);

  gc_mark_object(pic, obj);
}

static void
gc_mark_phase(pic_state *pic)
{
  pic_value *stack;
  struct pic_env *env;
  int i;

  /* stack */
  for (stack = pic->stbase; stack != pic->sp; ++stack) {
    gc_mark(pic, *stack);
  }
  gc_mark(pic, *stack);

  /* arena */
  for (i = 0; i < pic->arena_idx; ++i) {
    gc_mark_object(pic, pic->arena[i]);
  }

  /* global env */
  env = pic->global_env;
  do {
    gc_mark(pic, env->assoc);
  } while ((env = env->parent) != NULL);
}

static bool
is_marked(union header *p)
{
  return p->s.mark == PIC_GC_MARK;
}

static void
gc_unmark(union header *p)
{
  p->s.mark = PIC_GC_UNMARK;
}

static void
gc_finalize_object(pic_state *pic, struct pic_object *obj)
{
#if GC_DEBUG
  printf("finalizing object type %d\n", obj->tt);
#endif

  switch (obj->tt) {
  case PIC_TT_SYMBOL: {
    char *name;
    name = ((struct pic_symbol *)obj)->name;
    pic_free(pic, name);
    break;
  }
  case PIC_TT_PAIR: {
    break;
  }
  case PIC_TT_PROC: {
    struct pic_proc *proc;

    proc = (struct pic_proc *)obj;

    /* free irep */
    pic_free(pic, proc->u.irep->code);
    pic_free(pic, proc->u.irep);
    break;
  }
  default:
    pic_raise(pic, "logic flaw");
  }
}

static void
gc_sweep_phase(pic_state *pic)
{
  union header *base, *bp, *p;

#if GC_DEBUG
  puts("sweep started");
#endif

  base = pic->heap->base;
  for (p = base->s.ptr; p != base; p = p->s.ptr) {

#if GC_DEBUG
    puts("sweeping block");
#endif

  retry:

    for (bp = p + p->s.size; bp != p->s.ptr; bp += bp->s.size) {

#if GC_DEBUG
      printf("  bp = %p\n  p  = %p\n  p->s.ptr = %p\n  endp = %p\n",bp, p, p->s.ptr, pic->heap->endp);
#endif

      if (p >= p->s.ptr && bp == pic->heap->endp)
	break;
      if (is_marked(bp)) {

#if GC_DEBUG
	printf("marked:\t\t\t");
	pic_debug(pic, pic_obj_value((struct pic_object *)(bp + 1)));
	printf("\n");
#endif

	gc_unmark(bp);
	continue;
      }

#if GC_DEBUG
      puts("unmarked");
#endif

      /* free! */
      gc_finalize_object(pic, (struct pic_object *)(bp + 1));
      if (bp + bp->s.size == p->s.ptr) {
	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) {
	p->s.size += bp->s.size;
	p->s.ptr = bp->s.ptr;
      }
      else {
	p->s.ptr = bp;
	/* retry with next p */
	p = p->s.ptr;
      }

      goto retry;
    }
  }
}

void
pic_gc_run(pic_state *pic)
{
#if GC_DEBUG
  puts("gc run!");
#endif
  gc_mark_phase(pic);
  gc_sweep_phase(pic);
}

struct pic_object *
pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt)
{
  struct pic_object *obj;

  obj = (struct pic_object *)gc_alloc(pic, size);
  if (obj == NULL) {
    pic_gc_run(pic);
    obj = (struct pic_object *)gc_alloc(pic, size);
    if (obj == NULL)
      pic_raise(pic, "GC memory exhausted");
  }
  obj->tt = tt;

#if GC_DEBUG
  printf("* alloced object type %d\n", tt);
#endif

  gc_protect(pic, obj);
  return obj;
}