Better local cache
							parent
							
								
									7e84daf0f1
								
							
						
					
					
						commit
						a14e5a4a3b
					
				| 
						 | 
				
			
			@ -14,13 +14,13 @@ BIN: 111 tag-mask set
 | 
			
		|||
H{
 | 
			
		||||
    { fixnum      BIN: 000 }
 | 
			
		||||
    { bignum      BIN: 001 }
 | 
			
		||||
    { tuple       BIN: 010 }
 | 
			
		||||
    { object      BIN: 011 }
 | 
			
		||||
    { hi-tag      BIN: 011 }
 | 
			
		||||
    { ratio       BIN: 100 }
 | 
			
		||||
    { float       BIN: 101 }
 | 
			
		||||
    { complex     BIN: 110 }
 | 
			
		||||
    { POSTPONE: f BIN: 111 }
 | 
			
		||||
    { ratio       BIN: 010 }
 | 
			
		||||
    { float       BIN: 011 }
 | 
			
		||||
    { complex     BIN: 100 }
 | 
			
		||||
    { POSTPONE: f BIN: 101 }
 | 
			
		||||
    { object      BIN: 110 }
 | 
			
		||||
    { hi-tag      BIN: 110 }
 | 
			
		||||
    { tuple       BIN: 111 }
 | 
			
		||||
} tag-numbers set
 | 
			
		||||
 | 
			
		||||
