factor/vm/dispatch.c

#include "master.h"

static CELL search_lookup_alist(CELL table, CELL class)
{
	F_ARRAY *pairs = untag_object(table);
	F_FIXNUM index = array_capacity(pairs) - 1;
	while(index >= 0)
	{
		F_ARRAY *pair = untag_object(array_nth(pairs,index));
		if(array_nth(pair,0) == class)
			return array_nth(pair,1);
		else
			index--;
	}

	return F;
}

static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode)
{
	F_ARRAY *buckets = untag_object(table);
	CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
	if(type_of(bucket) == WORD_TYPE || bucket == F)
		return bucket;
	else
		return search_lookup_alist(bucket,class);
}

static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
{
	CELL *ptr = (CELL *)(layout + 1);
	return ptr[echelon * 2];
}

static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
{
	CELL *ptr = (CELL *)(layout + 1);
	return ptr[echelon * 2 + 1];
}

static CELL lookup_tuple_method(CELL object, CELL methods)
{
	F_TUPLE *tuple = untag_object(object);
	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);

	F_ARRAY *echelons = untag_object(methods);

	F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
	F_FIXNUM max_echelon = array_capacity(echelons) - 1;
	if(echelon > max_echelon) echelon = max_echelon;
       
	while(echelon >= 0)
	{
		CELL echelon_methods = array_nth(echelons,echelon);

		if(type_of(echelon_methods) == WORD_TYPE)
			return echelon_methods;
		else if(echelon_methods != F)
		{
			CELL class = nth_superclass(layout,echelon);
			CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon));
			CELL result = search_lookup_hash(echelon_methods,class,hashcode);
			if(result != F)
				return result;
		}

		echelon--;
	}

	critical_error("Cannot find tuple method",methods);
	return F;
}

static CELL lookup_hi_tag_method(CELL object, CELL methods)
{
	F_ARRAY *hi_tag_methods = untag_object(methods);
	CELL tag = hi_tag(object) - HEADER_TYPE;
#ifdef FACTOR_DEBUG
	assert(tag < TYPE_COUNT - HEADER_TYPE);
#endif
	return array_nth(hi_tag_methods,tag);
}

static CELL lookup_hairy_method(CELL object, CELL methods)
{
	CELL method = array_nth(untag_object(methods),TAG(object));
	if(type_of(method) == WORD_TYPE)
		return method;
	else
	{
		switch(TAG(object))
		{
		case TUPLE_TYPE:
			return lookup_tuple_method(object,method);
			break;
		case OBJECT_TYPE:
			return lookup_hi_tag_method(object,method);
			break;
		default:
			critical_error("Bad methods array",methods);
			return -1;
		}
	}
}

CELL lookup_method(CELL object, CELL methods)
{
	if(!HI_TAG_OR_TUPLE_P(object))
		return array_nth(untag_object(methods),TAG(object));
	else
		return lookup_hairy_method(object,methods);
}

void primitive_lookup_method(void)
{
	CELL methods = dpop();
	CELL object = dpop();
	dpush(lookup_method(object,methods));
}

CELL object_class(CELL object)
{
	if(!HI_TAG_OR_TUPLE_P(object))
		return tag_fixnum(TAG(object));
	else
		return get(HI_TAG_HEADER(object));
}

static CELL method_cache_hashcode(CELL class, F_ARRAY *array)
{
	CELL capacity = (array_capacity(array) >> 1) - 1;
	return ((class >> TAG_BITS) & capacity) << 1;
}

static void update_method_cache(CELL cache, CELL class, CELL method)
{
	F_ARRAY *array = untag_object(cache);
	CELL hashcode = method_cache_hashcode(class,array);
	set_array_nth(array,hashcode,class);
	set_array_nth(array,hashcode + 1,method);
}

void primitive_mega_cache_miss(void)
{
	megamorphic_cache_misses++;

	CELL cache = dpop();
	F_FIXNUM index = untag_fixnum_fast(dpop());
	CELL methods = dpop();

	CELL object = get(ds - index * CELLS);
	CELL class = object_class(object);
	CELL method = lookup_method(object,methods);

	update_method_cache(cache,class,method);

	dpush(method);
}

void primitive_reset_dispatch_stats(void)
{
	megamorphic_cache_hits = megamorphic_cache_misses = 0;
}

void primitive_dispatch_stats(void)
{
	GROWABLE_ARRAY(stats);
	GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_hits));
	GROWABLE_ARRAY_ADD(stats,allot_cell(megamorphic_cache_misses));
	GROWABLE_ARRAY_TRIM(stats);
	GROWABLE_ARRAY_DONE(stats);
	dpush(stats);
}

void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type)
{
	jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
	jit_emit(jit,userenv[type]);
}

void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache)
{
	/* Generate machine code to determine the object's class. */
	jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE);

	/* Do a cache lookup. */
	jit_emit_with(jit,userenv[MEGA_LOOKUP],cache);
	
	/* If we end up here, the cache missed. */
	jit_emit(jit,userenv[JIT_PROLOG]);

	/* Push index, method table and cache on the stack. */
	jit_push(jit,methods);
	jit_push(jit,tag_fixnum(index));
	jit_push(jit,cache);
	jit_word_call(jit,userenv[MEGA_MISS_WORD]);

	/* Now the new method has been stored into the cache, and its on
	   the stack. */
	jit_emit(jit,userenv[JIT_EPILOG]);
	jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
}