Rewriting method dispatch to support inheritance

core/bootstrap/layouts/layouts.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel alien byte-arrays
 hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts classes.tuple.private ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
 
 BIN: 111 tag-mask set
 8 num-tags set
@@ -15,6 +16,7 @@ H{
     { bignum      BIN: 001 }
     { tuple       BIN: 010 }
     { object      BIN: 011 }
+    { hi-tag      BIN: 011 }
     { ratio       BIN: 100 }
     { float       BIN: 101 }
     { complex     BIN: 110 }

core/bootstrap/primitives.factor

@@ -101,17 +101,24 @@ num-types get f <array> builtins set
 } [ create-vocab drop ] each
 
 ! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+    [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
     [
-        "type" word-prop
+        [ dup tag ] % \ hi-tag tag-number , \ eq? ,
-        [ tag-mask get < \ tag \ type ? , ] [ , ] bi
+        [ [ hi-tag ] % , \ eq? , ] [ ] make ,
-        \ eq? ,
+        [ drop f ] ,
+        \ if ,
     ] [ ] make ;
 
+: builtin-predicate-quot ( class -- quot )
+    "type" word-prop
+    dup tag-mask get <
+    [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
 : define-builtin-predicate ( class -- )
-    [ dup builtin-predicate-quot define-predicate ]
+    dup builtin-predicate-quot define-predicate ;
-    [ predicate-word make-inline ]
-    bi ;
 
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
@@ -363,7 +370,7 @@ define-class
 f builtins get [ ] subset union-class define-class
 
 ! Class of objects with object tag
-"hi-tag" "classes.private" create
+"hi-tag" "kernel.private" create
 f builtins get num-tags get tail union-class define-class
 
 ! Null class with no instances.

core/classes/classes.factor

@@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- )
         ] bi
     ] 2tri ;
 
-GENERIC: class ( object -- class ) inline
+GENERIC: class ( object -- class )
 
-M: object class type type>class ;
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;

core/combinators/combinators.factor

@@ -9,24 +9,24 @@ hashtables sorting ;
     [ call ] with each ;
 
 : cleave>quot ( seq -- quot )
