New generic word implementation reduces compile time

core/bootstrap/image/image.factor

@@ -203,7 +203,14 @@ M: f '
 
 ! Words
 
+DEFER: emit-word
+
+: emit-generic ( generic -- )
+    dup "default-method" word-prop method-word emit-word
+    "methods" word-prop [ nip method-word emit-word ] assoc-each ;
+
 : emit-word ( word -- )
+    dup generic? [ dup emit-generic ] when
     [
         dup hashcode ' ,
         dup word-name ' ,
@@ -224,7 +231,7 @@ M: f '
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
-    dup target-word [ ] [ word-name no-word ] ?if ;
+    dup target-word swap or ;
 
 : fixup-word ( word -- offset )
     transfer-word dup objects get at
@@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ;
     ] emit-object ;
 
 : emit-tuple ( obj -- pointer )
-    objects get [
+    [
         [ tuple>array unclip transfer-word , % ] { } make
         tuple type-number dup emit-array
-    ] cache ; inline
+    ]
+    ! Hack
+    over class word-name "tombstone" =
+    [ objects get swap cache ] [ call ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first emit-tuple ;
+    word-def first objects get [ emit-tuple ] cache ;
 
 M: array '
     array type-number object tag-number emit-array ;
@@ -313,41 +323,6 @@ M: quotation '
         ] emit-object
     ] cache ;
 
-! Vectors and sbufs
-
-M: vector '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        vector ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-M: sbuf '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        sbuf ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-! Hashes
-
-M: hashtable '
-    [ hash-array ' ] keep
-    tuple type-number tuple tag-number [
-        5 emit-fixnum
-        hashtable ' emit
-        f ' emit
-        dup hash-count emit-fixnum
-        hash-deleted emit-fixnum
-        emit ! array ptr
-    ] emit-object ;
-
 ! Curries
 
 M: curry '

core/bootstrap/primitives.factor

@@ -118,11 +118,11 @@ H{ } clone update-map set
 H{ } clone typemap set
 num-types get f <array> builtins set
 
-! These symbols are needed by the code that executes below
+! Forward definitions
-{
+"object" "kernel" create t "class" set-word-prop
-    { "object" "kernel" }
+"object" "kernel" create union-class "metaclass" set-word-prop
-    { "null" "kernel" }
+
-} [ create drop ] assoc-each
+"null" "kernel" create drop
 
 "fixnum" "math" create "fixnum?" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop

core/bootstrap/stage1.factor

@@ -32,6 +32,7 @@ vocabs.loader system ;
 
     "io.streams.c" require
     "vocabs.loader" require
+    
     "syntax" require
     "bootstrap.layouts" require
 

core/bootstrap/stage2.factor

@@ -15,7 +15,7 @@ IN: bootstrap.stage2
     vm file-name windows? [ "." split1 drop ] when
     ".image" append "output-image" set-global
 
-    "math tools help compiler ui ui.tools io" "include" set-global
+    "math help compiler tools ui ui.tools io" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: classes
 USING: arrays definitions assocs kernel

core/classes/union/union.factor

@@ -1,19 +1,34 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays ;
+generic.standard namespaces arrays math quotations ;
 IN: classes.union
 
 PREDICATE: class union-class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.
+: small-union-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop f ]
+    ] [
+        unclip first "predicate" word-prop swap
+        [ >r "predicate" word-prop [ dup ] swap append r> ]
+        assoc-map alist>quot
+    ] if ;
+
+: big-union-predicate-quot ( members -- quot )
+    [ small-union-predicate-quot ] [ dup ]
+    class-hash-dispatch-quot ;
+
 : union-predicate-quot ( members -- quot )
-    0 (dispatch#) [
+    [ [ drop t ] ] { } map>assoc
-        [ [ drop t ] ] { } map>assoc
+    dup length 4 <= [
-        object bootstrap-word [ drop f ] 2array add*
+        small-union-predicate-quot
-        single-combination
+    ] [
-    ] with-variable ;
+        flatten-methods
+        big-union-predicate-quot
+    ] if ;
 
 : define-union-predicate ( class -- )
     dup predicate-word

core/compiler/compiler.factor

@@ -26,7 +26,7 @@ IN: compiler
     >r dupd save-effect r>
     f pick compiler-error
     over compiled-unxref
-    over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
+    compiled-xref ;
 
 : compile-succeeded ( word -- effect dependencies )
     [

core/effects/effects.factor

@@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ;
     ] "" make ;
 
 : stack-effect ( word -- effect/f )
