Various optimizations leading to a 10% speedup on compiling empty EBNF parser:

- open-code getenv primitive
- inline tuple predicates in finalization
- faster partial dispatch
- faster built-in type predicates
- faster tuple predicates
- faster lo-tag dispatch
- compile V{ } clone and H{ } clone more efficiently
- add fixnum fast-path to =; avoid indirect branch if two fixnums not eq
- faster >alist on hashtables

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
+USING: kernel math namespaces assocs hashtables sequences arrays
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.copy-prop ;
@@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
 M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
+M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 
 M: ##peek insn-object loc>> class ;
 M: ##replace insn-object loc>> class ;
@@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
+M: ##alien-global insn-object drop \ ##alien-global ;
 
 : init-alias-analysis ( -- )
     H{ } clone histories set
@@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
 M: ##load-indirect analyze-aliases*
     dup dst>> set-heap-ac ;
 
+M: ##alien-global analyze-aliases*
+    dup dst>> set-heap-ac ;
+
 M: ##allot analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.

basis/compiler/cfg/hats/hats.factor

@@ -65,6 +65,7 @@ IN: compiler.cfg.hats
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
 : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
 : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -161,6 +161,8 @@ INSN: ##set-alien-double < ##alien-setter ;
 INSN: ##allot < ##flushable size class { temp vreg } ;
 INSN: ##write-barrier < ##effect card# table ;
 
+INSN: ##alien-global < ##read symbol library ;
+
 ! FFI
 INSN: ##alien-invoke params ;
 INSN: ##alien-indirect params ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -12,8 +12,7 @@ compiler.cfg.registers ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
-    D 0 ^^peek
+    2inputs
-    D 1 ^^peek
     ^^or
     tag-mask get ^^and-imm
     0 cc= ^^compare-imm

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.misc
 compiler.cfg.iterator ;
 QUALIFIED: kernel
 QUALIFIED: arrays