-    [ [ keep ] curry ] map concat [ drop ] append ;
+    [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
 
 : 2cleave ( x seq -- )
     [ 2keep ] each 2drop ;
 
 : 2cleave>quot ( seq -- quot )
-    [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+    [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
 
 : 3cleave ( x seq -- )
     [ 3keep ] each 3drop ;
 
 : 3cleave>quot ( seq -- quot )
-    [ [ 3keep ] curry ] map concat [ 3drop ] append ;
+    [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
 
 : spread>quot ( seq -- quot )
     [ length [ >r ] <repetition> concat ]
     [ [ [ r> ] prepend ] map concat ] bi
-    append ;
+    append [ ] like ;
 
 : spread ( objs... seq -- )
     spread>quot call ;

core/compiler/tests/intrinsics.factor

@@ -174,11 +174,6 @@ sequences.private ;
 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@@ -223,9 +218,6 @@ sequences.private ;
 
 [ t ] [ f [ f eq? ] compile-call ] unit-test
 
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
 ! regression
 [ 3 ] [
     100001 f <array> 3 100000 pick set-nth

core/compiler/tests/templates.factor

@@ -26,10 +26,6 @@ IN: compiler.tests
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
 unit-test
 
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
 

core/cpu/x86/intrinsics/intrinsics.factor

@@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "in" } }
 } define-intrinsic
 
-\ type [
-    "end" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "end" get JNE
-    ! If we have equality, load type from header
-    "x" operand "obj" operand -3 [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
-    "end" define-label
-    "tuple" define-label
-    "object" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with tuple tag number (2).
-    "x" operand tuple tag-number tag-fixnum CMP
-    "tuple" get JE
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "object" get JE
-    "end" get JMP
-    "object" get resolve-label
-    ! Load header type
-    "x" operand "obj" operand header-offset [+] MOV
-    "end" get JMP
-    "tuple" get resolve-label
-    ! Load class hash
-    "x" operand "obj" operand tuple-class-offset [+] MOV
-    "x" operand dup class-hash-offset [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
 ! Slots
 : %slot-literal-known-tag
     "obj" operand

core/generic/generic.factor

@@ -37,10 +37,12 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
+: sort-methods ( assoc -- assoc' )
+    [ keys sort-classes ]
+    [ [ dupd at ] curry ] bi { } map>assoc ;
+
 : methods ( word -- assoc )
-    "methods" word-prop
+    "methods" word-prop sort-methods ;
-    [ keys sort-classes ] keep
-    [ dupd at ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 

core/generic/standard/engines/engines.factor

@@ -0,0 +1,49 @@
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+    [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+    [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+    >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+: split-methods ( assoc class -- first second )
+    [ [ nip class< not ] curry assoc-subset ]
+    [ [ nip class<     ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+    over >r >r split-methods dup assoc-empty? [
+        r> r> 3drop
+    ] [
+        r> execute r> pick set-at
+    ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+    {
+        { 0 [ [ dup ] ] }
+        { 1 [ [ over ] ] }
+        { 2 [ [ pick ] ] }
+        [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+    } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;

core/generic/standard/engines/predicate/predicate.factor

@@ -0,0 +1,28 @@
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+    [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: 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? ] [ 1 tail-slice prune-redundant-predicates ] }
+        { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+    } cond ;
+
+M: predicate-dispatch-engine engine>quot
+    methods>> clone
+    default get object bootstrap-word pick set-at engines>quots
+    sort-methods prune-redundant-predicates
+    class-predicates alist>quot ;

core/generic/standard/engines/tag/tag.factor

@@ -0,0 +1,48 @@
+USING: classes.private generic.standard.engines namespaces
+arrays mirrors assocs sequences.private quotations
+kernel.private layouts math slots.private math.private
+kernel accessors ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+    hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
+
+: direct-dispatch-quot ( alist n -- quot )
+    default get <array>
+    [ <enum> swap update ] keep
+    [ dispatch ] curry >quotation ;
+
+M: lo-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r tag-number r> ] assoc-map
+    [
+        picker % [ tag ] % [
+            linear-dispatch-quot
+        ] [
+            num-tags get direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number type-number num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+    [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+    [
+        picker % hi-tag-quot % [
+            linear-dispatch-quot
+        ] [
+            num-hi-tags direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;

core/generic/standard/engines/tuple/tuple.factor

@@ -0,0 +1,109 @@
+IN: generic.standard.engines.tuple
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private quotations ;
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+    >r swap dup tuple-layout layout-echelon r>
+    [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+    V{ } clone [
+        [
+            push-echelon
+        ] curry assoc-each
+    ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+    echelon-sort
+    [ dupd <echelon-dispatch-engine> ] assoc-map
+    \ tuple-dispatch-engine construct-boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+    tuple \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+    methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+    >alist V{ } clone [ class-hashes ] distribute-buckets
+    [ <trivial-tuple-dispatch-engine> ] map ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+    #! 1 slot == word hashcode
+    [
+        [ dup 1 slot ] %
+        hash-methods [ engine>quot ] map hash-dispatch-quot %
+    ] [ ] make ;
+
+: tuple-dispatch-engine-word-name ( engine -- string )
+    [
+        generic get word-name %
+        "/tuple-dispatch-engine/" %
+        n>> #
+    ] "" make ;
+
+PREDICATE: tuple-dispatch-engine-word < word
+    "tuple-dispatch-engine" word-prop ;
+
+M: tuple-dispatch-engine-word stack-effect
+    "tuple-dispatch-generic" word-prop stack-effect ;
+
+: <tuple-dispatch-engine-word> ( engine -- word )
+    tuple-dispatch-engine-word-name f <word>
+    [ t "tuple-dispatch-engine" set-word-prop ]
+    [ generic get "tuple-dispatch-generic" set-word-prop ]
+    [ ]
+    tri ;
+
+: define-tuple-dispatch-engine-word ( engine quot -- word )
+    >r <tuple-dispatch-engine-word> dup r> define ;
+
+: tuple-dispatch-engine-body ( engine -- quot )
+    #! 1 slot == tuple-layout
+    #! 2 slot == 0 array-nth
+    #! 4 slot == layout-superclasses
+    [
+        picker %
+        [ 1 slot 4 slot ] %
+        [ n>> 2 + , [ slot ] % ]
+        [
+            methods>> [
+                <trivial-tuple-dispatch-engine> engine>quot
+            ] [
+                class-hash-dispatch-quot
+            ] if-small? %
+        ] bi
+    ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+    dup tuple-dispatch-engine-body
+    define-tuple-dispatch-engine-word
+    1quotation ;
+
+: >=-case-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+M: tuple-dispatch-engine engine>quot
+    #! 1 slot == tuple-layout
+    #! 5 slot == layout-echelon
+    [
+        picker %
+        [ 1 slot 5 slot ] %
+        echelons>>
+        [ [ engine>quot dup default set ] assoc-map ] with-scope
+        >=-case-quot %
+    ] [ ] make ;

core/generic/standard/new/new-tests.factor

@@ -0,0 +1,141 @@
+IN: generic.standard.new.tests
+USING: tools.test math math.functions math.constants
+generic.standard.new strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser ;
+
+<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: number hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+    [ width>> ] [ height>> ] bi
+    rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+    [ width>> ]
+    [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+    rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test

core/generic/standard/new/new.factor

@@ -0,0 +1,139 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel kernel.private slots.private math
+namespaces sequences vectors words quotations definitions
+hashtables layouts combinators sequences.private generic
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
+IN: generic.standard.new
+
+: unpickers
+    {
+        [ nip ]
+        [ >r nip r> swap ]
+        [ >r >r nip r> r> -rot ]
+    } ; inline
+
+: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
+
+ERROR: no-method object generic ;
+
+: error-method ( word -- quot )
+    picker swap [ no-method ] curry append ;
+
+: empty-method ( word -- quot )
+    [
+        picker % [ delegate dup ] %
+        unpicker over suffix ,
+        error-method \ drop prefix , \ if ,
+    ] [ ] make ;
+
+: default-method ( word -- pair )
+    "default-method" word-prop
+    object bootstrap-word swap 2array ;
+
+: push-method ( method specializer atomic assoc -- )
+    [
+        [ H{ } clone <predicate-dispatch-engine> ] unless*
+        [ methods>> set-at ] keep
+    ] change-at ;
+
+: flatten-method ( class method assoc -- )
+    >r >r dup flatten-class keys swap r> r> [
+        >r spin r> push-method
+    ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+    H{ } clone [
+        [
+            flatten-method
+        ] curry assoc-each
+    ] keep ;
+
+: <big-dispatch-engine> ( assoc -- engine )
+    flatten-methods
+    convert-tuple-methods
+    convert-hi-tag-methods
+    <lo-tag-dispatch-engine> ;
+
+: find-default ( methods -- quot )
+    #! Side-effects methods.
+    object swap delete-at* [
+        drop generic get "default-method" word-prop
+    ] unless 1quotation ;
+
+GENERIC: mangle-method ( method generic -- quot )
+
+: single-combination ( words -- quot )
+    [
+        object bootstrap-word assumed set
+        [ generic set ]
+        [
+            "methods" word-prop
+            [ generic get mangle-method ] assoc-map
+            [ find-default default set ]
+            [
+                generic get "inline" word-prop [
+                    <predicate-dispatch-engine>
+                ] [
+                    <big-dispatch-engine>
+                ] if
+            ] bi
+            engine>quot
+        ] bi
+    ] with-scope ;
+
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
+
+PREDICATE: standard-generic < generic
+    "combination" word-prop standard-combination? ;
+
+PREDICATE: simple-generic < standard-generic
+    "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+    T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+    >r #>> (dispatch#) r> with-variable ;
+
+M: standard-combination make-default-method
+    [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+    [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+    "combination" word-prop hook-combination? ;
+
+: with-hook ( combination quot -- quot' )
+    0 (dispatch#) [
+        dip var>> [ get ] curry prepend
+    ] with-variable ; inline
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ single-combination ] with-hook ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
+M: standard-combination dispatch# #>> ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: simple-generic definer drop \ GENERIC: f ;
+
+M: standard-generic definer drop \ GENERIC# f ;
+
+M: hook-generic definer drop \ HOOK: f ;

core/generic/standard/standard.factor

@@ -41,23 +41,13 @@ ERROR: no-method object generic ;
 : class-predicates ( assoc -- assoc )
     [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
 
-: (simplify-alist) ( class i assoc -- default assoc )
+: simplify-alist ( class assoc -- default assoc' )
-    2dup length 1- = [
+    {
-        nth second { } rot drop
+        { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
-    ] [
+        { [ dup length 1 = ] [ nip first second { } ] }
-        3dup >r 1+ r> nth first class< [
+        { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
-            >r 1+ r> (simplify-alist)
+        { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
-        ] [
+    } cond ;
-            [ nth second ] 2keep swap 1+ tail rot drop
-        ] if
-    ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
-    dup empty? [
-        2drop [ "Unreachable" throw ] { }
-    ] [
-        0 swap (simplify-alist)
-    ] if ;
 
 : default-method ( word -- pair )
     "default-method" word-prop

core/inference/backend/backend.factor

@@ -3,14 +3,23 @@
 USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
-: inline? ( word -- ? )
+GENERIC: inline? ( word -- ? )
-    dup "method-generic" word-prop swap or "inline" word-prop ;
+
+M: method-body inline?
+    "method-generic" word-prop inline? ;
+
+M: tuple-dispatch-engine-word inline?
+    "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+    "inline" word-prop ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys

core/inference/class/class-tests.factor

@@ -120,7 +120,7 @@ M: object xyz ;
     [
         [ no-cond ] 1
         [ 1array dup quotation? [ >quotation ] unless ] times
-    ] \ type inlined?
+    ] \ quotation? inlined?
 ] unit-test
 
 [ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test

core/inference/known-words/known-words.factor

@@ -383,9 +383,6 @@ set-primitive-effect
 \ millis { } { integer } <effect> set-primitive-effect
 \ millis make-flushable
 
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
 \ tag { object } { fixnum } <effect> set-primitive-effect
 \ tag make-foldable
 

core/kernel/kernel-docs.factor

@@ -413,12 +413,6 @@ HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
 
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
 HELP: ? ( ? true false -- true/false )
 { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
 { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;

core/kernel/kernel.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private ;
+USING: kernel.private slots.private ;
 IN: kernel
 
 ! Stack stuff
@@ -99,14 +99,14 @@ DEFER: if
 
 ! Appliers
 : bi@ ( x y quot -- )
-    tuck 2slip call ; inline
+    dup bi* ; inline
 
 : tri@ ( x y z quot -- )
-    tuck >r bi@ r> call ; inline
+    dup dup tri* ; inline
 
 ! Double appliers
 : 2bi@ ( w x y z quot -- )
-    dup -roll 3slip call ; inline
+    dup 2bi* ; inline
 
 : while ( pred body tail -- )
     >r >r dup slip r> r> roll
@@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 <PRIVATE
 
+: hi-tag ( obj -- n ) 0 slot ;
+
 : declare ( spec -- ) drop ;
 
 : do-primitive ( number -- ) "Improper primitive call" throw ;

core/layouts/layouts-docs.factor

@@ -14,7 +14,7 @@ HELP: tag-mask
 { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
 
 HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
 
 HELP: tag-number
 { $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
 
 ARTICLE: "layouts-types" "Type numbers"
 "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
 "Built-in type numbers can be converted to classes, and vice versa:"
 { $subsection type>class }
 { $subsection type-number }

core/optimizer/known-words/known-words.factor

@@ -87,29 +87,6 @@ sequences.private combinators ;
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
-    node-class-first class-types length 1 number= ;
-
-: fold-known-type ( node -- node )
-    dup node-class-first class-types inline-literals ;
-
-\ type [
-    { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
-    [
-        num-types get swap [
-            [
-                [ type>class object or 0 `input class, ] keep
-                0 `output literal,
-            ] set-constraints
-        ] curry each
-    ] "constraints" set-word-prop
-] each
-
 ! Specializers
 { 1+ 1- sq neg recip sgn } [
     { number } "specializer" set-word-prop