-    dup symbol? [
+    {
-        drop 0 1 <effect>
+        { [ dup symbol? ] [ drop 0 1 <effect> ] }
-    ] [
+        { [ dup "parent-generic" word-prop ] [
-        { "declared-effect" "inferred-effect" }
+            "parent-generic" word-prop stack-effect
-        swap word-props [ at ] curry map [ ] find nip
+        ] }
-    ] if ;
+        { [ t ] [
+            { "declared-effect" "inferred-effect" }
+            swap word-props [ at ] curry map [ ] find nip
+        ] }
+    } cond ;
 
 M: effect clone
     [ effect-in clone ] keep effect-out clone <effect> ;

core/generator/generator.factor

@@ -154,9 +154,17 @@ M: #if generate-node
         ] generate-1
     ] keep ;
 
+: tail-dispatch? ( node -- ? )
+    #! Is the dispatch a jump to a tail call to a word?
+    dup #call? swap node-successor #return? and ;
+
 : dispatch-branches ( node -- )
     node-children [
-        compiling-word get dispatch-branch %dispatch-label
+        dup tail-dispatch? [
+            node-param
+        ] [
+            compiling-word get dispatch-branch
+        ] if %dispatch-label
     ] each ;
 
 M: #dispatch generate-node

core/generic/generic-docs.factor

