Better word hashing, working on class vtable dispatch

diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor
index df13aaf1dea761375771746abccb6338c2be7e47..69b8734f1f4e32d0198ec03aab8a1b3be6e24bbb 100644 (file)
--- a/library/generic/standard-combination.factor
+++ b/library/generic/standard-combination.factor
@@ -52,30 +52,36 @@ TUPLE: no-method object generic ;
 : simplify-alist ( class assoc -- default assoc )
     0 swap (simplify-alist) ;
 
+: default-method ( dispatch# word -- pair )
+    empty-method object bootstrap-word swap 2array ;
+
 : methods* ( dispatch# word -- assoc )
     #! Make a class->method association, together with a
     #! default delegating method at the end.
-    [
-        empty-method object bootstrap-word swap 2array 1array
-    ] keep methods append ;
+    dup methods -rot default-method add* ;
 
-: small-generic ( dispatch# word -- def )
-    dupd methods* object bootstrap-word swap simplify-alist
+: method-alist>quot ( dispatch# word base-class -- quot )
+    bootstrap-word swap simplify-alist
     swapd class-predicates alist>quot ;
 
-: vtable-methods ( dispatch# alist-seq -- alist-seq )
+: small-generic ( dispatch# word -- def )
+    dupd methods* object method-alist>quot ;
+
+: build-type-vtable ( dispatch# alist-seq -- alist-seq )
     dup length [
         type>class
         [ swap simplify-alist ] [ first second [ ] ] if*
         >r over r> class-predicates alist>quot
     ] 2map nip ;
 
-: <vtable> ( dispatch# word n -- vtable )
+: <type-vtable> ( dispatch# word n -- vtable )
     #! n is vtable size; either num-types or num-tags.
-    >r dupd methods* r> sort-methods vtable-methods ;
+    >r dupd methods* r> sort-methods build-type-vtable ;
 
-: big-generic ( dispatch# word n dispatcher -- def )
-    [ >r pick picker % r> , <vtable> , \ dispatch , ] [ ] make ;
+: type-generic ( dispatch# word n dispatcher -- quot )
+    [
+        >r pick picker % r> , <type-vtable> , \ dispatch ,
+    ] [ ] make ;
 
 : tag-generic? ( word -- ? )
     #! If all the types we dispatch upon can be identified
@@ -85,16 +91,35 @@ TUPLE: no-method object generic ;
 
 : small-generic? ( word -- ? ) generic-tags length 3 <= ;
 
+: build-class-vtable ( vtable pair -- )
+    dup first hashcode pick length rem rot nth push ;
+
+: <class-vtable> ( dispatch# word assoc -- table )
+    >r dupd default-method r>
+    [ length 3 + [ drop 1array >vector ] map-with ] keep
+    [ dupd build-class-vtable ] each
+    [ object method-alist>quot ] map-with ;
+
+: class-generic ( dispatch# word -- quot )
+    dup methods dup empty? [
+        drop default-method
+    ] [
+        [
+            pick picker % [ class hashcode ] %
+            <class-vtable> dup length , \ rem , , \ dispatch ,
+        ] [ ] make
+    ] if ;
+
 : standard-combination ( word dispatch# -- quot )
     swap {
-        { [ dup tag-generic? ] [ num-tags \ tag big-generic ] }
+        { [ dup tag-generic? ] [ num-tags \ tag type-generic ] }
         { [ dup small-generic? ] [ small-generic ] }
-        { [ t ] [ num-types \ type big-generic ] }
+        { [ t ] [ class-generic ] }
+        { [ t ] [ num-types \ type type-generic ] }
     } cond ;
 
 : define-generic ( word -- )
     [ 0 standard-combination ] define-generic* ;
 
 PREDICATE: generic standard-generic
-    1 swap "combination" word-prop ?nth
-    \ standard-combination eq? ;
+    "combination" word-prop [ standard-combination ] tail? ;

diff --git a/vm/factor.c b/vm/factor.c
index d2e7eaa561b9db894fac823877127dde709f088c..8a35c5ff82a0eb2899af75808f7d08a00d5ffa31 100644 (file)
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -4,6 +4,7 @@ void init_factor(const char* image,
        CELL ds_size, CELL rs_size, CELL cs_size,
        CELL gen_count, CELL young_size, CELL aging_size, CELL code_size)
 {
+       srand(current_millis());
        init_ffi();
        init_data_heap(gen_count,young_size,aging_size);
        init_code_heap(code_size);

diff --git a/vm/types.c b/vm/types.c
index 6fd7b2f0cd09367b7d1651bdd94d115dbf39b0f8..b45ba532ea9a4c4cafe1dadf612e2cf53817d75c 100644 (file)
--- a/vm/types.c
+++ b/vm/types.c
@@ -434,7 +434,7 @@ void primitive_word(void)
        vocabulary = dpop();
        name = dpop();
        word = allot_object(WORD_TYPE,sizeof(F_WORD));
-       word->hashcode = tag_fixnum((CELL)word); /* initial address */
+       word->hashcode = tag_fixnum(rand());
        word->name = name;
        word->vocabulary = vocabulary;
        word->primitive = tag_fixnum(0);