Working on new method dispatch system

Makefile

@@ -35,6 +35,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/data_gc.o \
 	vm/data_heap.o \
 	vm/debug.o \
+	vm/dispatch.o \
 	vm/errors.o \
 	vm/factor.o \
 	vm/image.o \
@@ -182,5 +183,5 @@ vm/ffi_test.o: vm/ffi_test.c
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
-	
+
 .PHONY: factor

basis/stack-checker/known-words/known-words.factor

@@ -12,6 +12,7 @@ classes.tuple.private vectors vectors.private words definitions
 words.private assocs summary compiler.units system.private
 combinators locals locals.backend locals.types words.private
 quotations.private combinators.private stack-checker.values
+generic.standard.private
 alien.libraries
 stack-checker.alien
 stack-checker.state
@@ -676,3 +677,5 @@ M: object infer-call*
 \ gc-stats { } { array } define-primitive
 
 \ jit-compile { quotation } { } define-primitive
+
+\ lookup-method { object array } { word } define-primitive

core/bootstrap/primitives.factor

@@ -69,6 +69,7 @@ bootstrapping? on
     "classes.predicate"
     "compiler.units"
     "continuations.private"
+    "generic.standard.private"
     "growable"
     "hashtables"
     "hashtables.private"
@@ -532,6 +533,7 @@ tuple
     { "jit-compile" "quotations" (( quot -- )) }
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
+    { "lookup-method" "generic.standard.private" (( object methods -- method )) }
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number

core/generic/standard/compiler/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

core/generic/standard/compiler/compiler.factor

