factor/vm/types.c

#include "master.h"

/* FFI calls this */
void box_boolean(bool value)
{
	dpush(value ? T : F);
}

/* FFI calls this */
bool to_boolean(CELL value)
{
	return value != F;
}

CELL clone(CELL object)
{
	CELL size = object_size(object);
	if(size == 0)
		return object;
	else
	{
		REGISTER_ROOT(object);
		void *new_obj = allot_object(type_of(object),size);
		UNREGISTER_ROOT(object);

		CELL tag = TAG(object);
		memcpy(new_obj,(void*)UNTAG(object),size);
		return RETAG(new_obj,tag);
	}
}

DEFINE_PRIMITIVE(clone)
{
	drepl(clone(dpeek()));
}

F_WORD *allot_word(CELL vocab, CELL name)
{
	REGISTER_ROOT(vocab);
	REGISTER_ROOT(name);
	F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
	UNREGISTER_ROOT(name);
	UNREGISTER_ROOT(vocab);

	word->hashcode = tag_fixnum((rand() << 16) ^ rand());
	word->vocabulary = vocab;
	word->name = name;
	word->def = userenv[UNDEFINED_ENV];
	word->props = F;
	word->counter = tag_fixnum(0);
	word->compiledp = F;
	word->profiling = NULL;
	word->code = NULL;

	REGISTER_UNTAGGED(word);
	default_word_code(word,true);
	UNREGISTER_UNTAGGED(word);

	REGISTER_UNTAGGED(word);
	update_word_xt(word);
	UNREGISTER_UNTAGGED(word);

	return word;
}

/* <word> ( name vocabulary -- word ) */
DEFINE_PRIMITIVE(word)
{
	CELL vocab = dpop();
	CELL name = dpop();
	dpush(tag_object(allot_word(vocab,name)));
}

/* word-xt ( word -- start end ) */
DEFINE_PRIMITIVE(word_xt)
{
	F_WORD *word = untag_word(dpop());
	F_COMPILED *code = word->code;
	dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
	dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
}

DEFINE_PRIMITIVE(wrapper)
{
	F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
	wrapper->object = dpeek();
	drepl(tag_object(wrapper));
}

/* Arrays */

/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array_internal(CELL type, CELL capacity)
{
	F_ARRAY *array = allot_object(type,array_size(capacity));
	array->capacity = tag_fixnum(capacity);
	return array;
}

/* make a new array with an initial element */
F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
	int i;
	REGISTER_ROOT(fill);
	F_ARRAY* array = allot_array_internal(type, capacity);
	UNREGISTER_ROOT(fill);
	if(fill == 0)
		memset((void*)AREF(array,0),'\0',capacity * CELLS);
	else
	{
		/* No need for write barrier here. Either the object is in
		the nursery, or it was allocated directly in tenured space
		and the write barrier is already hit for us in that case. */
		for(i = 0; i < capacity; i++)
			put(AREF(array,i),fill);
	}
	return array;
}

/* push a new array on the stack */
DEFINE_PRIMITIVE(array)
{
	CELL initial = dpop();
	CELL size = unbox_array_size();
	dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}

CELL allot_array_1(CELL obj)
{
	REGISTER_ROOT(obj);
	F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
	UNREGISTER_ROOT(obj);
	set_array_nth(a,0,obj);
	return tag_object(a);
}

CELL allot_array_2(CELL v1, CELL v2)
{
	REGISTER_ROOT(v1);
	REGISTER_ROOT(v2);
	F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
	UNREGISTER_ROOT(v2);
	UNREGISTER_ROOT(v1);
	set_array_nth(a,0,v1);
	set_array_nth(a,1,v2);
	return tag_object(a);
}

CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
	REGISTER_ROOT(v1);
	REGISTER_ROOT(v2);
	REGISTER_ROOT(v3);
	REGISTER_ROOT(v4);
	F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
	UNREGISTER_ROOT(v4);
	UNREGISTER_ROOT(v3);
	UNREGISTER_ROOT(v2);
	UNREGISTER_ROOT(v1);
	set_array_nth(a,0,v1);
	set_array_nth(a,1,v2);
	set_array_nth(a,2,v3);
	set_array_nth(a,3,v4);
	return tag_object(a);
}

