From 8c5b0373a83955d0f94b86055c6a3623145d8e79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 15:31:06 -0500 Subject: [PATCH] Working on new method dispatch system --- Makefile | 3 +- .../known-words/known-words.factor | 3 + core/bootstrap/primitives.factor | 2 + core/generic/standard/compiler/authors.txt | 1 + .../generic/standard/compiler/compiler.factor | 174 ++++++++++++++++++ vm/data_heap.c | 2 +- vm/dispatch.c | 108 +++++++++++ vm/dispatch.h | 1 + vm/layouts.h | 2 +- vm/master.h | 1 + vm/primitives.c | 3 +- 11 files changed, 296 insertions(+), 4 deletions(-) create mode 100644 core/generic/standard/compiler/authors.txt create mode 100644 core/generic/standard/compiler/compiler.factor create mode 100644 vm/dispatch.c create mode 100644 vm/dispatch.h diff --git a/Makefile b/Makefile index 35a5ba58bf..511c191711 100644 --- a/Makefile +++ b/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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..ab205b4a16 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/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 \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..a8e23cd336 100644 --- a/core/bootstrap/primitives.factor +++ b/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 diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/standard/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/standard/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/standard/compiler/compiler.factor new file mode 100644 index 0000000000..0456918b49 --- /dev/null +++ b/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 ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] 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 + +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 ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! 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 [ 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 default get prefix + [ 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+ ; + +: define-predicate-engine ( alist -- word ) + [ generic-word get name>> "/predicate-engine" append f 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 + compile-engine 1quotation + picker [ lookup-method ] surround + ] with-scope ; \ No newline at end of file diff --git a/vm/data_heap.c b/vm/data_heap.c index c5aa42aebe..eb8add544e 100644 --- a/vm/data_heap.c +++ b/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 */ diff --git a/vm/dispatch.c b/vm/dispatch.c new file mode 100644 index 0000000000..e231d6f431 --- /dev/null +++ b/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)); +} diff --git a/vm/dispatch.h b/vm/dispatch.h new file mode 100644 index 0000000000..6541c8fef1 --- /dev/null +++ b/vm/dispatch.h @@ -0,0 +1 @@ +void primitive_lookup_method(void); diff --git a/vm/layouts.h b/vm/layouts.h index e9cdef6272..9d92d2c386 100755 --- a/vm/layouts.h +++ b/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 */ diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..e2cafd9a87 100644 --- a/vm/master.h +++ b/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" diff --git a/vm/primitives.c b/vm/primitives.c index 80b672d9d2..4281e88fc3 100755 --- a/vm/primitives.c +++ b/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 };