2014-08-25 00:38:09 -04:00
|
|
|
/**
|
|
|
|
* See Copyright Notice in picrin.h
|
|
|
|
*/
|
|
|
|
|
|
|
|
#include "picrin.h"
|
|
|
|
|
|
|
|
union header {
|
|
|
|
struct {
|
|
|
|
union header *ptr;
|
|
|
|
size_t size;
|
2015-05-27 09:49:29 -04:00
|
|
|
char mark;
|
2014-08-25 00:38:09 -04:00
|
|
|
} s;
|
2015-01-17 04:36:23 -05:00
|
|
|
long alignment[2];
|
2014-08-25 00:38:09 -04:00
|
|
|
};
|
|
|
|
|
|
|
|
struct heap_page {
|
|
|
|
union header *basep, *endp;
|
|
|
|
struct heap_page *next;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct pic_heap {
|
|
|
|
union header base, *freep;
|
|
|
|
struct heap_page *pages;
|
|
|
|
};
|
|
|
|
|
|
|
|
|
2015-07-15 10:32:31 -04:00
|
|
|
struct pic_heap *
|
|
|
|
pic_heap_open(pic_state *pic)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
2015-07-15 10:32:31 -04:00
|
|
|
struct pic_heap *heap;
|
|
|
|
|
2015-07-16 02:31:11 -04:00
|
|
|
heap = pic_malloc(pic, sizeof(struct pic_heap));
|
2015-07-15 10:32:31 -04:00
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
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;
|
|
|
|
|
|
|
|
return heap;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
2015-01-22 03:08:41 -05:00
|
|
|
pic_heap_close(pic_state *pic, struct pic_heap *heap)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
|
|
|
struct heap_page *page;
|
|
|
|
|
|
|
|
while (heap->pages) {
|
|
|
|
page = heap->pages;
|
|
|
|
heap->pages = heap->pages->next;
|
2015-07-16 02:28:30 -04:00
|
|
|
pic_free(pic, page->basep);
|
2015-01-22 03:08:41 -05:00
|
|
|
pic_free(pic, page);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-07-16 02:28:30 -04:00
|
|
|
pic_free(pic, heap);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
2015-05-27 13:12:26 -04:00
|
|
|
#if PIC_ENABLE_LIBC
|
|
|
|
void *
|
|
|
|
pic_default_allocf(void *ptr, size_t size)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
|
|
|
if (size == 0) {
|
|
|
|
if (ptr) {
|
|
|
|
free(ptr);
|
|
|
|
}
|
|
|
|
return NULL;
|
|
|
|
}
|
|
|
|
if (ptr) {
|
|
|
|
return realloc(ptr, size);
|
|
|
|
} else {
|
|
|
|
return malloc(size);
|
|
|
|
}
|
|
|
|
}
|
2015-05-27 13:12:26 -04:00
|
|
|
#endif
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
void *
|
2015-05-28 03:42:16 -04:00
|
|
|
pic_malloc(pic_state *pic, size_t size)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
|
|
|
void *ptr;
|
|
|
|
|
2015-05-27 13:12:26 -04:00
|
|
|
ptr = pic->allocf(NULL, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (ptr == NULL && size > 0) {
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "memory exhausted");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
return ptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
void *
|
|
|
|
pic_realloc(pic_state *pic, void *ptr, size_t size)
|
|
|
|
{
|
2015-05-27 13:12:26 -04:00
|
|
|
ptr = pic->allocf(ptr, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (ptr == NULL && size > 0) {
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "memory exhausted");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
return ptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
void *
|
|
|
|
pic_calloc(pic_state *pic, size_t count, size_t size)
|
|
|
|
{
|
|
|
|
void *ptr;
|
|
|
|
|
|
|
|
size *= count;
|
2015-05-27 13:12:26 -04:00
|
|
|
ptr = pic->allocf(NULL, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (ptr == NULL && size > 0) {
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "memory exhausted");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
memset(ptr, 0, size);
|
|
|
|
return ptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_free(pic_state *pic, void *ptr)
|
|
|
|
{
|
2015-05-27 13:12:26 -04:00
|
|
|
pic->allocf(ptr, 0);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_protect(pic_state *pic, struct pic_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 pic_object *) * pic->arena_size);
|
|
|
|
}
|
|
|
|
pic->arena[pic->arena_idx++] = obj;
|
|
|
|
}
|
|
|
|
|
|
|
|
pic_value
|
|
|
|
pic_gc_protect(pic_state *pic, pic_value v)
|
|
|
|
{
|
|
|
|
struct pic_object *obj;
|
|
|
|
|
|
|
|
if (pic_vtype(v) != PIC_VTYPE_HEAP) {
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
obj = pic_obj_ptr(v);
|
|
|
|
|
|
|
|
gc_protect(pic, obj);
|
|
|
|
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
|
|
|
|
size_t
|
|
|
|
pic_gc_arena_preserve(pic_state *pic)
|
|
|
|
{
|
|
|
|
return pic->arena_idx;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_gc_arena_restore(pic_state *pic, size_t state)
|
|
|
|
{
|
|
|
|
pic->arena_idx = state;
|
|
|
|
}
|
|
|
|
|
|
|
|
static void *
|
2015-07-16 02:38:37 -04:00
|
|
|
heap_alloc(pic_state *pic, size_t size)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
2015-07-16 02:42:44 -04:00
|
|
|
union header *p, *prevp;
|
2014-08-25 00:38:09 -04:00
|
|
|
size_t nunits;
|
|
|
|
|
|
|
|
assert(size > 0);
|
|
|
|
|
|
|
|
nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
|
|
|
|
|
2015-07-16 02:42:44 -04:00
|
|
|
prevp = pic->heap->freep;
|
2014-08-25 00:38:09 -04:00
|
|
|
for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
|
|
|
|
if (p->s.size >= nunits)
|
|
|
|
break;
|
2015-07-16 02:42:44 -04:00
|
|
|
if (p == pic->heap->freep) {
|
2014-08-25 00:38:09 -04:00
|
|
|
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
|
2015-07-16 02:41:43 -04:00
|
|
|
heap_free(pic_state *pic, void *ap)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
2015-07-16 02:42:44 -04:00
|
|
|
union header *bp, *p;
|
2015-07-16 02:41:43 -04:00
|
|
|
|
|
|
|
assert(ap != NULL);
|
|
|
|
|
|
|
|
bp = (union header *)ap - 1;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-07-16 02:42:44 -04:00
|
|
|
for (p = pic->heap->freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
|
2014-08-25 00:38:09 -04:00
|
|
|
if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
}
|
2015-07-16 03:13:30 -04:00
|
|
|
if (bp + bp->s.size == p->s.ptr && p->s.ptr->s.size > 0) { /* don't melt base header */
|
2014-08-25 00:38:09 -04:00
|
|
|
bp->s.size += p->s.ptr->s.size;
|
|
|
|
bp->s.ptr = p->s.ptr->s.ptr;
|
2015-07-16 02:45:01 -04:00
|
|
|
} else {
|
2014-08-25 00:38:09 -04:00
|
|
|
bp->s.ptr = p->s.ptr;
|
|
|
|
}
|
2015-07-16 03:13:30 -04:00
|
|
|
if (p + p->s.size == bp) {
|
2014-08-25 00:38:09 -04:00
|
|
|
p->s.size += bp->s.size;
|
|
|
|
p->s.ptr = bp->s.ptr;
|
2015-07-16 02:45:01 -04:00
|
|
|
} else {
|
2014-08-25 00:38:09 -04:00
|
|
|
p->s.ptr = bp;
|
|
|
|
}
|
|
|
|
pic->heap->freep = p;
|
|
|
|
}
|
|
|
|
|
2015-07-16 02:33:31 -04:00
|
|
|
static void
|
2015-07-16 02:38:37 -04:00
|
|
|
heap_morecore(pic_state *pic)
|
2015-07-16 02:33:31 -04:00
|
|
|
{
|
|
|
|
union header *up, *np;
|
|
|
|
struct heap_page *page;
|
|
|
|
size_t nu;
|
|
|
|
|
2015-07-16 03:13:30 -04:00
|
|
|
nu = PIC_HEAP_PAGE_SIZE / sizeof(union header);
|
|
|
|
|
|
|
|
assert(nu >= 2);
|
2015-07-16 02:33:31 -04:00
|
|
|
|
2015-07-16 03:13:30 -04:00
|
|
|
up = pic_malloc(pic, PIC_HEAP_PAGE_SIZE);
|
|
|
|
up->s.size = 0; /* up is never used for allocation */
|
2015-07-16 02:41:43 -04:00
|
|
|
heap_free(pic, up + 1);
|
2015-07-16 02:33:31 -04:00
|
|
|
|
|
|
|
np = up + 1;
|
2015-07-16 03:13:30 -04:00
|
|
|
np->s.size = nu - 1;
|
|
|
|
heap_free(pic, np + 1);
|
2015-07-16 02:33:31 -04:00
|
|
|
|
|
|
|
page = pic_malloc(pic, sizeof(struct heap_page));
|
|
|
|
page->basep = up;
|
2015-07-16 03:13:30 -04:00
|
|
|
page->endp = up + nu;
|
2015-07-16 02:33:31 -04:00
|
|
|
page->next = pic->heap->pages;
|
|
|
|
|
|
|
|
pic->heap->pages = page;
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static void gc_mark(pic_state *, pic_value);
|
|
|
|
|
|
|
|
static bool
|
|
|
|
gc_is_marked(union header *p)
|
|
|
|
{
|
|
|
|
return p->s.mark == PIC_GC_MARK;
|
|
|
|
}
|
|
|
|
|
2014-09-24 23:12:52 -04:00
|
|
|
static bool
|
|
|
|
gc_obj_is_marked(struct pic_object *obj)
|
|
|
|
{
|
|
|
|
union header *p;
|
|
|
|
|
|
|
|
p = ((union header *)obj) - 1;
|
|
|
|
|
|
|
|
return gc_is_marked(p);
|
|
|
|
}
|
|
|
|
|
2015-06-09 05:31:46 -04:00
|
|
|
static bool
|
|
|
|
gc_value_need_mark(pic_value value)
|
|
|
|
{
|
|
|
|
return pic_obj_p(value) && (! gc_obj_is_marked(pic_obj_ptr(value)));
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static void
|
|
|
|
gc_unmark(union header *p)
|
|
|
|
{
|
|
|
|
p->s.mark = PIC_GC_UNMARK;
|
|
|
|
}
|
|
|
|
|
2015-07-16 02:38:37 -04:00
|
|
|
static void
|
|
|
|
gc_unmark_object(struct pic_object *obj)
|
|
|
|
{
|
|
|
|
union header *p;
|
|
|
|
|
|
|
|
p = ((union header *)obj) - 1;
|
|
|
|
|
|
|
|
p->s.mark = PIC_GC_UNMARK;
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static void
|
|
|
|
gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|
|
|
{
|
|
|
|
union header *p;
|
|
|
|
|
|
|
|
p = ((union header *)obj) - 1;
|
|
|
|
|
|
|
|
if (gc_is_marked(p))
|
|
|
|
return;
|
|
|
|
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;
|
|
|
|
}
|
2015-05-30 09:34:51 -04:00
|
|
|
case PIC_TT_CXT: {
|
|
|
|
struct pic_context *cxt = (struct pic_context *)obj;
|
2014-08-25 00:38:09 -04:00
|
|
|
int i;
|
|
|
|
|
2015-05-30 09:34:51 -04:00
|
|
|
for (i = 0; i < cxt->regc; ++i) {
|
|
|
|
gc_mark(pic, cxt->regs[i]);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-05-30 09:34:51 -04:00
|
|
|
if (cxt->up) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)cxt->up);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_PROC: {
|
|
|
|
struct pic_proc *proc = (struct pic_proc *)obj;
|
|
|
|
if (pic_proc_irep_p(proc)) {
|
2015-05-31 07:19:07 -04:00
|
|
|
gc_mark_object(pic, (struct pic_object *)proc->u.i.irep);
|
|
|
|
if (proc->u.i.cxt) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt);
|
|
|
|
}
|
2015-01-18 22:14:46 -05:00
|
|
|
} else {
|
2015-05-31 07:46:44 -04:00
|
|
|
if (proc->u.f.env) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)proc->u.f.env);
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_PORT: {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_ERROR: {
|
|
|
|
struct pic_error *err = (struct pic_error *)obj;
|
2015-01-18 22:14:46 -05:00
|
|
|
gc_mark_object(pic, (struct pic_object *)err->type);
|
|
|
|
gc_mark_object(pic, (struct pic_object *)err->msg);
|
2014-08-25 00:38:09 -04:00
|
|
|
gc_mark(pic, err->irrs);
|
|
|
|
gc_mark_object(pic, (struct pic_object *)err->stack);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_STRING: {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_VECTOR: {
|
|
|
|
size_t i;
|
|
|
|
for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) {
|
|
|
|
gc_mark(pic, ((struct pic_vector *)obj)->data[i]);
|
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_BLOB: {
|
|
|
|
break;
|
|
|
|
}
|
2015-06-09 13:16:38 -04:00
|
|
|
case PIC_TT_ID: {
|
|
|
|
struct pic_id *id = (struct pic_id *)obj;
|
|
|
|
gc_mark(pic, id->var);
|
|
|
|
gc_mark_object(pic, (struct pic_object *)id->env);
|
|
|
|
break;
|
|
|
|
}
|
2015-05-30 09:39:03 -04:00
|
|
|
case PIC_TT_ENV: {
|
|
|
|
struct pic_env *env = (struct pic_env *)obj;
|
2015-06-24 18:26:48 -04:00
|
|
|
khash_t(env) *h = &env->map;
|
|
|
|
khiter_t it;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-05-30 09:39:03 -04:00
|
|
|
if (env->up) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)env->up);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-06-24 18:26:48 -04:00
|
|
|
for (it = kh_begin(h); it != kh_end(h); ++it) {
|
|
|
|
if (kh_exist(h, it)) {
|
|
|
|
gc_mark_object(pic, kh_key(h, it));
|
|
|
|
gc_mark_object(pic, (struct pic_object *)kh_val(h, it));
|
|
|
|
}
|
2015-06-09 13:16:38 -04:00
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_LIB: {
|
|
|
|
struct pic_lib *lib = (struct pic_lib *)obj;
|
|
|
|
gc_mark(pic, lib->name);
|
|
|
|
gc_mark_object(pic, (struct pic_object *)lib->env);
|
2015-01-18 07:32:16 -05:00
|
|
|
gc_mark_object(pic, (struct pic_object *)lib->exports);
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_IREP: {
|
|
|
|
struct pic_irep *irep = (struct pic_irep *)obj;
|
|
|
|
size_t i;
|
|
|
|
|
|
|
|
for (i = 0; i < irep->ilen; ++i) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
|
|
|
|
}
|
|
|
|
for (i = 0; i < irep->plen; ++i) {
|
|
|
|
gc_mark(pic, irep->pool[i]);
|
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_DATA: {
|
|
|
|
struct pic_data *data = (struct pic_data *)obj;
|
|
|
|
|
2015-06-23 12:13:18 -04:00
|
|
|
gc_mark_object(pic, (struct pic_object *)data->storage);
|
2014-09-16 03:18:19 -04:00
|
|
|
if (data->type->mark) {
|
|
|
|
data->type->mark(pic, data->data, gc_mark);
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_DICT: {
|
|
|
|
struct pic_dict *dict = (struct pic_dict *)obj;
|
2015-06-23 12:13:18 -04:00
|
|
|
pic_sym *sym;
|
2015-06-24 16:56:15 -04:00
|
|
|
khiter_t it;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-06-23 12:13:18 -04:00
|
|
|
pic_dict_for_each (sym, dict, it) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)sym);
|
|
|
|
gc_mark(pic, pic_dict_ref(pic, dict, sym));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_RECORD: {
|
|
|
|
struct pic_record *rec = (struct pic_record *)obj;
|
|
|
|
|
2015-01-18 07:40:14 -05:00
|
|
|
gc_mark_object(pic, (struct pic_object *)rec->data);
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
2015-01-18 20:59:35 -05:00
|
|
|
case PIC_TT_SYMBOL: {
|
|
|
|
break;
|
|
|
|
}
|
2015-06-09 05:31:46 -04:00
|
|
|
case PIC_TT_REG: {
|
|
|
|
struct pic_reg *reg = (struct pic_reg *)obj;
|
|
|
|
|
|
|
|
reg->prev = pic->regs;
|
|
|
|
pic->regs = reg;
|
|
|
|
break;
|
|
|
|
}
|
2015-06-22 04:06:13 -04:00
|
|
|
case PIC_TT_CP: {
|
|
|
|
struct pic_checkpoint *cp = (struct pic_checkpoint *)obj;
|
|
|
|
|
|
|
|
if (cp->prev) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)cp->prev);
|
|
|
|
}
|
|
|
|
if (cp->in) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)cp->in);
|
|
|
|
}
|
|
|
|
if (cp->out) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)cp->out);
|
|
|
|
}
|
|
|
|
break;
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_NIL:
|
|
|
|
case PIC_TT_BOOL:
|
2015-05-27 12:48:38 -04:00
|
|
|
#if PIC_ENABLE_FLOAT
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_FLOAT:
|
2015-05-27 12:48:38 -04:00
|
|
|
#endif
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_INT:
|
|
|
|
case PIC_TT_CHAR:
|
|
|
|
case PIC_TT_EOF:
|
|
|
|
case PIC_TT_UNDEF:
|
2015-06-09 03:02:23 -04:00
|
|
|
case PIC_TT_INVALID:
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "logic flaw");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_mark(pic_state *pic, pic_value v)
|
|
|
|
{
|
|
|
|
struct pic_object *obj;
|
|
|
|
|
|
|
|
if (pic_vtype(v) != PIC_VTYPE_HEAP)
|
|
|
|
return;
|
|
|
|
obj = pic_obj_ptr(v);
|
|
|
|
|
|
|
|
gc_mark_object(pic, obj);
|
|
|
|
}
|
|
|
|
|
2015-01-18 22:14:46 -05:00
|
|
|
#define M(x) gc_mark_object(pic, (struct pic_object *)pic->x)
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_mark_global_symbols(pic_state *pic)
|
|
|
|
{
|
2015-07-01 16:36:09 -04:00
|
|
|
M(sQUOTE); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING);
|
|
|
|
M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); M(sSYNTAX_UNQUOTE_SPLICING);
|
|
|
|
M(sDEFINE_LIBRARY); M(sIMPORT); M(sEXPORT); M(sCOND_EXPAND);
|
|
|
|
M(sCALL); M(sGREF); M(sLREF); M(sCREF);
|
2015-01-20 03:38:34 -05:00
|
|
|
|
2015-07-01 16:36:09 -04:00
|
|
|
M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); M(uDEFINE_MACRO);
|
|
|
|
M(uDEFINE_LIBRARY); M(uIMPORT); M(uEXPORT); M(uCOND_EXPAND);
|
2015-07-01 19:50:10 -04:00
|
|
|
M(uCONS); M(uCAR); M(uCDR); M(uNILP); M(uSYMBOLP); M(uPAIRP);
|
|
|
|
M(uADD); M(uSUB); M(uMUL); M(uDIV); M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT);
|
2015-01-18 22:14:46 -05:00
|
|
|
}
|
|
|
|
|
2015-07-04 05:48:48 -04:00
|
|
|
#define P(x) gc_mark(pic, pic->x)
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_mark_system_procedures(pic_state *pic)
|
|
|
|
{
|
|
|
|
P(pCONS);
|
|
|
|
P(pCAR);
|
|
|
|
P(pCDR);
|
|
|
|
P(pNILP);
|
|
|
|
P(pSYMBOLP);
|
|
|
|
P(pPAIRP);
|
|
|
|
P(pNOT);
|
|
|
|
P(pADD);
|
|
|
|
P(pSUB);
|
|
|
|
P(pMUL);
|
|
|
|
P(pDIV);
|
|
|
|
P(pEQ);
|
|
|
|
P(pLT);
|
|
|
|
P(pLE);
|
2015-07-06 06:13:00 -04:00
|
|
|
P(pGT);
|
|
|
|
P(pGE);
|
2015-07-04 05:48:48 -04:00
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static void
|
|
|
|
gc_mark_phase(pic_state *pic)
|
|
|
|
{
|
|
|
|
pic_value *stack;
|
|
|
|
pic_callinfo *ci;
|
2014-09-18 01:50:01 -04:00
|
|
|
struct pic_proc **xhandler;
|
|
|
|
size_t j;
|
2015-06-09 05:31:46 -04:00
|
|
|
|
|
|
|
assert(pic->regs == NULL);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-06-08 08:04:04 -04:00
|
|
|
/* checkpoint */
|
|
|
|
if (pic->cp) {
|
2015-06-22 04:06:13 -04:00
|
|
|
gc_mark_object(pic, (struct pic_object *)pic->cp);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* stack */
|
|
|
|
for (stack = pic->stbase; stack != pic->sp; ++stack) {
|
|
|
|
gc_mark(pic, *stack);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* callinfo */
|
|
|
|
for (ci = pic->ci; ci != pic->cibase; --ci) {
|
2015-05-30 09:34:51 -04:00
|
|
|
if (ci->cxt) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)ci->cxt);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-09-18 01:50:01 -04:00
|
|
|
/* exception handlers */
|
|
|
|
for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)*xhandler);
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* arena */
|
|
|
|
for (j = 0; j < pic->arena_idx; ++j) {
|
|
|
|
gc_mark_object(pic, pic->arena[j]);
|
|
|
|
}
|
|
|
|
|
2015-01-20 03:38:34 -05:00
|
|
|
/* mark reserved symbols */
|
2015-01-18 22:14:46 -05:00
|
|
|
gc_mark_global_symbols(pic);
|
|
|
|
|
2015-07-04 05:48:48 -04:00
|
|
|
/* mark system procedures */
|
|
|
|
gc_mark_system_procedures(pic);
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* global variables */
|
2015-01-18 07:25:34 -05:00
|
|
|
if (pic->globals) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)pic->globals);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* macro objects */
|
2015-01-18 07:25:34 -05:00
|
|
|
if (pic->macros) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)pic->macros);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
2015-06-09 05:31:46 -04:00
|
|
|
/* attribute table */
|
|
|
|
if (pic->attrs) {
|
|
|
|
gc_mark_object(pic, (struct pic_object *)pic->attrs);
|
|
|
|
}
|
|
|
|
|
2014-09-18 01:50:01 -04:00
|
|
|
/* error object */
|
|
|
|
gc_mark(pic, pic->err);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-18 01:50:01 -04:00
|
|
|
/* features */
|
2014-09-09 12:41:10 -04:00
|
|
|
gc_mark(pic, pic->features);
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* library table */
|
|
|
|
gc_mark(pic, pic->libs);
|
2014-09-01 00:43:54 -04:00
|
|
|
|
2015-06-08 09:28:17 -04:00
|
|
|
/* parameter table */
|
|
|
|
gc_mark(pic, pic->ptable);
|
|
|
|
|
2015-06-09 05:31:46 -04:00
|
|
|
/* registries */
|
2014-09-24 23:12:52 -04:00
|
|
|
do {
|
2015-06-09 05:31:46 -04:00
|
|
|
struct pic_object *key;
|
|
|
|
pic_value val;
|
2015-06-24 18:14:29 -04:00
|
|
|
khiter_t it;
|
|
|
|
khash_t(reg) *h;
|
2015-06-09 05:31:46 -04:00
|
|
|
struct pic_reg *reg;
|
2014-09-24 23:12:52 -04:00
|
|
|
|
2015-06-09 05:31:46 -04:00
|
|
|
j = 0;
|
|
|
|
reg = pic->regs;
|
|
|
|
|
|
|
|
while (reg != NULL) {
|
2015-06-24 18:14:29 -04:00
|
|
|
h = ®->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);
|
2015-06-09 05:31:46 -04:00
|
|
|
if (gc_obj_is_marked(key) && gc_value_need_mark(val)) {
|
|
|
|
gc_mark(pic, val);
|
2014-09-24 23:12:52 -04:00
|
|
|
++j;
|
|
|
|
}
|
|
|
|
}
|
2015-06-09 05:31:46 -04:00
|
|
|
reg = reg->prev;
|
2014-09-24 23:12:52 -04:00
|
|
|
}
|
|
|
|
} while (j > 0);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_finalize_object(pic_state *pic, struct pic_object *obj)
|
|
|
|
{
|
|
|
|
switch (obj->tt) {
|
|
|
|
case PIC_TT_PAIR: {
|
|
|
|
break;
|
|
|
|
}
|
2015-05-30 09:34:51 -04:00
|
|
|
case PIC_TT_CXT: {
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_PROC: {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_VECTOR: {
|
|
|
|
pic_free(pic, ((struct pic_vector *)obj)->data);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_BLOB: {
|
|
|
|
pic_free(pic, ((struct pic_blob *)obj)->data);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_STRING: {
|
2015-05-27 10:34:40 -04:00
|
|
|
pic_rope_decref(pic, ((struct pic_string *)obj)->rope);
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_PORT: {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_ERROR: {
|
|
|
|
break;
|
|
|
|
}
|
2015-06-09 13:16:38 -04:00
|
|
|
case PIC_TT_ID: {
|
|
|
|
break;
|
|
|
|
}
|
2015-05-30 09:39:03 -04:00
|
|
|
case PIC_TT_ENV: {
|
2015-06-09 13:16:38 -04:00
|
|
|
struct pic_env *env = (struct pic_env *)obj;
|
2015-06-24 18:26:48 -04:00
|
|
|
kh_destroy(env, &env->map);
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_LIB: {
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_IREP: {
|
|
|
|
struct pic_irep *irep = (struct pic_irep *)obj;
|
|
|
|
pic_free(pic, irep->code);
|
|
|
|
pic_free(pic, irep->irep);
|
|
|
|
pic_free(pic, irep->pool);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_DATA: {
|
|
|
|
struct pic_data *data = (struct pic_data *)obj;
|
2015-06-22 14:02:12 -04:00
|
|
|
if (data->type->dtor) {
|
|
|
|
data->type->dtor(pic, data->data);
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_DICT: {
|
|
|
|
struct pic_dict *dict = (struct pic_dict *)obj;
|
2015-06-24 16:56:15 -04:00
|
|
|
kh_destroy(dict, &dict->hash);
|
2014-08-25 00:38:09 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
case PIC_TT_RECORD: {
|
|
|
|
break;
|
|
|
|
}
|
2015-01-18 20:59:35 -05:00
|
|
|
case PIC_TT_SYMBOL: {
|
2015-06-25 13:32:59 -04:00
|
|
|
pic_sym *sym = (pic_sym *)obj;
|
|
|
|
pic_free(pic, (void *)sym->cstr);
|
2015-01-18 20:59:35 -05:00
|
|
|
break;
|
|
|
|
}
|
2015-06-09 05:31:46 -04:00
|
|
|
case PIC_TT_REG: {
|
|
|
|
struct pic_reg *reg = (struct pic_reg *)obj;
|
2015-06-24 18:14:29 -04:00
|
|
|
kh_destroy(reg, ®->hash);
|
2015-06-09 05:31:46 -04:00
|
|
|
break;
|
|
|
|
}
|
2015-06-22 04:06:13 -04:00
|
|
|
case PIC_TT_CP: {
|
|
|
|
break;
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_NIL:
|
|
|
|
case PIC_TT_BOOL:
|
2015-05-27 12:48:38 -04:00
|
|
|
#if PIC_ENABLE_FLOAT
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_FLOAT:
|
2015-05-27 12:48:38 -04:00
|
|
|
#endif
|
2014-08-25 00:38:09 -04:00
|
|
|
case PIC_TT_INT:
|
|
|
|
case PIC_TT_CHAR:
|
|
|
|
case PIC_TT_EOF:
|
|
|
|
case PIC_TT_UNDEF:
|
2015-06-09 03:02:23 -04:00
|
|
|
case PIC_TT_INVALID:
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "logic flaw");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2015-01-20 03:38:34 -05:00
|
|
|
static void
|
|
|
|
gc_sweep_symbols(pic_state *pic)
|
|
|
|
{
|
2015-06-24 18:05:41 -04:00
|
|
|
khash_t(s) *h = &pic->syms;
|
|
|
|
khiter_t it;
|
|
|
|
pic_sym *sym;
|
|
|
|
|
|
|
|
for (it = kh_begin(h); it != kh_end(h); ++it) {
|
|
|
|
if (! kh_exist(h, it))
|
|
|
|
continue;
|
|
|
|
sym = kh_val(h, it);
|
|
|
|
if (! gc_obj_is_marked((struct pic_object *)sym)) {
|
|
|
|
kh_del(s, h, it);
|
2015-06-23 09:08:18 -04:00
|
|
|
}
|
2015-01-20 03:38:34 -05:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static void
|
|
|
|
gc_sweep_page(pic_state *pic, struct heap_page *page)
|
|
|
|
{
|
2015-07-16 02:45:01 -04:00
|
|
|
union header *bp, *p, *head = NULL, *tail = NULL;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
for (bp = page->basep; ; bp = bp->s.ptr) {
|
2015-07-16 03:13:30 -04:00
|
|
|
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) {
|
2015-07-16 02:45:01 -04:00
|
|
|
goto escape;
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-07-16 02:45:01 -04:00
|
|
|
if (gc_is_marked(p)) {
|
|
|
|
gc_unmark(p);
|
|
|
|
} else {
|
|
|
|
if (head == NULL) {
|
|
|
|
head = p;
|
|
|
|
} else {
|
|
|
|
tail->s.ptr = p;
|
|
|
|
}
|
|
|
|
tail = p;
|
|
|
|
tail->s.ptr = NULL; /* We can safely reuse ptr field of dead object */
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
escape:
|
|
|
|
|
|
|
|
/* free! */
|
2015-07-16 02:45:01 -04:00
|
|
|
while (head != NULL) {
|
|
|
|
p = head;
|
|
|
|
head = head->s.ptr;
|
|
|
|
gc_finalize_object(pic, (struct pic_object *)(p + 1));
|
|
|
|
heap_free(pic, p + 1);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
gc_sweep_phase(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct heap_page *page = pic->heap->pages;
|
2015-06-24 18:14:29 -04:00
|
|
|
khiter_t it;
|
|
|
|
khash_t(reg) *h;
|
2014-09-24 23:12:52 -04:00
|
|
|
|
2015-06-09 05:31:46 -04:00
|
|
|
/* registries */
|
|
|
|
while (pic->regs != NULL) {
|
2015-06-24 18:14:29 -04:00
|
|
|
h = &pic->regs->hash;
|
|
|
|
for (it = kh_begin(h); it != kh_end(h); ++it) {
|
|
|
|
if (! kh_exist(h, it))
|
|
|
|
continue;
|
|
|
|
if (! gc_obj_is_marked(kh_key(h, it))) {
|
|
|
|
kh_del(reg, h, it);
|
2014-09-24 23:12:52 -04:00
|
|
|
}
|
|
|
|
}
|
2015-06-09 05:31:46 -04:00
|
|
|
pic->regs = pic->regs->prev;
|
|
|
|
}
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-01-20 03:38:34 -05:00
|
|
|
gc_sweep_symbols(pic);
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
while (page) {
|
|
|
|
gc_sweep_page(pic, page);
|
|
|
|
page = page->next;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_gc_run(pic_state *pic)
|
|
|
|
{
|
2015-01-18 22:14:29 -05:00
|
|
|
if (! pic->gc_enable) {
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
gc_mark_phase(pic);
|
|
|
|
gc_sweep_phase(pic);
|
|
|
|
}
|
|
|
|
|
|
|
|
struct pic_object *
|
|
|
|
pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt)
|
|
|
|
{
|
|
|
|
struct pic_object *obj;
|
|
|
|
|
|
|
|
#if GC_STRESS
|
|
|
|
pic_gc_run(pic);
|
|
|
|
#endif
|
|
|
|
|
2015-07-16 02:38:37 -04:00
|
|
|
obj = (struct pic_object *)heap_alloc(pic, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (obj == NULL) {
|
2015-01-18 22:14:46 -05:00
|
|
|
pic_gc_run(pic);
|
2015-07-16 02:38:37 -04:00
|
|
|
obj = (struct pic_object *)heap_alloc(pic, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (obj == NULL) {
|
2015-07-16 02:38:37 -04:00
|
|
|
heap_morecore(pic);
|
|
|
|
obj = (struct pic_object *)heap_alloc(pic, size);
|
2014-08-25 00:38:09 -04:00
|
|
|
if (obj == NULL)
|
2014-09-16 12:02:27 -04:00
|
|
|
pic_panic(pic, "GC memory exhausted");
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
2015-07-16 02:38:37 -04:00
|
|
|
gc_unmark_object(obj);
|
2014-08-25 00:38:09 -04:00
|
|
|
obj->tt = tt;
|
|
|
|
|
|
|
|
return obj;
|
|
|
|
}
|
|
|
|
|
|
|
|
struct pic_object *
|
|
|
|
pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt)
|
|
|
|
{
|
|
|
|
struct pic_object *obj;
|
|
|
|
|
|
|
|
obj = pic_obj_alloc_unsafe(pic, size, tt);
|
|
|
|
|
|
|
|
gc_protect(pic, obj);
|
|
|
|
return obj;
|
|
|
|
}
|