@@ -0,0 +1,174 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.algebra math combinators
+generic.standard.engines hashtables kernel kernel.private layouts
+namespaces sequences words sorting quotations effects
+generic.standard.private words.private ;
+IN: generic.standard.compiler
+
+! ! ! Build an engine ! ! !
+
+! 1. Flatten methods
+TUPLE: predicate-engine methods ;
+
+: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+
+: push-method ( method specializer atomic assoc -- )
+    [
+        [ H{ } clone <predicate-engine> ] unless*
+        [ methods>> set-at ] keep
+    ] change-at ;
+
+: flatten-method ( class method assoc -- )
+    [ [ flatten-class keys ] keep ] 2dip [
+        [ spin ] dip push-method
+    ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+    H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+
+! 2. Convert methods
+: convert-methods ( assoc class word -- assoc' )
+    over [ split-methods ] 2dip pick assoc-empty?
+    [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
+
+! 2.1 Convert tuple methods
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+    [ swap dup "layout" word-prop third ] dip
+    [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+    H{ } clone [ [ push-echelon ] curry assoc-each ] keep ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+    echelon-sort
+    [ dupd <echelon-dispatch-engine> ] assoc-map
+    \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+    tuple bootstrap-word
+    \ <tuple-dispatch-engine> convert-methods ;
+
+! 2.2 Convert hi-tag methods
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+    \ hi-tag bootstrap-word
+    \ <hi-tag-dispatch-engine> convert-methods ;
+
+! 3 Tag methods
+TUPLE: tag-dispatch-engine methods ;
+
+C: <tag-dispatch-engine> tag-dispatch-engine
+
+: <engine> ( assoc -- engine )
+    flatten-methods
+    convert-tuple-methods
+    convert-hi-tag-methods
+    <tag-dispatch-engine> ;
+
+! ! ! Compile engine ! ! !
+SYMBOL: assumed
+SYMBOL: default
+SYMBOL: generic-word
+
+GENERIC: compile-engine ( engine -- obj )
+
+: compile-engines ( assoc -- assoc' )
+    [ compile-engine ] assoc-map ;
+
+: compile-engines* ( assoc -- assoc' )
+    [ over assumed [ compile-engine ] with-variable ] assoc-map ;
+
+: direct-dispatch-table ( assoc n -- table )
+    default get <array> [ <enum> swap update ] keep ;
+
+M: tag-dispatch-engine compile-engine
+    methods>> compile-engines*
+    [ [ 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 - ;
+
+M: hi-tag-dispatch-engine compile-engine
+    methods>> compile-engines*
+    [ [ hi-tag-number num-tags get - ] dip ] assoc-map
+    num-hi-tags direct-dispatch-table ;
+
+: build-fast-hash ( methods -- buckets )
+    >alist V{ } clone [ hashcode 1array ] distribute-buckets
+    [ compile-engines* >alist >array ] map ;
+
+M: echelon-dispatch-engine compile-engine
+    methods>> compile-engines* build-fast-hash ;
+
+M: tuple-dispatch-engine compile-engine
+    tuple assumed [
+        echelons>> compile-engines
+        dup keys supremum f <array> default get prefix
+        [ <enum> swap update ] keep
+    ] with-variable ;
+
+: sort-methods ( assoc -- assoc' )
+    >alist [ keys sort-classes ] keep extract-keys ;
+
+: literalize-methods ( assoc -- assoc' )
+    [ [ ] curry \ drop prefix ] assoc-map ;
+
+: methods-with-default ( engine -- assoc )
+    methods>> clone default get object bootstrap-word pick set-at ;
+
+: keep-going? ( assoc -- ? )
+    assumed get swap second first class<= ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+    {
+        { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+        { [ dup length 1 = ] [ first second { } ] }
+        { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+        [ [ first second ] [ rest-slice ] bi ]
+    } cond ;
+
+: class-predicates ( assoc -- assoc )
+    [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
+
+: predicate-engine-effect ( -- effect )
+    (dispatch#) get 1+ dup 1+ <effect> ;
+
+: define-predicate-engine ( alist -- word )
+    [ generic-word get name>> "/predicate-engine" append f <word> dup ] dip
+    predicate-engine-effect define-declared ;
+
+M: predicate-engine compile-engine
+    methods-with-default
+    sort-methods
+    literalize-methods
+    prune-redundant-predicates
+    class-predicates
+    [ peek wrapped>> ]
+    [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+
+M: word compile-engine ;
+
+M: f compile-engine ;
+
+: build-engine ( generic combination -- engine )
+    [
+        #>> (dispatch#) set
+        [ generic-word set ]
+        [ "default-method" word-prop default set ]
+        [ "methods" word-prop ] tri
+        <engine> compile-engine 1quotation
+        picker [ lookup-method ] surround
+    ] with-scope ;

vm/data_heap.c

@@ -334,7 +334,7 @@ CELL next_object(void)
 	type = untag_header(value);
 	heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 
-	return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
+	return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE);
 }
 
 /* Push object at heap scan cursor and advance; pushes f when done */

vm/dispatch.c

@@ -0,0 +1,108 @@
+#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_ARRAY *echelons = untag_object(methods);
+	F_TUPLE *tuple = untag_object(object);
+	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
+
+	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",object);
+	return F;
+}
+
+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);
+}
+
+static CELL lookup_method(CELL object, CELL methods)
+{
+	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;
+	else
+	{
+		switch(tag)
+		{
+		case TUPLE_TYPE:
+			return lookup_tuple_method(object,element);
+		case OBJECT_TYPE:
+			return lookup_hi_tag_method(object,element);
+		default:
+			critical_error("Bad methods array",methods);
+			return F;
+		}
+	}
+}
+
+void primitive_lookup_method(void)
+{
+	CELL methods = dpop();
+	CELL object = dpop();
+	dpush(lookup_method(object,methods));
+}

vm/dispatch.h

@@ -0,0 +1 @@
+void primitive_lookup_method(void);

vm/layouts.h

@@ -42,7 +42,7 @@ typedef signed long long s64;
 #define F_TYPE 7
 #define F F_TYPE
 
-#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
+#define HEADER_TYPE 8 /* anything less than this is a tag */
 
 #define GC_COLLECTED 5 /* See gc.c */
 

vm/master.h

@@ -41,6 +41,7 @@
 #include "callstack.h"
 #include "alien.h"
 #include "quotations.h"
+#include "dispatch.h"
 #include "factor.h"
 #include "utilities.h"
 

vm/primitives.c

@@ -144,5 +144,6 @@ void *primitives[] = {
 	primitive_clear_gc_stats,
 	primitive_jit_compile,
 	primitive_load_locals,
-	primitive_check_datastack
+	primitive_check_datastack,
+	primitive_lookup_method
 };