F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
{
	int i;
	F_ARRAY* new_array;

	CELL to_copy = array_capacity(array);
	if(capacity < to_copy)
		to_copy = capacity;

	REGISTER_UNTAGGED(array);
	REGISTER_ROOT(fill);

	new_array = allot_array_internal(untag_header(array->header),capacity);

	UNREGISTER_ROOT(fill);
	UNREGISTER_UNTAGGED(array);

	memcpy(new_array + 1,array + 1,to_copy * CELLS);

	for(i = to_copy; i < capacity; i++)
		put(AREF(new_array,i),fill);

	return new_array;
}

DEFINE_PRIMITIVE(resize_array)
{
	F_ARRAY* array = untag_array(dpop());
	CELL capacity = unbox_array_size();
	dpush(tag_object(reallot_array(array,capacity,F)));
}

F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
{
	REGISTER_ROOT(elt);

	if(*result_count == array_capacity(result))
	{
		result = reallot_array(result,
			*result_count * 2,F);
	}

	UNREGISTER_ROOT(elt);
	set_array_nth(result,*result_count,elt);
	(*result_count)++;

	return result;
}

F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
{
	REGISTER_UNTAGGED(elts);

	CELL elts_size = array_capacity(elts);
	CELL new_size = *result_count + elts_size;

	if(new_size >= array_capacity(result))
		result = reallot_array(result,new_size * 2,F);

	UNREGISTER_UNTAGGED(elts);

	write_barrier((CELL)result);

	memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);

	*result_count += elts_size;

	return result;
}

/* Byte arrays */

/* must fill out array before next GC */
F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
{
	F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
		byte_array_size(size));
	array->capacity = tag_fixnum(size);
	return array;
}

/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
	F_BYTE_ARRAY *array = allot_byte_array_internal(size);
	memset(array + 1,0,size);
	return array;
}

/* push a new byte array on the stack */
DEFINE_PRIMITIVE(byte_array)
{
	CELL size = unbox_array_size();
	dpush(tag_object(allot_byte_array(size)));
}

F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
	CELL to_copy = array_capacity(array);
	if(capacity < to_copy)
		to_copy = capacity;

	REGISTER_UNTAGGED(array);
	F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
	UNREGISTER_UNTAGGED(array);

	memcpy(new_array + 1,array + 1,to_copy);

	return new_array;
}

DEFINE_PRIMITIVE(resize_byte_array)
{
	F_BYTE_ARRAY* array = untag_byte_array(dpop());
	CELL capacity = unbox_array_size();
	dpush(tag_object(reallot_byte_array(array,capacity)));
}

F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
{
	if(*result_count == byte_array_capacity(result))
	{
		result = reallot_byte_array(result,*result_count * 2);
	}

	bput(BREF(result,*result_count),elt);
	*result_count++;

	return result;
}

F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
{
	CELL new_size = *result_count + len;

	if(new_size >= byte_array_capacity(result))
		result = reallot_byte_array(result,new_size * 2);

	memcpy((void *)BREF(result,*result_count),elts,len);

	*result_count = new_size;

	return result;
}

/* Bit arrays */

/* size is in bits */

F_BIT_ARRAY *allot_bit_array_internal(CELL size)
{
	F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size));
	array->capacity = tag_fixnum(size);
	return array;
}

F_BIT_ARRAY *allot_bit_array(CELL size)
{
	F_BIT_ARRAY *array = allot_bit_array_internal(size);
	memset(array + 1,0,bit_array_size(size));
	return array;
}

/* push a new bit array on the stack */
DEFINE_PRIMITIVE(bit_array)
{
	CELL size = unbox_array_size();
	dpush(tag_object(allot_bit_array(size)));
}

F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity)
{
	CELL to_copy = array_capacity(array);
	if(capacity < to_copy)
		to_copy = capacity;

	REGISTER_UNTAGGED(array);
	F_BIT_ARRAY *new_array = allot_bit_array(capacity);
	UNREGISTER_UNTAGGED(array);

	memcpy(new_array + 1,array + 1,bit_array_size(to_copy));

	return new_array;
}

DEFINE_PRIMITIVE(resize_bit_array)
{
	F_BYTE_ARRAY* array = untag_bit_array(dpop());
	CELL capacity = unbox_array_size();
	dpush(tag_object(reallot_bit_array(array,capacity)));
}

/* Float arrays */

/* size is in 8-byte doubles */
F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
{
	F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
		float_array_size(size));
	array->capacity = tag_fixnum(size);
	return array;
}

F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
{
	F_FLOAT_ARRAY *array = allot_float_array_internal(size);

	double *elements = (double *)AREF(array,0);
	int i;
	for(i = 0; i < size; i++)
		elements[i] = initial;

	return array;
}