tag-numbers get H{
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -33,13 +33,13 @@ M: lo-tag-class define-builtin-predicate
 | 
			
		|||
 | 
			
		||||
M: hi-tag-class define-builtin-predicate
 | 
			
		||||
    dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
 | 
			
		||||
    [ dup tag 3 eq? ] [ [ drop f ] if ] surround
 | 
			
		||||
    [ dup tag 6 eq? ] [ [ drop f ] if ] surround
 | 
			
		||||
    define-predicate ;
 | 
			
		||||
 | 
			
		||||
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
 | 
			
		||||
 | 
			
		||||
M: hi-tag-class instance?
 | 
			
		||||
    over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
 | 
			
		||||
    over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
 | 
			
		||||
 | 
			
		||||
M: builtin-class (flatten-class) dup set ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -143,15 +143,19 @@ GENERIC: compile-engine ( engine -- obj )
 | 
			
		|||
: direct-dispatch-table ( assoc n -- table )
 | 
			
		||||
    default get <array> [ <enum> swap update ] keep ;
 | 
			
		||||
 | 
			
		||||
: lo-tag-number ( class -- n )
 | 
			
		||||
    "type" word-prop dup num-tags get member?
 | 
			
		||||
    [ drop object tag-number ] unless ;
 | 
			
		||||
 | 
			
		||||
M: tag-dispatch-engine compile-engine
 | 
			
		||||
    methods>> compile-engines*
 | 
			
		||||
    [ [ global [ target-word ] bind tag-number ] dip ] assoc-map
 | 
			
		||||
    [ [ lo-tag-number ] dip ] assoc-map
 | 
			
		||||
    num-tags get direct-dispatch-table ;
 | 
			
		||||
 | 
			
		||||
: hi-tag-number ( class -- n ) "type" word-prop ;
 | 
			
		||||
 | 
			
		||||
: num-hi-tags ( -- n ) num-types get num-tags get - ;
 | 
			
		||||
 | 
			
		||||
: hi-tag-number ( class -- n ) "type" word-prop ;
 | 
			
		||||
 | 
			
		||||
M: hi-tag-dispatch-engine compile-engine
 | 
			
		||||
    methods>> compile-engines*
 | 
			
		||||
    [ [ hi-tag-number num-tags get - ] dip ] assoc-map
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -220,7 +220,7 @@ void mark_object_code_block(CELL scan)
 | 
			
		|||
	F_QUOTATION *quot;
 | 
			
		||||
	F_CALLSTACK *stack;
 | 
			
		||||
 | 
			
		||||
	switch(object_type(scan))
 | 
			
		||||
	switch(hi_tag(scan))
 | 
			
		||||
	{
 | 
			
		||||
	case WORD_TYPE:
 | 
			
		||||
		word = (F_WORD *)scan;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -45,7 +45,7 @@ multiply_overflow:
 | 
			
		|||
	
 | 
			
		||||
/* Note that the XT is passed to the quotation in r11 */
 | 
			
		||||
#define CALL_OR_JUMP_QUOT \
 | 
			
		||||
	lwz r11,17(r3)	   /* load quotation-xt slot */ XX \
 | 
			
		||||
	lwz r11,14(r3)	   /* load quotation-xt slot */ XX \
 | 
			
		||||
 | 
			
		||||
#define CALL_QUOT \
 | 
			
		||||
	CALL_OR_JUMP_QUOT XX \
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -29,7 +29,7 @@ and the callstack top is passed in EDX */
 | 
			
		|||
	pop %ebp ; \
 | 
			
		||||
	pop %ebx
 | 
			
		||||
 | 
			
		||||
#define QUOT_XT_OFFSET 17
 | 
			
		||||
#define QUOT_XT_OFFSET 14
 | 
			
		||||
 | 
			
		||||
/* We pass a function pointer to memcpy to work around a Mac OS X
 | 
			
		||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -61,7 +61,7 @@
 | 
			
		|||
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
#define QUOT_XT_OFFSET 37
 | 
			
		||||
#define QUOT_XT_OFFSET 34
 | 
			
		||||
 | 
			
		||||
/* We pass a function pointer to memcpy to work around a Mac OS X
 | 
			
		||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										101
									
								
								vm/dispatch.c
								
								
								
								
							
							
						
						
									
										101
									
								
								vm/dispatch.c
								
								
								
								
							| 
						 | 
				
			
			@ -38,24 +38,11 @@ static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon)
 | 
			
		|||
	return ptr[echelon * 2 + 1];
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
INLINE CELL method_cache_hashcode(F_TUPLE_LAYOUT *layout, F_ARRAY *array)
 | 
			
		||||
static CELL lookup_tuple_method(CELL object, CELL methods)
 | 
			
		||||
{
 | 
			
		||||
	CELL capacity = (array_capacity(array) >> 1) - 1;
 | 
			
		||||
	return (((CELL)layout >> TAG_BITS) & capacity) << 1;
 | 
			
		||||
}
 | 
			
		||||
	F_TUPLE *tuple = untag_object(object);
 | 
			
		||||
	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
 | 
			
		||||
 | 
			
		||||
INLINE CELL lookup_tuple_method_fast(F_TUPLE_LAYOUT *layout, CELL method_cache)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *array = untag_object(method_cache);
 | 
			
		||||
	CELL hashcode = method_cache_hashcode(layout,array);
 | 
			
		||||
	if(array_nth(array,hashcode) == tag_object(layout))
 | 
			
		||||
		return array_nth(array,hashcode + 1);
 | 
			
		||||
	else
 | 
			
		||||
		return F;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *echelons = untag_object(methods);
 | 
			
		||||
 | 
			
		||||
	F_FIXNUM echelon = untag_fixnum_fast(layout->echelon);
 | 
			
		||||
| 
						 | 
				
			
			@ -84,56 +71,68 @@ static CELL lookup_tuple_method_slow(F_TUPLE_LAYOUT *layout, CELL methods)
 | 
			
		|||
	return F;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static void update_method_cache(F_TUPLE_LAYOUT *layout, CELL method_cache, CELL method)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *array = untag_object(method_cache);
 | 
			
		||||
	CELL hashcode = method_cache_hashcode(layout,array);
 | 
			
		||||
	set_array_nth(array,hashcode,tag_object(layout));
 | 
			
		||||
	set_array_nth(array,hashcode + 1,method);
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL lookup_tuple_method(CELL object, CELL methods, CELL method_cache)
 | 
			
		||||
{
 | 
			
		||||
	F_TUPLE *tuple = untag_object(object);
 | 
			
		||||
	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
 | 
			
		||||
 | 
			
		||||
	CELL method = lookup_tuple_method_fast(layout,method_cache);
 | 
			
		||||
	if(method == F)
 | 
			
		||||
	{
 | 
			
		||||
		local_cache_misses++;
 | 
			
		||||
		method = lookup_tuple_method_slow(layout,methods);
 | 
			
		||||
		update_method_cache(layout,method_cache,method);
 | 
			
		||||
	}
 | 
			
		||||
 | 
			
		||||
	return method;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL lookup_hi_tag_method(CELL object, CELL methods)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *hi_tag_methods = untag_object(methods);
 | 
			
		||||
	CELL hi_tag = object_type(object);
 | 
			
		||||
	return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE);
 | 
			
		||||
	return array_nth(hi_tag_methods,hi_tag(object) - HEADER_TYPE);
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL method_cache_hashcode(CELL key, F_ARRAY *array)
 | 
			
		||||
{
 | 
			
		||||
	CELL capacity = (array_capacity(array) >> 1) - 1;
 | 
			
		||||
	return ((key >> TAG_BITS) & capacity) << 1;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL lookup_cached_method(CELL key, CELL method_cache)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *array = untag_object(method_cache);
 | 
			
		||||
	CELL hashcode = method_cache_hashcode(key,array);
 | 
			
		||||
	if(array_nth(array,hashcode) == key)
 | 
			
		||||
		return array_nth(array,hashcode + 1);
 | 
			
		||||
	else
 | 
			
		||||
		return F;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static void update_method_cache(CELL key, CELL method_cache, CELL method)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *array = untag_object(method_cache);
 | 
			
		||||
	CELL hashcode = method_cache_hashcode(key,array);
 | 
			
		||||
	set_array_nth(array,hashcode,key);
 | 
			
		||||
	set_array_nth(array,hashcode + 1,method);
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
static CELL lookup_method(CELL object, CELL methods, CELL method_cache)
 | 
			
		||||
{
 | 
			
		||||
	F_ARRAY *tag_methods = untag_object(methods);
 | 
			
		||||
	CELL tag = TAG(object);
 | 
			
		||||
	CELL element = array_nth(tag_methods,tag);
 | 
			
		||||
 | 
			
		||||
	if(type_of(element) == WORD_TYPE)
 | 
			
		||||
		return element;
 | 
			
		||||
	if(!HI_TAG_OR_TUPLE_P(object))
 | 
			
		||||
		return array_nth(tag_methods,TAG(object));
 | 
			
		||||
	else
 | 
			
		||||
	{
 | 
			
		||||
		switch(tag)
 | 
			
		||||
		CELL key = get(HI_TAG_HEADER(object));
 | 
			
		||||
		CELL method = lookup_cached_method(key,method_cache);
 | 
			
		||||
		if(method != F)
 | 
			
		||||
			return method;
 | 
			
		||||
		else
 | 
			
		||||
		{
 | 
			
		||||
			method = array_nth(tag_methods,TAG(object));
 | 
			
		||||
			if(type_of(method) != WORD_TYPE)
 | 
			
		||||
			{
 | 
			
		||||
				switch(TAG(object))
 | 
			
		||||
				{
 | 
			
		||||
				case TUPLE_TYPE:
 | 
			
		||||
			return lookup_tuple_method(object,element,method_cache);
 | 
			
		||||
					method = lookup_tuple_method(object,method);
 | 
			
		||||
					break;
 | 
			
		||||
				case OBJECT_TYPE:
 | 
			
		||||
			return lookup_hi_tag_method(object,element);
 | 
			
		||||
					method = lookup_hi_tag_method(object,method);
 | 
			
		||||
					break;
 | 
			
		||||
				default:
 | 
			
		||||
					critical_error("Bad methods array",methods);
 | 
			
		||||
			return F;
 | 
			
		||||
					break;
 | 
			
		||||
				}
 | 
			
		||||
			}
 | 
			
		||||
 | 
			
		||||
			update_method_cache(key,method_cache,method);
 | 
			
		||||
			return method;
 | 
			
		||||
		}
 | 
			
		||||
	}
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										15
									
								
								vm/layouts.h
								
								
								
								
							
							
						
						
									
										15
									
								
								vm/layouts.h
								
								
								
								
							| 
						 | 
				
			
			@ -32,14 +32,17 @@ typedef signed long long s64;
 | 
			
		|||
/*** Tags ***/
 | 
			
		||||
#define FIXNUM_TYPE 0
 | 
			
		||||
#define BIGNUM_TYPE 1
 | 
			
		||||
#define TUPLE_TYPE 2
 | 
			
		||||
#define OBJECT_TYPE 3
 | 
			
		||||
#define RATIO_TYPE 4
 | 
			
		||||
#define FLOAT_TYPE 5
 | 
			
		||||
#define COMPLEX_TYPE 6
 | 
			
		||||
#define RATIO_TYPE 2
 | 
			
		||||
#define FLOAT_TYPE 3
 | 
			
		||||
#define COMPLEX_TYPE 4
 | 
			
		||||
#define F_TYPE 5
 | 
			
		||||
#define OBJECT_TYPE 6
 | 
			
		||||
#define TUPLE_TYPE 7
 | 
			
		||||
 | 
			
		||||
#define HI_TAG_OR_TUPLE_P(cell) (((CELL)(cell) & 6) == 6)
 | 
			
		||||
#define HI_TAG_HEADER(cell) (((CELL)(cell) & 1) * CELLS + UNTAG(cell))
 | 
			
		||||
 | 
			
		||||
/* Canonical F object */
 | 
			
		||||
#define F_TYPE 7
 | 
			
		||||
#define F F_TYPE
 | 
			
		||||
 | 
			
		||||
#define HEADER_TYPE 8 /* anything less than this is a tag */
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										4
									
								
								vm/run.h
								
								
								
								
							
							
						
						
									
										4
									
								
								vm/run.h
								
								
								
								
							| 
						 | 
				
			
			@ -139,7 +139,7 @@ INLINE CELL tag_object(void* cell)
 | 
			
		|||
	return RETAG(cell,OBJECT_TYPE);
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
INLINE CELL object_type(CELL tagged)
 | 
			
		||||
INLINE CELL hi_tag(CELL tagged)
 | 
			
		||||
{
 | 
			
		||||
	return untag_header(get(UNTAG(tagged)));
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			@ -148,7 +148,7 @@ INLINE CELL type_of(CELL tagged)
 | 
			
		|||
{
 | 
			
		||||
	CELL tag = TAG(tagged);
 | 
			
		||||
	if(tag == OBJECT_TYPE)
 | 
			
		||||
		return object_type(tagged);
 | 
			
		||||
		return hi_tag(tagged);
 | 
			
		||||
	else
 | 
			
		||||
		return tag;
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue