mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
244 lines
7 KiB
C
244 lines
7 KiB
C
/* gc.c -- simple mark&sweep garbage collector */
|
|
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
|
/* BSD-style license: http://synthcode.com/license.txt */
|
|
|
|
#include "chibi/sexp.h"
|
|
|
|
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
|
|
#define SEXP_MAXIMUM_HEAP_SIZE 0
|
|
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair))
|
|
#define SEXP_GROW_HEAP_RATIO 0.7
|
|
|
|
#define sexp_heap_align(n) sexp_align(n, 4)
|
|
|
|
typedef struct sexp_heap *sexp_heap;
|
|
|
|
struct sexp_heap {
|
|
sexp_uint_t size;
|
|
sexp free_list;
|
|
sexp_heap next;
|
|
char *data;
|
|
};
|
|
|
|
static sexp_heap heap;
|
|
|
|
#if USE_DEBUG_GC
|
|
static sexp* stack_base;
|
|
#endif
|
|
|
|
extern sexp continuation_resumer, final_resumer;
|
|
|
|
static sexp_heap sexp_heap_last (sexp_heap h) {
|
|
while (h->next) h = h->next;
|
|
return h;
|
|
}
|
|
|
|
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
|
sexp_uint_t res, *len_ptr;
|
|
sexp t;
|
|
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT))
|
|
return sexp_heap_align(1);
|
|
t = &(sexp_types[sexp_pointer_tag(x)]);
|
|
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));
|
|
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
|
|
return res;
|
|
}
|
|
|
|
void sexp_mark (sexp x) {
|
|
sexp_uint_t *len_ptr;
|
|
sexp_sint_t i, len;
|
|
sexp t, *p;
|
|
struct sexp_gc_var_t *saves;
|
|
loop:
|
|
if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x))
|
|
return;
|
|
sexp_gc_mark(x) = 1;
|
|
if (sexp_contextp(x))
|
|
for (saves=sexp_context_saves(x); saves; saves=saves->next)
|
|
if (saves->var) sexp_mark(*(saves->var));
|
|
t = &(sexp_types[sexp_pointer_tag(x)]);
|
|
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
|
|
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t));
|
|
len = sexp_type_field_len_base(t)
|
|
+ len_ptr[0]*sexp_type_field_len_scale(t) - 1;
|
|
if (len >= 0) {
|
|
for (i=0; i<len; i++)
|
|
sexp_mark(p[i]);
|
|
x = p[len];
|
|
goto loop;
|
|
}
|
|
}
|
|
|
|
#if USE_DEBUG_GC
|
|
int stack_references_pointer_p (sexp ctx, sexp x) {
|
|
sexp *p;
|
|
for (p=(&x)+1; p<stack_base; p++)
|
|
if (*p == x)
|
|
return 1;
|
|
return 0;
|
|
}
|
|
#else
|
|
#define stack_references_pointer_p(ctx, x) 0
|
|
#endif
|
|
|
|
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
|
size_t freed, max_freed=0, sum_freed=0, size;
|
|
sexp_heap h = heap;
|
|
sexp p, q, r;
|
|
char *end;
|
|
/* scan over the whole heap */
|
|
for ( ; h; h=h->next) {
|
|
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
|
|
q = h->free_list;
|
|
end = (char*)h->data + h->size;
|
|
while (((char*)p) < end) {
|
|
/* find the preceding and succeeding free list pointers */
|
|
for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r))
|
|
;
|
|
if (r == p) {
|
|
p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
|
|
continue;
|
|
}
|
|
size = sexp_heap_align(sexp_allocated_bytes(p));
|
|
if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
|
|
sum_freed += size;
|
|
if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
|
|
&& (q != h->free_list)) {
|
|
/* merge q with p */
|
|
if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
|
|
/* ... and with r */
|
|
sexp_cdr(q) = sexp_cdr(r);
|
|
freed = (sexp_uint_t)sexp_car(q) + size + (sexp_uint_t)sexp_car(r);
|
|
p = (sexp) (((char*)p)+size+(sexp_uint_t)sexp_car(r));
|
|
} else {
|
|
freed = (sexp_uint_t)sexp_car(q) + size;
|
|
p = (sexp) (((char*)p)+size);
|
|
}
|
|
sexp_car(q) = (sexp)freed;
|
|
} else {
|
|
if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
|
|
sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r));
|
|
sexp_cdr(p) = sexp_cdr(r);
|
|
sexp_cdr(q) = p;
|
|
freed = size + (sexp_uint_t)sexp_car(r);
|
|
} else {
|
|
sexp_car(p) = (sexp)size;
|
|
sexp_cdr(p) = r;
|
|
sexp_cdr(q) = p;
|
|
freed = size;
|
|
}
|
|
sexp_pointer_tag(p) = SEXP_PAIR;
|
|
p = (sexp) (((char*)p)+freed);
|
|
}
|
|
if (freed > max_freed)
|
|
max_freed = freed;
|
|
} else {
|
|
sexp_gc_mark(p) = 0;
|
|
p = (sexp) (((char*)p)+size);
|
|
}
|
|
}
|
|
}
|
|
sum_freed_ptr[0] = sum_freed;
|
|
return sexp_make_integer(max_freed);
|
|
}
|
|
|
|
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
|
sexp res;
|
|
int i;
|
|
sexp_mark(continuation_resumer);
|
|
sexp_mark(final_resumer);
|
|
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
|
sexp_mark(sexp_symbol_table[i]);
|
|
sexp_mark(ctx);
|
|
res = sexp_sweep(ctx, sum_freed);
|
|
return res;
|
|
}
|
|
|
|
sexp_heap sexp_make_heap (size_t size) {
|
|
sexp free, next;
|
|
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
|
|
if (! h) {
|
|
fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size);
|
|
exit(70);
|
|
}
|
|
h->size = size;
|
|
h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data));
|
|
free = h->free_list = (sexp) h->data;
|
|
h->next = NULL;
|
|
next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair)));
|
|
sexp_pointer_tag(free) = SEXP_PAIR;
|
|
sexp_car(free) = 0; /* actually sexp_sizeof(pair) */
|
|
sexp_cdr(free) = next;
|
|
sexp_pointer_tag(next) = SEXP_PAIR;
|
|
sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair)));
|
|
sexp_cdr(next) = SEXP_NULL;
|
|
return h;
|
|
}
|
|
|
|
int sexp_grow_heap (sexp ctx, size_t size) {
|
|
size_t cur_size, new_size;
|
|
sexp_heap h = sexp_heap_last(heap);
|
|
cur_size = h->size;
|
|
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
|
|
h->next = sexp_make_heap(new_size);
|
|
return (h->next != NULL);
|
|
}
|
|
|
|
void* sexp_try_alloc (sexp ctx, size_t size) {
|
|
sexp ls1, ls2, ls3;
|
|
sexp_heap h;
|
|
for (h=heap; h; h=h->next) {
|
|
ls1 = h->free_list;
|
|
ls2 = sexp_cdr(ls1);
|
|
while (sexp_pairp(ls2)) {
|
|
if ((sexp_uint_t)sexp_car(ls2) >= size) {
|
|
if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
|
|
ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */
|
|
sexp_pointer_tag(ls3) = SEXP_PAIR;
|
|
sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size);
|
|
sexp_cdr(ls3) = sexp_cdr(ls2);
|
|
sexp_cdr(ls1) = ls3;
|
|
} else { /* take the whole chunk */
|
|
sexp_cdr(ls1) = sexp_cdr(ls2);
|
|
}
|
|
bzero((void*)ls2, size);
|
|
return ls2;
|
|
}
|
|
ls1 = ls2;
|
|
ls2 = sexp_cdr(ls2);
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
void* sexp_alloc (sexp ctx, size_t size) {
|
|
void *res;
|
|
size_t max_freed, sum_freed;
|
|
sexp_heap h;
|
|
size = sexp_heap_align(size);
|
|
res = sexp_try_alloc(ctx, size);
|
|
if (! res) {
|
|
max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed));
|
|
h = sexp_heap_last(heap);
|
|
if (((max_freed < size)
|
|
|| ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO))))
|
|
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
|
|
sexp_grow_heap(ctx, size);
|
|
res = sexp_try_alloc(ctx, size);
|
|
if (! res) {
|
|
fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size);
|
|
exit(70);
|
|
}
|
|
}
|
|
return res;
|
|
}
|
|
|
|
void sexp_gc_init () {
|
|
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
|
heap = sexp_make_heap(size);
|
|
#if USE_DEBUG_GC
|
|
/* the +32 is a hack, but this is just for debugging anyway */
|
|
stack_base = ((sexp*)&size) + 32;
|
|
#endif
|
|
}
|
|
|