SCM_EXPORT void
scm_call_continuation(ScmObj cont, ScmObj ret)
{
struct scm_continuation_frame *frame;
#if SCM_NESTED_CONTINUATION_ONLY
ScmObj dst;
#endif
DECLARE_INTERNAL_FUNCTION("scm_call_continuation");
frame = CONTINUATION_FRAME(cont);
if (frame != INVALID_CONTINUATION_OPAQUE
#if SCM_NESTED_CONTINUATION_ONLY
&& (dst = continuation_stack_unwind(cont), CONTINUATIONP(dst))
#endif
)
{
/* Don't refer cont because it may already be invalidated by
* continuation_stack_unwind(). */
exit_dynamic_extent(frame->dyn_ext);
frame->ret_val = ret;
LONGJMP(frame->c_env, scm_true);
/* NOTREACHED */
} else {
ERR("expired continuation");
}
}
object make_continuation(object the_frame, long* pc, object* sp_) {
object result;
long size = stack_top - sp_;
long i = size * sizeof(object);
gc_tmp1 = the_frame;
result = make_heap_object(CONTINUATION_TYPE,
sizeof(struct continuation_heap_structure) + i);
CONTINUATION_FRAME(result) = gc_tmp1;
CONTINUATION_PC(result) = pc;
if ((CONTINUATION_STACKSIZE(result) = size) != 0) {
memcpy(CONTINUATION_STACK(result), sp_, i);
}
return result;
}
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)();
}