152 lines
2.9 KiB
C
152 lines
2.9 KiB
C
#include "factor.h"
|
|
|
|
/* Stop-and-copy garbage collection using Cheney's algorithm. */
|
|
|
|
/* #define GC_DEBUG /* */
|
|
|
|
INLINE void gc_debug(char* msg, CELL x) {
|
|
#ifdef GC_DEBUG
|
|
printf("%s %d\n",msg,x);
|
|
#endif
|
|
}
|
|
|
|
/* Given a pointer to oldspace, copy it to newspace. */
|
|
void* copy_untagged_object(void* pointer, CELL size)
|
|
{
|
|
void* newpointer = allot(size);
|
|
memcpy(newpointer,pointer,size);
|
|
|
|
return newpointer;
|
|
}
|
|
|
|
/*
|
|
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
|
|
If the object has already been copied, return the forwarding
|
|
pointer address without copying anything; otherwise, install
|
|
a new forwarding pointer.
|
|
*/
|
|
void copy_object(CELL* handle)
|
|
{
|
|
CELL pointer = *handle;
|
|
CELL tag = TAG(pointer);
|
|
CELL header, newpointer;
|
|
|
|
if(tag == FIXNUM_TYPE)
|
|
{
|
|
/* convinience */
|
|
gc_debug("FIXNUM",pointer);
|
|
return;
|
|
}
|
|
|
|
if(in_zone(active,pointer))
|
|
critical_error("copy_object given newspace ptr",pointer);
|
|
|
|
header = get(UNTAG(pointer));
|
|
|
|
if(TAG(header) == GC_COLLECTED)
|
|
{
|
|
newpointer = UNTAG(header);
|
|
gc_debug("FORWARDING",newpointer);
|
|
}
|
|
else if(TAG(pointer) == GC_COLLECTED)
|
|
{
|
|
critical_error("asked to copy forwarding pointer",pointer);
|
|
newpointer = 0; /* to shut up gcc */
|
|
}
|
|
else
|
|
{
|
|
gc_debug("copy_object",pointer);
|
|
newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
|
|
object_size(pointer));
|
|
put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
|
|
}
|
|
|
|
if(tag == GC_COLLECTED)
|
|
critical_error("installing forwarding pointer in newspace",newpointer);
|
|
|
|
*handle = RETAG(newpointer,tag);
|
|
}
|
|
|
|
void collect_object(void)
|
|
{
|
|
CELL size = untagged_object_size(scan);
|
|
gc_debug("collect_object",scan);
|
|
gc_debug("collect_object size=",size);
|
|
|
|
switch(untag_header(get(scan)))
|
|
{
|
|
case WORD_TYPE:
|
|
collect_word((WORD*)scan);
|
|
break;
|
|
case ARRAY_TYPE:
|
|
collect_array((ARRAY*)scan);
|
|
break;
|
|
case VECTOR_TYPE:
|
|
collect_vector((VECTOR*)scan);
|
|
break;
|
|
case SBUF_TYPE:
|
|
collect_sbuf((SBUF*)scan);
|
|
break;
|
|
case PORT_TYPE:
|
|
collect_port((PORT*)scan);
|
|
break;
|
|
}
|
|
|
|
scan += size;
|
|
}
|
|
|
|
void collect_next(void)
|
|
{
|
|
gc_debug("collect_next",scan);
|
|
gc_debug("collect_next header",get(scan));
|
|
switch(TAG(get(scan)))
|
|
{
|
|
case HEADER_TYPE:
|
|
collect_object();
|
|
break;
|
|
default:
|
|
copy_object((CELL*)scan);
|
|
scan += CELLS;
|
|
break;
|
|
}
|
|
}
|
|
|
|
void collect_roots(void)
|
|
{
|
|
int i;
|
|
|
|
CELL ptr;
|
|
|
|
gc_debug("collect_roots",scan);
|
|
/* these two must be the first in the heap */
|
|
copy_object(&F);
|
|
gc_debug("f",F);
|
|
copy_object(&T);
|
|
gc_debug("t",T);
|
|
copy_object(&callframe);
|
|
copy_bignum_constants();
|
|
|
|
for(ptr = ds_bot; ptr < ds; ptr += CELLS)
|
|
copy_object((void*)ptr);
|
|
|
|
for(ptr = cs_bot; ptr < cs; ptr += CELLS)
|
|
copy_object((void*)ptr);
|
|
|
|
for(i = 0; i < USER_ENV; i++)
|
|
copy_object(&userenv[i]);
|
|
}
|
|
|
|
void primitive_gc(void)
|
|
{
|
|
flip_zones();
|
|
scan = active->here = active->base;
|
|
collect_roots();
|
|
collect_io_tasks();
|
|
while(scan < active->here)
|
|
{
|
|
gc_debug("scan loop",scan);
|
|
collect_next();
|
|
}
|
|
gc_debug("gc done",0);
|
|
}
|