picrin/src/gc.c

#include <stdlib.h>

#include "picrin.h"
#include "picrin/gc.h"
#include "picrin/irep.h"
#include "picrin/proc.h"
#include "picrin/symbol.h"
#include "picrin/port.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 = 1;

  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;

#if GC_DEBUG
  printf("base = %p\nbase->s.ptr = %p\n", base, base->s.ptr);
#endif
}

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

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

void *
pic_realloc(pic_state *pic, void *ptr, size_t size)
{
  ptr = realloc(ptr, size);
  if (ptr == NULL) {
    pic_abort(pic, "memory exhausted");
  }
  return ptr;
}

void *
pic_calloc(pic_state *pic, unsigned count, size_t size)
{
  void *ptr;

  ptr = calloc(count ,size);
  if (ptr == NULL) {
    pic_abort(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_abort(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_obj_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_ENV: {
    struct pic_env *env = (struct pic_env *)obj;
    int i;

    for (i = 0; i < env->num_val; ++i) {
      gc_mark(pic, env->values[i]);
    }
    gc_mark_object(pic, (struct pic_object *)env->up);
    break;
  }
  case PIC_TT_PROC: {
    struct pic_proc *proc = (struct pic_proc *)obj;
    if (proc->env) {
      gc_mark_object(pic, (struct pic_object *)proc->env);
    }
    gc_mark(pic, proc->aux);
    break;
  }
  case PIC_TT_PORT: {
    break;
  }
  case PIC_TT_STRING: {
  }
  case PIC_TT_NIL:
  case PIC_TT_BOOL:
  case PIC_TT_FLOAT:
  case PIC_TT_INT:
  case PIC_TT_EOF:
  case PIC_TT_UNDEF:
    pic_abort(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_obj_ptr(v);

  gc_mark_object(pic, obj);
}

static void
gc_mark_phase(pic_state *pic)
{
  pic_value *stack;
  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]);
  }

  /* globals */
  for (i = 0; i < pic->glen; ++i) {
    gc_mark(pic, pic->globals[i]);
  }

  /* pool */
  for (i = 0; i < pic->plen; ++i) {
    gc_mark(pic, pic->pool[i]);
  }

  /* symbol table */
  for (i = 0; i < pic->sym_tbl->size; ++i) {
    gc_mark(pic, pic->sym_tbl->tbl[i]);
  }

  gc_mark(pic, pic->sDEFINE);
  gc_mark(pic, pic->sLAMBDA);
  gc_mark(pic, pic->sIF);
  gc_mark(pic, pic->sBEGIN);
  gc_mark(pic, pic->sSETBANG);
  gc_mark(pic, pic->sQUOTE);
  gc_mark(pic, pic->sQUASIQUOTE);
  gc_mark(pic, pic->sUNQUOTE);
  gc_mark(pic, pic->sUNQUOTE_SPLICING);
  gc_mark(pic, pic->sCONS);
  gc_mark(pic, pic->sCAR);
  gc_mark(pic, pic->sCDR);
  gc_mark(pic, pic->sNILP);
  gc_mark(pic, pic->sADD);
  gc_mark(pic, pic->sSUB);
  gc_mark(pic, pic->sMUL);
  gc_mark(pic, pic->sEQ);
  gc_mark(pic, pic->sLT);
  gc_mark(pic, pic->sLE);
  gc_mark(pic, pic->sGT);
  gc_mark(pic, pic->sGE);
  gc_mark(pic, pic->sDIV);
}

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_ENV: {
    pic_free(pic, ((struct pic_env *)obj)->values);
    break;
  }
  case PIC_TT_PROC: {
    break;
  }
  case PIC_TT_STRING: {
    pic_free(pic, (void*)((struct pic_string *)obj)->str);
    break;
  }
  case PIC_TT_PORT: {
    struct pic_port *port = (struct pic_port *)obj;
    if (port->status == PIC_PORT_OPEN) {
      fclose(port->file);
    }
    break;
  }
  case PIC_TT_NIL:
  case PIC_TT_BOOL:
  case PIC_TT_FLOAT:
  case PIC_TT_INT:
  case PIC_TT_EOF:
  case PIC_TT_UNDEF:
    pic_abort(pic, "logic flaw");
  }
}

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

#if GC_DEBUG
  int freed = 0;

  puts("sweep started");
#endif

  base = pic->heap->base;
#if GC_DEBUG
  printf("base = %p\nbase->s.ptr = %p\n", base, base->s.ptr);
#endif
  for (p = base->s.ptr; ; 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;
      }

#if GC_DEBUG
      freed++;
#endif

      goto retry;
    }

    if (p->s.ptr == base)
      break;
  }

#if GC_DEBUG
  printf("freed: %d counts\n", freed);
#endif
}

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_abort(pic, "GC memory exhausted");
  }
  obj->tt = tt;

  gc_protect(pic, obj);
  return obj;
}