mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
128 lines
3.7 KiB
C
128 lines
3.7 KiB
C
/* gc.c -- simple garbage collector */
|
|
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
|
/* BSD-style license: http://synthcode.com/license.txt */
|
|
|
|
#include <sexp.h>
|
|
|
|
#define SEXP_INITIAL_HEAP_SIZE 10000000
|
|
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
|
|
|
|
static char* sexp_heap;
|
|
static char* sexp_heap_end;
|
|
static sexp sexp_free_list;
|
|
|
|
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
|
switch (sexp_tag(x)) {
|
|
case SEXP_PAIR: return sexp_sizeof(pair);
|
|
case SEXP_SYMBOL: return sexp_sizeof(symbol);
|
|
case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x);
|
|
case SEXP_VECTOR:
|
|
return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp));
|
|
case SEXP_FLONUM: return sexp_sizeof(flonum);
|
|
case SEXP_BIGNUM: return sexp_sizeof(bignum);
|
|
case SEXP_IPORT:
|
|
case SEXP_OPORT: return sexp_sizeof(port);
|
|
case SEXP_EXCEPTION: return sexp_sizeof(exception);
|
|
case SEXP_PROCEDURE: return sexp_sizeof(procedure);
|
|
case SEXP_MACRO: return sexp_sizeof(macro);
|
|
case SEXP_SYNCLO: return sexp_sizeof(synclo);
|
|
case SEXP_ENV: return sexp_sizeof(env);
|
|
case SEXP_BYTECODE: return sexp_sizeof(bytecode)+sexp_bytecode_length(x);
|
|
case SEXP_CORE: return sexp_sizeof(core);
|
|
case SEXP_OPCODE: return sexp_sizeof(opcode);
|
|
case SEXP_LAMBDA: return sexp_sizeof(lambda);
|
|
case SEXP_CND: return sexp_sizeof(cnd);
|
|
case SEXP_REF: return sexp_sizeof(ref);
|
|
case SEXP_SET: return sexp_sizeof(set);
|
|
case SEXP_SEQ: return sexp_sizeof(seq);
|
|
case SEXP_LIT: return sexp_sizeof(lit);
|
|
case SEXP_CONTEXT: return sexp_sizeof(context);
|
|
default: return 0;
|
|
}
|
|
}
|
|
|
|
void *sexp_alloc (sexp ctx, size_t size) {
|
|
sexp ls1, ls2, ls3;
|
|
try_alloc:
|
|
ls1=sexp_free_list;
|
|
for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
|
|
if (sexp_car(ls2) >= size) {
|
|
if (sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) {
|
|
ls3 = (sexp) (((char*)ls2)+size);
|
|
sexp_car(ls3) = (sexp) (sexp_car(ls2) - size);
|
|
sexp_cdr(ls3) = sexp_cdr(ls2);
|
|
sexp_cdr(ls1) = sexp_cdr(ls3);
|
|
} else {
|
|
sexp_cdr(ls1) = sexp_cdr(ls2);
|
|
}
|
|
return ls2;
|
|
}
|
|
if (sexp_unbox_integer(sexp_gc(ctx)) >= size) {
|
|
goto try_alloc;
|
|
} else {
|
|
fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size);
|
|
exit(70);
|
|
}
|
|
}
|
|
|
|
void sexp_mark (sexp x) {
|
|
sexp *data;
|
|
sexp_uint_t i;
|
|
loop:
|
|
if ((! sexp_pointerp(x)) || sexp_mark(x))
|
|
return;
|
|
sexp_gc_mark(x) = 1;
|
|
switch (sexp_tag(x)) {
|
|
case SEXP_PAIR:
|
|
sexp_mark(sexp_car(x));
|
|
x = sexp_cdr(x);
|
|
goto loop;
|
|
case SEXP_VECTOR:
|
|
data = sexp_vector_data(x);
|
|
for (i=sexp_vector_length(x)-1; i>=0; i--)
|
|
sexp_mark(data[i]);
|
|
}
|
|
}
|
|
|
|
sexp sexp_sweep () {
|
|
sexp_uint_t freed=0, size;
|
|
sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2;
|
|
while (p<sexp_heap_end) {
|
|
for (f2=sexp_cdr(f1); sexp_pairp(f2) && (f2 < p); f1=f2, f2=sexp_cdr(f2))
|
|
;
|
|
size = sexp_allocated_bytes(p);
|
|
if (! sexp_mark(p)) {
|
|
freed += size;
|
|
sexp_car(p) = (sexp)size;
|
|
sexp_cdr(p) = f;
|
|
f = p;
|
|
} else {
|
|
sexp_mark(p) = 0;
|
|
}
|
|
p += size;
|
|
}
|
|
sexp_free_list = f;
|
|
return sexp_make_integer(freed);
|
|
}
|
|
|
|
sexp sexp_gc (sexp ctx) {
|
|
int i;
|
|
sexp ctx2, stack = sexp_context_stack(ctx);
|
|
for (i=0; i<sexp_context_top(ctx); i++)
|
|
sexp_mark(stack[i]);
|
|
for ( ; ctx; ctx=sexp_context_(ctx)) {
|
|
sexp_gc_mark(ctx) = 1;
|
|
sexp_gc_mark(sexp_context_bc(ctx)) = 1;
|
|
sexp_mark(sexp_context_env(ctx));
|
|
}
|
|
return sexp_sweep();
|
|
}
|
|
|
|
void sexp_gc_init () {
|
|
sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE);
|
|
sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE;
|
|
sexp_free_list = sexp_heap;
|
|
sexp_car(sexp_free_list) = SEXP_INITIAL_HEAP_SIZE;
|
|
sexp_cdr(sexp_free_list) = SEXP_NULL;
|
|
}
|
|
|