Performance improvements

core/generic/standard/engines/engines.factor

@@ -1,16 +1,16 @@
-USING: assocs kernel namespaces quotations generic math
-sequences combinators words classes.algebra ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel kernel.private namespaces quotations
+generic math sequences combinators words classes.algebra arrays
+;
 IN: generic.standard.engines
 
 SYMBOL: default
 SYMBOL: assumed
+SYMBOL: (dispatch#)
 
 GENERIC: engine>quot ( engine -- quot )
 
-M: quotation engine>quot ;
-
-M: method-body engine>quot 1quotation ;
-
 : engines>quots ( assoc -- assoc' )
     [ engine>quot ] assoc-map ;
 
@@ -36,8 +36,6 @@ M: method-body engine>quot 1quotation ;
         r> execute r> pick set-at
     ] if ; inline
 
-SYMBOL: (dispatch#)
-
 : (picker) ( n -- quot )
     {
         { 0 [ [ dup ] ] }

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

@@ -1,6 +1,8 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: generic.standard.engines generic namespaces kernel
-sequences classes.algebra accessors words combinators
-assocs ;
+kernel.private sequences classes.algebra accessors words
+combinators assocs arrays ;
 IN: generic.standard.engines.predicate
 
 TUPLE: predicate-dispatch-engine methods ;
@@ -24,8 +26,13 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
 : sort-methods ( assoc -- assoc' )
     >alist [ keys sort-classes ] keep extract-keys ;
 
+: methods-with-default ( engine -- assoc )
+    methods>> clone default get object bootstrap-word pick set-at ;
+
 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 ;
+    methods-with-default
+    engines>quots
+    sort-methods
+    prune-redundant-predicates
+    class-predicates
+    alist>quot ;

core/generic/standard/standard.factor

@@ -10,7 +10,16 @@ IN: generic.standard
 
 GENERIC: dispatch# ( word -- n )
 
-M: word dispatch# "combination" word-prop dispatch# ;
+M: generic dispatch#
+    "combination" word-prop dispatch# ;
+
+GENERIC: method-declaration ( class generic -- quot )
+
+M: generic method-declaration
+    "combination" word-prop method-declaration ;
+
+M: quotation engine>quot
+    assumed get generic get method-declaration prepend ;
 
 : unpickers
     {
@@ -135,6 +144,9 @@ M: standard-combination perform-combination
 
 M: standard-combination dispatch# #>> ;
 
+M: standard-combination method-declaration
+    dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
+
 M: standard-combination next-method-quot*
     [
         single-next-method-quot picker prepend
@@ -157,6 +169,8 @@ PREDICATE: hook-generic < generic
 
 M: hook-combination dispatch# drop 0 ;
 
+M: hook-combination method-declaration 2drop [ ] ;
+
 M: hook-generic extra-values drop 1 ;
 
 M: hook-generic effective-method

core/optimizer/inlining/inlining.factor

@@ -191,6 +191,10 @@ DEFER: (flat-length)
 : apply-identities ( node -- node/f )
     dup find-identity f splice-quot ;
 
+: splice-word-def ( #call word def -- node )
+    [ drop +inlined+ depends-on ] [ swap 1array ] 2bi
+    splice-quot ;
+
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [
         >r node-input-classes r> specialized-length tail*
@@ -199,22 +203,20 @@ DEFER: (flat-length)
         2drop f
     ] if ;
 
-: splice-word-def ( #call word -- node )
-    dup +inlined+ depends-on
-    dup def>> swap 1array splice-quot ;
+: already-inlined? ( #call -- ? )
+    [ param>> ] [ history>> ] bi memq? ;
 
 : optimistic-inline ( #call -- node )
-    dup node-param over node-history memq? [
-        drop t
-    ] [
-        dup node-param splice-word-def
+    dup already-inlined? [ drop t ] [
+        dup param>> dup def>> splice-word-def
     ] if ;
 
 : should-inline? ( word -- ? )
     flat-length 11 <= ;
 
 : method-body-inline? ( #call -- ? )
-    node-param dup method-body? [ should-inline? ] [ drop f ] if ;
+    param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+    [ should-inline? ] [ drop f ] if ;
 
 M: #call optimize-node*
     {

core/optimizer/specializers/specializers.factor

@@ -18,13 +18,6 @@ IN: optimizer.specializers
         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
     ] if ;
 
-: tag-specializer ( quot -- newquot )
-    [
-        [ dup tag ] %
-        num-tags get swap <array> ,
-        \ dispatch ,
-    ] [ ] make ;
-
 : specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
@@ -39,11 +32,7 @@ IN: optimizer.specializers
     method-declaration [ declare ] curry prepend ;
 
 : specialize-quot ( quot specializer -- quot' )
-    dup { number } = [
-        drop tag-specializer
-    ] [
-        specializer-cases alist>quot
-    ] if ;
+    specializer-cases alist>quot ;
 
 : standard-method? ( method -- ? )
     dup method-body? [