/* push a new float array on the stack */
DEFINE_PRIMITIVE(float_array)
{
	double initial = untag_float(dpop());
	CELL size = unbox_array_size();
	dpush(tag_object(allot_float_array(size,initial)));
}

F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
{
	F_FLOAT_ARRAY* new_array;

	CELL to_copy = array_capacity(array);
	if(capacity < to_copy)
		to_copy = capacity;

	REGISTER_UNTAGGED(array);
	new_array = allot_float_array(capacity,0.0);
	UNREGISTER_UNTAGGED(array);

	memcpy(new_array + 1,array + 1,to_copy * sizeof(double));

	return new_array;
}

DEFINE_PRIMITIVE(resize_float_array)
{
	F_FLOAT_ARRAY* array = untag_float_array(dpop());
	CELL capacity = unbox_array_size();
	dpush(tag_object(reallot_float_array(array,capacity)));
}

/* Tuple layouts */
DEFINE_PRIMITIVE(tuple_layout)
{
	F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
	layout->echelon = dpop();
	layout->superclasses = dpop();
	layout->size = dpop();
	layout->class = dpop();
	layout->hashcode = untag_word(layout->class)->hashcode;
	dpush(tag_object(layout));
}

/* Tuples */

/* push a new tuple on the stack */
F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
{
	REGISTER_UNTAGGED(layout);
	F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
	UNREGISTER_UNTAGGED(layout);
	tuple->layout = tag_object(layout);
	return tuple;
}

DEFINE_PRIMITIVE(tuple)
{
	F_TUPLE_LAYOUT *layout = untag_object(dpop());
	F_FIXNUM size = to_fixnum(layout->size);

	F_TUPLE *tuple = allot_tuple(layout);
	F_FIXNUM i;
	for(i = size - 1; i >= 0; i--)
		put(AREF(tuple,i),F);

	dpush(tag_tuple(tuple));
}

/* push a new tuple on the stack, filling its slots from the stack */
DEFINE_PRIMITIVE(tuple_boa)
{
	F_TUPLE_LAYOUT *layout = untag_object(dpop());
	F_FIXNUM size = to_fixnum(layout->size);

	REGISTER_UNTAGGED(layout);
	F_TUPLE *tuple = allot_tuple(layout);
	UNREGISTER_UNTAGGED(layout);

	/* set delegate slot */
	put(AREF(tuple,0),F);

	F_FIXNUM i;
	for(i = size - 1; i >= 1; i--)
		put(AREF(tuple,i),dpop());

	dpush(tag_tuple(tuple));
}

/* Strings */
CELL string_nth(F_STRING* string, CELL index)
{
	CELL ch = bget(SREF(string,index));
	if(string->aux == F)
		return ch;
	else
	{
		F_BYTE_ARRAY *aux = untag_object(string->aux);
		return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch;
	}
}

/* allocates memory */
void set_string_nth(F_STRING* string, CELL index, CELL value)
{
	bput(SREF(string,index),value & 0xff);

	F_BYTE_ARRAY *aux;

	if(string->aux == F)
	{
		if(value <= 0xff)
			return;
		else
		{
			REGISTER_UNTAGGED(string);
			aux = allot_byte_array(
				untag_fixnum_fast(string->length)
				* sizeof(u16));
			UNREGISTER_UNTAGGED(string);

			write_barrier((CELL)string);
			string->aux = tag_object(aux);
		}
	}
	else
		aux = untag_object(string->aux);

	cput(BREF(aux,index * sizeof(u16)),value >> 8);
}

/* untagged */
F_STRING* allot_string_internal(CELL capacity)
{
	F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));

	string->length = tag_fixnum(capacity);
	string->hashcode = F;
	string->aux = F;

	return string;
}

/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
	if(fill == 0)
	{
		memset((void *)SREF(string,start),'\0',capacity - start);

		if(string->aux != F)
		{
			F_BYTE_ARRAY *aux = untag_object(string->aux);
			memset((void *)BREF(aux,start * sizeof(u16)),'\0',
				(capacity - start) * sizeof(u16));
		}
	}
	else
	{
		CELL i;

		for(i = start; i < capacity; i++)
		{
			REGISTER_UNTAGGED(string);
			set_string_nth(string,i,fill);
			UNREGISTER_UNTAGGED(string);
		}
	}
}

/* untagged */
F_STRING *allot_string(CELL capacity, CELL fill)
{
	F_STRING* string = allot_string_internal(capacity);
	REGISTER_UNTAGGED(string);
	fill_string(string,0,capacity,fill);
	UNREGISTER_UNTAGGED(string);
	return string;
}