@@ -125,16 +125,12 @@ HELP: method
 { $description "Looks up a method definition." }
 { $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
 
-{ method method-def method-loc define-method POSTPONE: M: } related-words
+{ method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
 { $description "Creates a new  "{ $link method } " instance." } ;
 
-HELP: sort-methods
-{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
 { $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;

core/generic/generic.factor

@@ -5,12 +5,7 @@ definitions kernel.private classes classes.private
 quotations arrays vocabs ;
 IN: generic
 
-PREDICATE: word generic "combination" word-prop >boolean ;
+! Method combination protocol
-
-M: generic definer drop f f ;
-
-M: generic definition drop f ;
-
 GENERIC: perform-combination ( word combination -- quot )
 
 M: object perform-combination
@@ -22,22 +17,22 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
+GENERIC: method-prologue ( class combination -- quot )
+
+M: object method-prologue 2drop [ ] ;
+
+GENERIC: make-default-method ( generic combination -- method )
+
+PREDICATE: word generic "combination" word-prop >boolean ;
+
+M: generic definer drop f f ;
+
+M: generic definition drop f ;
+
 : make-generic ( word -- )
     dup dup "combination" word-prop perform-combination define ;
 
-: init-methods ( word -- )
+TUPLE: method word def specializer generic loc ;
-     dup "methods" word-prop
-     H{ } assoc-like
-     "methods" set-word-prop ;
-
-: define-generic ( word combination -- )
-    dupd "combination" set-word-prop
-    dup init-methods make-generic ;
-
-TUPLE: method loc def ;
-
-: <method> ( def -- method )
-    { set-method-def } \ method construct ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -48,12 +43,10 @@ PREDICATE: pair method-spec
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: sort-methods ( assoc -- newassoc )
-    [ keys sort-classes ] keep
-    [ dupd at method-def ] curry { } map>assoc ;
-
 : methods ( word -- assoc )
-    "methods" word-prop sort-methods ;
+    "methods" word-prop
+    [ keys sort-classes ] keep
+    [ dupd at method-word ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -66,10 +59,31 @@ TUPLE: check-method class generic ;
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
-: define-method ( method class generic -- )
+: method-word-name ( class word -- string )
-    >r >r <method> r> bootstrap-word r> check-method
+    word-name "/" rot word-name 3append ;
+
+: make-method-def ( quot word combination -- quot )
+    "combination" word-prop method-prologue swap append ;
+
+: <method-word> ( quot class generic -- word )
+    [ make-method-def ] 2keep
+    [ method-word-name f <word> dup ] keep
+    "parent-generic" set-word-prop
+    dup rot define ;
+
+: <method> ( quot class generic -- method )
+    check-method
+    [ <method-word> ] 3keep f \ method construct-boa ;
+
+: define-method ( quot class generic -- )
+    >r bootstrap-word r>
+    [ <method> ] 2keep
     [ set-at ] with-methods ;
 
+: define-default-method ( generic combination -- )
+    dupd make-default-method object bootstrap-word pick <method>
+    "default-method" set-word-prop ;
+
 ! Definition protocol
 M: method-spec where
     dup first2 method [ method-loc ] [ second where ] ?if ;
@@ -105,3 +119,14 @@ M: class forget* ( class -- )
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
+
+: init-methods ( word -- )
+     dup "methods" word-prop
+     H{ } assoc-like
+     "methods" set-word-prop ;
+
+: define-generic ( word combination -- )
+    2dup "combination" set-word-prop
+    dupd define-default-method
+    dup init-methods
+    make-generic ;

core/generic/math/math.factor

@@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
 : no-math-method ( left right generic -- * )
     \ no-math-method construct-boa throw ;
 
+: default-math-method ( generic -- quot )
+    [ no-math-method ] curry [ ] like ;
+
 : applicable-method ( generic class -- quot )
     over method
-    [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
+    [ method-word word-def ]
+    [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
     object bootstrap-word applicable-method ;
@@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
 
 TUPLE: math-combination ;
 
+M: math-combination make-default-method
+    drop default-math-method ;
+
 M: math-combination perform-combination
     drop
     \ over [

core/generic/standard/standard.factor

@@ -8,6 +8,10 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
+M: standard-combination method-prologue
+    standard-combination-# object
+    <array> swap add [ declare ] curry ;
+
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)
@@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
 : no-method ( object generic -- * )
     \ no-method construct-boa throw ;
 
-: error-method ( word -- method )
+: error-method ( word --  quot )
     picker swap [ no-method ] curry append ;
 
-: empty-method ( word -- method )
+: empty-method ( word -- quot )
     [
         picker % [ delegate dup ] %
         unpicker over add ,
@@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    empty-method object bootstrap-word swap 2array ;
+    "default-method" word-prop method-word
+    object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )
     bootstrap-word swap simplify-alist
     class-predicates alist>quot ;
 
 : small-generic ( methods -- def )
+    [ 1quotation ] assoc-map
     object method-alist>quot ;
 
 : hash-methods ( methods -- buckets )
@@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
         ] if
     ] distribute-buckets ;
 
+: class-hash-dispatch-quot ( methods quot picker -- quot )
+    >r >r hash-methods r> map
+    hash-dispatch-quot r> [ class-hash ] rot 3append ;
+
 : big-generic ( methods -- quot )
-    hash-methods [ small-generic ] map
+    [ small-generic ] picker class-hash-dispatch-quot ;
-    hash-dispatch-quot picker [ class-hash ] rot 3append ;
 
 : vtable-class ( n -- class )
     type>class [ hi-tag bootstrap-word ] unless* ;
@@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
 
 : build-type-vtable ( alist-seq -- alist-seq )
     dup length [
-        vtable-class swap simplify-alist
+        vtable-class
+        swap [ word-def ] assoc-map simplify-alist
         class-predicates alist>quot
     ] 2map ;
 
@@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
 : standard-methods ( word -- alist )
     dup methods swap default-method add* ;
 
+M: standard-combination make-default-method
+    standard-combination-# (dispatch#)
+    [ empty-method ] with-variable ;
+
 M: standard-combination perform-combination
     standard-combination-# (dispatch#) [
         [ standard-methods ] keep "inline" word-prop
         [ small-generic ] [ single-combination ] if
     ] with-variable ;
 
-: default-hook-method ( word -- pair )
-    error-method object bootstrap-word swap 2array ;
-
-: hook-methods ( word -- methods )
-    dup methods [ [ drop ] swap append ] assoc-map
-    swap default-hook-method add* ;
-
 TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
 
-M: hook-combination perform-combination
+M: hook-combination method-prologue
+    2drop [ drop ] ;
+
+: with-hook ( combination quot -- quot' )
     0 (dispatch#) [
-        [
+        swap slip
-            hook-combination-var [ get ] curry %
+        hook-combination-var [ get ] curry
-            hook-methods single-combination %
+        swap append
-        ] [ ] make
+    ] with-variable ; inline
-    ] with-variable ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ standard-methods single-combination ] with-hook ;
 
 : define-simple-generic ( word -- )
     T{ standard-combination f 0 } define-generic ;

core/inference/backend/backend.factor

@@ -9,9 +9,13 @@ IN: inference.backend
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
+: inline? ( word -- ? )
+    dup "parent-generic" word-prop
+    [ inline? ] [ "inline" word-prop ] ?if ;
+
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
-    [ dup word? [ "inline" word-prop ] when not ] find drop
+    [ dup word? [ inline? ] when not ] find drop
     [ head-slice ] when* ;
 
 : inline-recursive-label ( word -- label/f )
@@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
     meta-d get push-all ;
 
 : if-inline ( word true false -- )
-    >r >r dup "inline" word-prop r> r> if ; inline
+    >r >r dup inline? r> r> if ; inline
 
 : consume/produce ( effect node -- )
     over effect-in over consume-values
@@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
     #merge node, ; inline
 
 : make-call-node ( word effect -- )
-    swap dup "inline" word-prop
+    swap dup inline?
     over dup recursive-label eq? not and [
         meta-d get clone -rot
         recursive-label #call-label [ consume/produce ] keep

core/optimizer/backend/backend.factor

@@ -245,11 +245,19 @@ M: #dispatch optimize-node*
 : dispatching-class ( node word -- class )
     [ dispatch# node-class# ] keep specific-method ;
 
+: flat-length ( seq -- n )
+    [
+        dup quotation? over array? or
+        [ flat-length ] [ drop 1 ] if
+    ] map sum ;
+
 : will-inline-method ( node word -- method-spec/t quot/t )
     #! t indicates failure
     tuck dispatching-class dup [
         swap [ 2array ] 2keep
-        method method-def
+        method method-word
+        dup word-def flat-length 5 >=
+        [ 1quotation ] [ word-def ] if
     ] [
         2drop t t
     ] if ;

core/words/words.factor

@@ -154,7 +154,8 @@ SYMBOL: changed-words
     } reset-props ;
 
 : reset-generic ( word -- )
-    dup reset-word { "methods" "combination" } reset-props ;
+    dup reset-word
+    { "methods" "combination" "default-method" } reset-props ;
 
 : gensym ( -- word )
     "G:" \ gensym counter number>string append f <word> ;

extra/benchmark/dispatch5/dispatch5.factor

@@ -0,0 +1,77 @@
+USING: classes kernel sequences vocabs math ;
+IN: benchmark.dispatch5
+
+MIXIN: g
+
+TUPLE: x1 ;
+INSTANCE: x1 g
+TUPLE: x2 ;
+INSTANCE: x2 g
+TUPLE: x3 ;
+INSTANCE: x3 g
+TUPLE: x4 ;
+INSTANCE: x4 g
+TUPLE: x5 ;
+INSTANCE: x5 g
+TUPLE: x6 ;
+INSTANCE: x6 g
+TUPLE: x7 ;
+INSTANCE: x7 g
+TUPLE: x8 ;
+INSTANCE: x8 g
+TUPLE: x9 ;
+INSTANCE: x9 g
+TUPLE: x10 ;
+INSTANCE: x10 g
+TUPLE: x11 ;
+INSTANCE: x11 g
+TUPLE: x12 ;
+INSTANCE: x12 g
+TUPLE: x13 ;
+INSTANCE: x13 g
+TUPLE: x14 ;
+INSTANCE: x14 g
+TUPLE: x15 ;
+INSTANCE: x15 g
+TUPLE: x16 ;
+INSTANCE: x16 g
+TUPLE: x17 ;
+INSTANCE: x17 g
+TUPLE: x18 ;
+INSTANCE: x18 g
+TUPLE: x19 ;
+INSTANCE: x19 g
+TUPLE: x20 ;
+INSTANCE: x20 g
+TUPLE: x21 ;
+INSTANCE: x21 g
+TUPLE: x22 ;
+INSTANCE: x22 g
+TUPLE: x23 ;
+INSTANCE: x23 g
+TUPLE: x24 ;
+INSTANCE: x24 g
+TUPLE: x25 ;
+INSTANCE: x25 g
+TUPLE: x26 ;
+INSTANCE: x26 g
+TUPLE: x27 ;
+INSTANCE: x27 g
+TUPLE: x28 ;
+INSTANCE: x28 g
+TUPLE: x29 ;
+INSTANCE: x29 g
+TUPLE: x30 ;
+INSTANCE: x30 g
+
+: my-classes ( -- seq )
+    "benchmark.dispatch5" words [ tuple-class? ] subset ;
+
+: a-bunch-of-objects ( -- seq )
+    my-classes [ construct-empty ] map ;
+
+: dispatch-benchmark ( -- )
+    1000000 a-bunch-of-objects
+    [ f [ g? or ] reduce drop ] curry times ;
+
+MAIN: dispatch-benchmark

extra/tools/crossref/crossref.factor

@@ -14,8 +14,7 @@ IN: tools.crossref
 
 : (method-usage) ( word generic -- methods )
     tuck methods
-    [ second quot-uses key? ] with subset
+    [ second uses member? ] with subset keys
-    0 <column>
     swap [ 2array ] curry map ;
 
 : method-usage ( word seq -- methods )