object make_table(long capacity) {
object bindings = make_vector(capacity*2, false_object);
long size = sizeof(struct table_heap_structure);
object *ve, v;
PUSH_GC_PROTECT(bindings);
v = make_heap_object(TABLE_TYPE,size);
TABLE_COUNT(v) = 0;
VECTOR_TAG(bindings) = false_object;
/* FIX ME */
TABLE_BINDINGS(v) = bindings;
POP_GC_PROTECT(1);
return v;
}
static void primop_table_p(long argc) {
if (TABLE_P(*sp) && FALSE_P(VECTOR_TAG(TABLE_BINDINGS(*sp)))) return;
*sp = false_object;
}
void garbage_collect(long min_space) {
char *p;
object **gcp;
object *op;
long i, max, count;
int old_interrupt;
if (*will_gc_hook) (*will_gc_hook)();
old_interrupt = enable_interrupts(0);
/* switch heap space */
gc_count++;
/* printf("[GC]\n"); */
heap += heap_size;
if (heap >= max_heap)
heap = min_memory;
heap_pointer = heap;
heap_end = heap + heap_size;
/* migrate objects */
count = gc_root_stack_pointer - gc_root_stack_begin;
migrate_object(gc_root_stack_buffer);
if (FORWARDED_P(gc_root_stack_buffer)) gc_root_stack_buffer = FORWARDED_POINTER(gc_root_stack_buffer);
gc_root_stack_begin = (object **)BUFFER_DATA(gc_root_stack_buffer);
gc_root_stack_end = gc_root_stack_begin + GC_ROOT_STACK_MAX;
gc_root_stack_pointer = gc_root_stack_begin + count;
gcp = gc_root_stack_begin;
for (i=0; i<count; i++)
migrate_object(*gcp[i]);
for (op = sp; op < stack_top; op++)
migrate_object(*op);
/* eliminate forwarding pointers */
gcp = gc_root_stack_begin;
for (i=0; i<count; i++) {
object o = *gcp[i];
if (FORWARDED_P(o))
*gcp[i] = FORWARDED_POINTER(o);
}
for (op = sp; op < stack_top; op++) {
object o = *op;
if (FORWARDED_P(o))
*op = FORWARDED_POINTER(o);
}
p = heap;
while (p < heap_pointer) {
object *q, obj, o;
obj = (object)p;
switch (POINTER_TYPE(obj)) {
case PAIR_TYPE:
o = CAR(obj); if (FORWARDED_P(o)) CAR(obj) = FORWARDED_POINTER(o);
o = CDR(obj); if (FORWARDED_P(o)) CDR(obj) = FORWARDED_POINTER(o);
break;
case WEAK_TYPE:
if (FORWARDED_P(WEAK_VALUE(obj))) {
WEAK_BOUND(obj) = 1;
} else {
WEAK_BOUND(obj) = 0;
migrate_object(WEAK_VALUE(obj));
}
o = WEAK_VALUE(obj); if (FORWARDED_P(o)) WEAK_VALUE(obj) = FORWARDED_POINTER(o);
break;
case SYMBOL_TYPE:
o = SYMBOL_VALUE(obj); if (FORWARDED_P(o)) SYMBOL_VALUE(obj) = FORWARDED_POINTER(o);
break;
case VECTOR_TYPE:
max = VECTOR_LENGTH(obj);
q = VECTOR_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
o = VECTOR_TAG(obj); if (FORWARDED_P(o)) VECTOR_TAG(obj) = FORWARDED_POINTER(o);
break;
case PROCEDURE_TYPE:
o = PROC_MODULE(obj); if (FORWARDED_P(o)) PROC_MODULE(obj) = FORWARDED_POINTER(o);
break;
case FRAME_TYPE:
o = FRAME_PREVIOUS(obj); if (FORWARDED_P(o)) FRAME_PREVIOUS(obj) = FORWARDED_POINTER(o);
o = FRAME_ENV(obj); if (FORWARDED_P(o)) FRAME_ENV(obj) = FORWARDED_POINTER(o);
max = (POINTER_LENGTH(obj) - sizeof(struct frame_heap_structure))/sizeof(long);
q = FRAME_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case CLOSURE_TYPE:
o = CLOSURE_PROC(obj); if (FORWARDED_P(o)) CLOSURE_PROC(obj) = FORWARDED_POINTER(o);
o = CLOSURE_ENV(obj); if (FORWARDED_P(o)) CLOSURE_ENV(obj) = FORWARDED_POINTER(o);
break;
case CONTINUATION_TYPE:
o = CONTINUATION_FRAME(obj); if (FORWARDED_P(o)) CONTINUATION_FRAME(obj) = FORWARDED_POINTER(o);
max = CONTINUATION_STACKSIZE(obj);
q = CONTINUATION_STACK(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case SYMBOLTABLE_TYPE:
o = SYMBOLTABLE_MAPPINGS(obj); if (FORWARDED_P(o)) SYMBOLTABLE_MAPPINGS(obj) = FORWARDED_POINTER(o);
break;
case PORT_TYPE:
o = PORT_BUFFER(obj); if (FORWARDED_P(o)) PORT_BUFFER(obj) = FORWARDED_POINTER(o);
break;
default:
fatal_error("Unknown pointer type: heap.c#garbage_collect(): %p\n", obj);
return;
}
p += POINTER_LENGTH(obj);
}
/* finalization of ports */
close_stale_ports();
fix_runtime_pointers();
/* Finish up */
enable_interrupts(old_interrupt);
i = heap_size - (heap_pointer - heap);
if (i < min_space)
fatal_error("out of heap space: %d\n", i);
if (*did_gc_hook) (*did_gc_hook)();
}