DEFINE_PRIMITIVE(string)
{
	CELL initial = to_cell(dpop());
	CELL length = unbox_array_size();
	dpush(tag_object(allot_string(length,initial)));
}

F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
{
	CELL to_copy = string_capacity(string);
	if(capacity < to_copy)
		to_copy = capacity;

	REGISTER_UNTAGGED(string);
	F_STRING *new_string = allot_string_internal(capacity);
	UNREGISTER_UNTAGGED(string);

	memcpy(new_string + 1,string + 1,to_copy);

	if(string->aux != F)
	{
		REGISTER_UNTAGGED(string);
		REGISTER_UNTAGGED(new_string);
		F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
		UNREGISTER_UNTAGGED(new_string);
		UNREGISTER_UNTAGGED(string);

		new_string->aux = tag_object(new_aux);

		F_BYTE_ARRAY *aux = untag_object(string->aux);
		memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
	}

	REGISTER_UNTAGGED(string);
	fill_string(new_string,to_copy,capacity,fill);
	UNREGISTER_UNTAGGED(string);

	return new_string;
}

DEFINE_PRIMITIVE(resize_string)
{
	F_STRING* string = untag_string(dpop());
	CELL capacity = unbox_array_size();
	dpush(tag_object(reallot_string(string,capacity,0)));
}

/* Some ugly macros to prevent a 2x code duplication */

#define MEMORY_TO_STRING(type,utype) \
	F_STRING *memory_to_##type##_string(const type *string, CELL length) \
	{ \
		REGISTER_C_STRING(string); \
		F_STRING* s = allot_string_internal(length); \
		UNREGISTER_C_STRING(string); \
		CELL i; \
		for(i = 0; i < length; i++) \
		{ \
			REGISTER_UNTAGGED(s); \
			set_string_nth(s,i,(utype)*string); \
			UNREGISTER_UNTAGGED(s); \
			string++; \
		} \
		return s; \
	} \
	F_STRING *from_##type##_string(const type *str) \
	{ \
		CELL length = 0; \
		const type *scan = str; \
		while(*scan++) length++; \
		return memory_to_##type##_string(str,length); \
	} \
	void box_##type##_string(const type *str) \
	{ \
		dpush(str ? tag_object(from_##type##_string(str)) : F); \
	}

MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)

bool check_string(F_STRING *s, CELL max)
{
	CELL capacity = string_capacity(s);
	CELL i;
	for(i = 0; i < capacity; i++)
	{
		CELL ch = string_nth(s,i);
		if(ch == '\0' || ch >= (1 << (max * 8)))
			return false;
	}
	return true;
}

F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
{
	return allot_byte_array((capacity + 1) * size);
}

#define STRING_TO_MEMORY(type) \
	void type##_string_to_memory(F_STRING *s, type *string) \
	{ \
		CELL i; \
		CELL capacity = string_capacity(s); \
		for(i = 0; i < capacity; i++) \
			string[i] = string_nth(s,i); \
	} \
	DEFINE_PRIMITIVE(type##_string_to_memory) \
	{ \
		type *address = unbox_alien(); \
		F_STRING *str = untag_string(dpop()); \
		type##_string_to_memory(str,address); \
	} \
	F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
	{ \
		CELL capacity = string_capacity(s); \
		F_BYTE_ARRAY *_c_str; \
		if(check && !check_string(s,sizeof(type))) \
			general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
		REGISTER_UNTAGGED(s); \
		_c_str = allot_c_string(capacity,sizeof(type)); \
		UNREGISTER_UNTAGGED(s); \
		type *c_str = (type*)(_c_str + 1); \
		type##_string_to_memory(s,c_str); \
		c_str[capacity] = 0; \
		return _c_str; \
	} \
	type *to_##type##_string(F_STRING *s, bool check) \
	{ \
		return (type*)(string_to_##type##_alien(s,check) + 1); \
	} \
	type *unbox_##type##_string(void) \
	{ \
		return to_##type##_string(untag_string(dpop()),true); \
	}

STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);

DEFINE_PRIMITIVE(string_nth)
{
	F_STRING *string = untag_object(dpop());
	CELL index = untag_fixnum_fast(dpop());
	dpush(tag_fixnum(string_nth(string,index)));
}

DEFINE_PRIMITIVE(set_string_nth)
{
	F_STRING *string = untag_object(dpop());
	CELL index = untag_fixnum_fast(dpop());
	CELL value = untag_fixnum_fast(dpop());
	set_string_nth(string,index,value);
}