factor/native/memory.c

#include "factor.h"

CELL object_size(CELL tagged)
{
	if(tagged == F)
		return 0;
	else if(TAG(tagged) == FIXNUM_TYPE)
		return 0;
	else
		return untagged_object_size(UNTAG(tagged));
}

CELL untagged_object_size(CELL pointer)
{
	CELL size;

	switch(untag_header(get(pointer)))
	{
	case WORD_TYPE:
		size = sizeof(F_WORD);
		break;
	case ARRAY_TYPE:
	case TUPLE_TYPE:
	case BIGNUM_TYPE:
	case BYTE_ARRAY_TYPE:
	case QUOTATION_TYPE:
		size = array_size(array_capacity((F_ARRAY*)(pointer)));
		break;
	case HASHTABLE_TYPE:
		size = sizeof(F_HASHTABLE);
		break;
	case VECTOR_TYPE:
		size = sizeof(F_VECTOR);
		break;
	case STRING_TYPE:
		size = string_size(string_capacity((F_STRING*)(pointer)));
		break;
	case SBUF_TYPE:
		size = sizeof(F_SBUF);
		break;
	case RATIO_TYPE:
		size = sizeof(F_RATIO);
		break;
	case FLOAT_TYPE:
		size = sizeof(F_FLOAT);
		break;
	case COMPLEX_TYPE:
		size = sizeof(F_COMPLEX);
		break;
	case DLL_TYPE:
		size = sizeof(DLL);
		break;
	case ALIEN_TYPE:
		size = sizeof(ALIEN);
		break;
	case WRAPPER_TYPE:
		size = sizeof(F_WRAPPER);
		break;
	default:
		critical_error("Cannot determine untagged_object_size",pointer);
		size = -1;/* can't happen */
		break;
	}

	return align8(size);
}

void primitive_type(void)
{
	drepl(tag_fixnum(type_of(dpeek())));
}

void primitive_tag(void)
{
	drepl(tag_fixnum(TAG(dpeek())));
}

void primitive_slot(void)
{
	F_FIXNUM slot = untag_fixnum_fast(dpop());
	CELL obj = UNTAG(dpop());
	dpush(get(SLOT(obj,slot)));
}

void primitive_set_slot(void)
{
	F_FIXNUM slot = untag_fixnum_fast(dpop());
	CELL obj = UNTAG(dpop());
	CELL value = dpop();
	put(SLOT(obj,slot),value);
	write_barrier(obj);
}

void primitive_integer_slot(void)
{
	F_FIXNUM slot = untag_fixnum_fast(dpop());
	CELL obj = UNTAG(dpop());
	dpush(tag_integer(get(SLOT(obj,slot))));
}

void primitive_set_integer_slot(void)
{
	F_FIXNUM slot = untag_fixnum_fast(dpop());
	CELL obj = UNTAG(dpop());
	F_FIXNUM value = to_fixnum(dpop());
	put(SLOT(obj,slot),value);
}

void primitive_address(void)
{
	drepl(tag_bignum(s48_cell_to_bignum(dpeek())));
}

void primitive_size(void)
{
	drepl(tag_fixnum(object_size(dpeek())));
}

CELL clone(CELL obj)
{
	CELL size = object_size(obj);
	CELL tag = TAG(obj);
	void *new_obj = allot(size);
	return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
}

void primitive_clone(void)
{
	maybe_gc(0);
	drepl(clone(dpeek()));
}

void primitive_room(void)
{
	F_ARRAY *a = array(ARRAY_TYPE,gen_count,F);
	int gen;
	box_unsigned_cell(compiling.limit - compiling.here);
	box_unsigned_cell(compiling.limit - compiling.base);
	box_unsigned_cell(cards_end - cards);
	box_unsigned_cell(prior.limit - prior.base);
	for(gen = 0; gen < gen_count; gen++)
	{
		ZONE *z = &generations[gen];
		put(AREF(a,gen),make_array_2(tag_cell(z->limit - z->here),
			tag_cell(z->limit - z->base)));
	}
	dpush(tag_object(a));
}

/* Disables GC and activates next-object ( -- obj ) primitive */
void primitive_begin_scan(void)
{
	garbage_collection(TENURED);
	heap_scan_ptr = tenured.base;
	heap_scan = true;
}

/* Push object at heap scan cursor and advance; pushes f when done */
void primitive_next_object(void)
{
	CELL value = get(heap_scan_ptr);
	CELL obj = heap_scan_ptr;
	CELL type;

	if(!heap_scan)
		general_error(ERROR_HEAP_SCAN,F,F,true);

	if(heap_scan_ptr >= tenured.here)
	{
		dpush(F);
		return;
	}
	
	type = untag_header(value);
	heap_scan_ptr += untagged_object_size(heap_scan_ptr);

	if(type <= HEADER_TYPE)
		dpush(RETAG(obj,type));
	else
		dpush(RETAG(obj,OBJECT_TYPE));
}

/* Re-enables GC */
void primitive_end_scan(void)
{
	heap_scan = false;
}