@@ -23,6 +24,7 @@ IN: compiler.cfg.intrinsics
 
 {
     kernel.private:tag
+    kernel.private:getenv
     math.private:both-fixnums?
     math.private:fixnum+
     math.private:fixnum-
@@ -94,6 +96,7 @@ IN: compiler.cfg.intrinsics
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
+        { \ kernel.private:getenv [ emit-getenv iterate-next ] }
         { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces layouts sequences kernel
+accessors compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.misc
+
+: emit-tag ( -- )
+    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+
+: emit-getenv ( node -- )
+    "userenv" f ^^alien-global
+    swap node-input-infos first literal>>
+    [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
+    ds-push ;

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.slots
 
-: emit-tag ( -- )
-    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
-
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )

basis/compiler/codegen/codegen.factor

@@ -236,6 +236,10 @@ M: _gc generate-insn drop %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
+M: ##alien-global generate-insn
+    [ dst>> register ] [ symbol>> ] [ library>> ] tri
+    %alien-global ;
+
 ! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )
 

basis/compiler/tree/finalization/finalization.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences words memoize classes.builtin
+USING: kernel accessors sequences words memoize combinators
+classes classes.builtin classes.tuple math.partial-dispatch
 fry assocs
 compiler.tree
 compiler.tree.combinators
@@ -12,7 +13,7 @@ IN: compiler.tree.finalization
 ! See the comment in compiler.tree.late-optimizations.
 
 ! This pass runs after propagation, so that it can expand
-! built-in type predicates; these cannot be expanded before
+! type predicates; these cannot be expanded before
 ! propagation since we need to see 'fixnum?' instead of
 ! 'tag 0 eq?' and so on, for semantic reasoning.
 
@@ -33,16 +34,24 @@ M: #shuffle finalize*
     [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
     bi and [ drop f ] when ;
 
-: builtin-predicate? ( #call -- ? )
+MEMO: cached-expansion ( word -- nodes )
-    word>> "predicating" word-prop builtin-class? ;
-
-MEMO: builtin-predicate-expansion ( word -- nodes )
     def>> splice-final ;
 
-: expand-builtin-predicate ( #call -- nodes )
+GENERIC: finalize-word ( #call word -- nodes )
-    word>> builtin-predicate-expansion ;
+
+M: predicate finalize-word
+    "predicating" word-prop {
+        { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
+        { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
+        [ drop ]
+    } cond ;
+
+! M: math-partial finalize-word
+!     dup primitive? [ drop ] [ nip cached-expansion ] if ;
+
+M: word finalize-word drop ;
 
 M: #call finalize*
-    dup builtin-predicate? [ expand-builtin-predicate ] when ;
+    dup word>> finalize-word ;
 
 M: node finalize* ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -193,13 +193,14 @@ SYMBOL: history
     #! of bounds value. This case comes up if a parsing word
     #! calls the compiler at parse time (doing so is
     #! discouraged, but it should still work.)
-    {
+    dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [
-        { [ dup deferred? ] [ 2drop f ] }
+        {
-        { [ dup custom-inlining? ] [ inline-custom ] }
+            { [ dup deferred? ] [ 2drop f ] }
-        { [ dup \ instance? eq? ] [ inline-instance-check ] }
+            { [ dup \ instance? eq? ] [ inline-instance-check ] }
-        { [ dup always-inline-word? ] [ inline-word ] }
+            { [ dup always-inline-word? ] [ inline-word ] }
-        { [ dup standard-generic? ] [ inline-standard-method ] }
+            { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup math-generic? ] [ inline-math-method ] }
+            { [ dup math-generic? ] [ inline-math-method ] }
-        { [ dup method-body? ] [ inline-method-body ] }
+            { [ dup method-body? ] [ inline-method-body ] }
-        [ 2drop f ]
+            [ 2drop f ]
-    } cond ;
+        } cond
+    ] if ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order
 layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
-definitions strings.private
+definitions strings.private vectors hashtables
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -194,6 +194,11 @@ generic-comparison-ops [
     2bi and maybe-or-never
 ] "outputs" set-word-prop
 
+\ both-fixnums? [
+    [ class>> fixnum classes-intersect? not ] either?
+    f <literal-info> object-info ?
+] "outputs" set-word-prop
+
 {
     { >fixnum fixnum }
     { bignum>fixnum fixnum }
@@ -287,6 +292,15 @@ generic-comparison-ops [
     "outputs" set-word-prop
 ] each
 
+! Generate more efficient code for common idiom
+\ clone [
+    in-d>> first value-info literal>> {
+        { V{ } [ [ drop { } 0 vector boa ] ] }
+        { H{ } [ [ drop hashtable new ] ] }
+        [ drop f ]
+    } case
+] "custom-inlining" set-word-prop
+
 \ slot [
     dup literal?>>
     [ literal>> swap value-info-slot ] [ 2drop object-info ] if

basis/cpu/architecture/architecture.factor

@@ -120,6 +120,8 @@ HOOK: %set-alien-cell      cpu ( ptr value -- )
 HOOK: %set-alien-float     cpu ( ptr value -- )
 HOOK: %set-alien-double    cpu ( ptr value -- )
 
+HOOK: %alien-global cpu ( dst symbol library -- )
+
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
 HOOK: %gc cpu ( -- )

basis/cpu/x86/32/32.factor

@@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ;
 
 M: x86.32 reserved-area-size 0 ;
 
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;

basis/cpu/x86/64/64.factor

@@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- )
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: x86.64 %alien-global
-    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
 M: x86.64 %alien-invoke
     R11 0 MOV
     rc-absolute-cell rel-dlsym

basis/cpu/x86/bootstrap.factor

@@ -381,8 +381,8 @@ big-endian off
 
 [
     arg0 ds-reg [] MOV
-    arg0 ds-reg bootstrap-cell neg [+] OR
+    ds-reg bootstrap-cell SUB
-    ds-reg bootstrap-cell ADD
+    arg0 ds-reg [] OR
     arg0 tag-mask get AND
     arg0 \ f tag-number MOV
     arg1 1 tag-fixnum MOV

basis/cpu/x86/x86.factor

@@ -458,19 +458,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
     dst class store-tagged
     nursery-ptr size inc-allot-ptr ;
 
-HOOK: %alien-global cpu ( symbol dll register -- )
-
 M:: x86 %write-barrier ( src card# table -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
     card# src MOV
     card# card-bits SHR
-    "cards_offset" f table %alien-global
+    table "cards_offset" f %alien-global
+    table table [] MOV
     table card# [+] card-mark <byte> MOV
 
     ! Mark the card deck
     card# deck-bits card-bits - SHR
-    "decks_offset" f table %alien-global
+    table "decks_offset" f %alien-global
+    table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
 M: x86 %gc ( -- )
@@ -485,6 +485,9 @@ M: x86 %gc ( -- )
     "minor_gc" f %alien-invoke
     "end" resolve-label ;
 
+M: x86 %alien-global
+    [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+
 HOOK: stack-reg cpu ( -- reg )
 
 : decr-stack-reg ( n -- )
@@ -595,7 +598,8 @@ M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f temp-reg-1 %alien-global
+    temp-reg-1 "stack_chain" f %alien-global
+    temp-reg-1 temp-reg-1 [] MOV
     temp-reg-1 [] stack-reg MOV
     temp-reg-1 [] cell SUB
     temp-reg-1 2 cells [+] ds-reg MOV

basis/math/partial-dispatch/partial-dispatch.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel kernel.private math math.private words
 sequences parser namespaces make assocs quotations arrays locals
 generic generic.math hashtables effects compiler.units
-classes.algebra ;
+classes.algebra fry combinators ;
 IN: math.partial-dispatch
 
 PREDICATE: math-partial < word
@@ -45,60 +45,62 @@ M: word integer-op-input-classes
         { bitnot fixnum-bitnot }
     } at swap or ;
 
-:: fixnum-integer-op ( a b fix-word big-word -- c )
+:: integer-fixnum-op-quot ( fix-word big-word -- quot )
-    b tag 0 eq? [
-        a b fix-word execute
-    ] [
-       a fixnum>bignum b big-word execute
-    ] if ; inline
-
-:: integer-fixnum-op ( a b fix-word big-word -- c )
-    a tag 0 eq? [
-        a b fix-word execute
-    ] [
-        a b fixnum>bignum big-word execute
-    ] if ; inline
-
-:: integer-integer-op ( a b fix-word big-word -- c )
-    b tag 0 eq? [
-        a b fix-word big-word integer-fixnum-op
-    ] [
-        a dup tag 0 eq? [ fixnum>bignum ] when
-        b big-word execute
-    ] if ; inline
-
-: integer-op-combinator ( triple -- word )
     [
-        [ second name>> % "-" % ]
+        [ over fixnum? ] %
-        [ third name>> % "-op" % ]
+        fix-word '[ _ execute ] ,
-        bi
+        big-word '[ fixnum>bignum _ execute ] ,
-    ] "" make "math.partial-dispatch" lookup ;
+        \ if ,
+    ] [ ] make ;
+
+:: fixnum-integer-op-quot ( fix-word big-word -- quot )
+    [
+        [ dup fixnum? ] %
+        fix-word '[ _ execute ] ,
+        big-word '[ [ fixnum>bignum ] dip _ execute ] ,
+        \ if ,
+    ] [ ] make ;
+
+:: integer-integer-op-quot ( fix-word big-word -- quot )
+    [
+        [ dup fixnum? ] %
+        fix-word big-word integer-fixnum-op-quot ,
+        [
+            [ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
+            big-word ,
+        ] [ ] make ,
+        \ if ,
+    ] [ ] make ;
 
 : integer-op-word ( triple -- word )
     [ name>> ] map "-" join "math.partial-dispatch" create ;
 
-: integer-op-quot ( triple fix-word big-word -- quot )
+: integer-op-quot ( fix-word big-word triple -- quot )
-    rot integer-op-combinator 1quotation 2curry ;
+    [ second ] [ third ] bi 2array {
+        { { fixnum integer } [ fixnum-integer-op-quot ] }
+        { { integer fixnum } [ integer-fixnum-op-quot ] }
+        { { integer integer } [ integer-integer-op-quot ] }
+    } case ;
 
-: define-integer-op-word ( triple fix-word big-word -- )
+: define-integer-op-word ( fix-word big-word triple -- )
     [
-        [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
+        [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
         (( x y -- z )) define-declared
     ] [
-        2drop
+        2nip
         [ integer-op-word ] keep
         "derived-from" set-word-prop
     ] 3bi ;
 
 : define-integer-op-words ( triples fix-word big-word -- )
-    [ define-integer-op-word ] 2curry each ;
+    '[ [ _ _ ] dip define-integer-op-word ] each ;
 
 : integer-op-triples ( word -- triples )
     {
         { fixnum integer }
         { integer fixnum }
         { integer integer }
-    } swap [ prefix ] curry map ;
+    } swap '[ _ prefix ] map ;
 
 : define-integer-ops ( word fix-word big-word -- )
     [
@@ -138,7 +140,7 @@ SYMBOL: fast-math-ops
     [ drop math-class-max swap specific-method >boolean ] if ;
 
 : (derived-ops) ( word assoc -- words )
-    swap [ rot first eq? nip ] curry assoc-filter ;
+    swap '[ swap first _ eq? nip ] assoc-filter ;
 
 : derived-ops ( word -- words )
     [ 1array ] [ math-ops get (derived-ops) values ] bi append ;

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

@@ -307,7 +307,7 @@ M: object infer-call*
 \ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
-\ both-fixnums? { object object } { object object object } define-primitive
+\ both-fixnums? { object object } { object } define-primitive
 
 \ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable

core/bootstrap/primitives.factor

@@ -109,9 +109,6 @@ bootstrapping? on
 } [ create-vocab drop ] each
 
 ! Builtin classes
-: define-builtin-predicate ( class -- )
-    dup class>type [ builtin-instance? ] curry define-predicate ;
-
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
 
@@ -192,6 +189,10 @@ define-union-class
 ] [ ] make
 define-predicate-class
 
+"array-capacity" "sequences.private" lookup
+[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append
+"coercer" set-word-prop
+
 ! Catch-all class for providing a default method.
 "object" "kernel" create
 [ f f { } intersection-class define-class ]

core/classes/builtin/builtin.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra words kernel
 kernel.private namespaces sequences math math.private
-combinators assocs ;
+combinators assocs quotations ;
 IN: classes.builtin
 
 SYMBOL: builtins
@@ -10,10 +10,14 @@ SYMBOL: builtins
 PREDICATE: builtin-class < class
     "metaclass" word-prop builtin-class eq? ;
 
-: type>class ( n -- class ) builtins get-global nth ;
-
 : class>type ( class -- n ) "type" word-prop ; foldable
 
+PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
+
+PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
 : bootstrap-type>class ( n -- class ) builtins get nth ;
 
 M: hi-tag class hi-tag type>class ;
@@ -22,16 +26,20 @@ M: object class tag type>class ;
 
 M: builtin-class rank-class drop 0 ;
 
-: builtin-instance? ( object n -- ? )
+GENERIC: define-builtin-predicate ( class -- )
-    #! 7 == tag-mask get
-    #! 3 == hi-tag tag-number
-    dup 7 fixnum<= [ swap tag eq? ] [
-        swap dup tag 3 eq?
-        [ hi-tag eq? ] [ 2drop f ] if
-    ] if ; inline
 
-M: builtin-class instance?
+M: lo-tag-class define-builtin-predicate
-    class>type builtin-instance? ;
+    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
+M: hi-tag-class define-builtin-predicate
+    dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
+    [ dup tag 3 eq? ] [ [ drop f ] if ] surround
+    define-predicate ;
+
+M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
+
+M: hi-tag-class instance?
+    over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
 
 M: builtin-class (flatten-class) dup set ;
 

core/classes/tuple/tuple.factor

@@ -90,10 +90,10 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
-: tuple-instance-1? ( object class -- ? )
+: tuple-predicate-quot/1 ( class -- quot )
-    swap dup tuple? [
+    #! Fast path for tuples with no superclass
-        layout-of 7 slot eq?
+    [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
-    ] [ 2drop f ] if ; inline
+    [ dup tuple? ] [ [ drop f ] if ] surround ;
 
 : tuple-instance? ( object class offset -- ? )
     rot dup tuple? [
@@ -105,13 +105,16 @@ ERROR: bad-superclass class ;
 : layout-class-offset ( echelon -- n )
     2 * 5 + ;
 
+: tuple-predicate-quot ( class echelon -- quot )
+    layout-class-offset [ tuple-instance? ] 2curry ;
+
 : echelon-of ( class -- n )
     tuple-layout third ;
 
 : define-tuple-predicate ( class -- )
     dup dup echelon-of {
-        { 1 [ [ tuple-instance-1? ] curry ] }
+        { 1 [ tuple-predicate-quot/1 ] }
-        [ layout-class-offset [ tuple-instance? ] 2curry ]
+        [ tuple-predicate-quot ]
     } case define-predicate ;
 
 : class-size ( class -- n )

core/generic/math/math.factor

@@ -83,7 +83,7 @@ M: math-combination perform-combination
     drop
     dup
     [
-        \ both-fixnums? ,
+        [ 2dup both-fixnums? ] %
         dup fixnum bootstrap-word dup math-method ,
         \ over [
             dup math-class? [

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

@@ -3,7 +3,7 @@
 USING: classes.private generic.standard.engines namespaces make
 arrays assocs sequences.private quotations kernel.private
 math slots.private math.private kernel accessors words
-layouts sorting sequences ;
+layouts sorting sequences combinators ;
 IN: generic.standard.engines.tag
 
 TUPLE: lo-tag-dispatch-engine methods ;
@@ -24,15 +24,21 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
 
 : sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
 
+: tag-dispatch-test ( tag# -- quot )
+    picker [ tag ] append swap [ eq? ] curry append ;
+
+: tag-dispatch-quot ( alist -- quot )
+    [ default get ] dip
+    [ [ tag-dispatch-test ] dip ] assoc-map
+    alist>quot ;
+
 M: lo-tag-dispatch-engine engine>quot
     methods>> engines>quots*
     [ [ lo-tag-number ] dip ] assoc-map
     [
-        picker % [ tag ] % [
+        [ sort-tags tag-dispatch-quot ]
-            sort-tags linear-dispatch-quot
+        [ picker % [ tag ] % num-tags get direct-dispatch-quot ]
-        ] [
+        if-small? %
-            num-tags get direct-dispatch-quot
-        ] if-small? %
     ] [ ] make ;
 
 TUPLE: hi-tag-dispatch-engine methods ;

core/hashtables/hashtables.factor

@@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
 : push-unsafe ( elt seq -- )
     [ length ] keep
     [ underlying>> set-array-nth ]
-    [ [ 1+ ] dip (>>length) ]
+    [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
     2bi ; inline
 
 PRIVATE>

core/kernel/kernel.factor

@@ -154,8 +154,11 @@ TUPLE: identity-tuple ;
 
 M: identity-tuple equal? 2drop f ;
 
+USE: math.private
 : = ( obj1 obj2 -- ? )
-    2dup eq? [ 2drop t ] [ equal? ] if ; inline
+    2dup eq? [ 2drop t ] [
+        2dup both-fixnums? [ 2drop f ] [ equal? ] if
+    ] if ; inline
 
 GENERIC: clone ( obj -- cloned )