classes.union: speed up instance? on unions of tuple-classes.

core/classes/tuple/tuple.factor

@@ -1,11 +1,18 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: classes.tuple
+! for classes.union mutual dependency
+DEFER: tuple-class?
+<PRIVATE
+DEFER: echelon-of
+DEFER: layout-of
+DEFER: layout-class-offset
+PRIVATE>
 USING: accessors arrays assocs classes classes.algebra
 classes.algebra.private classes.builtin classes.private
 combinators definitions effects generic kernel kernel.private
 make math math.private memory namespaces quotations
 sequences sequences.private slots slots.private strings words ;
-IN: classes.tuple
 
 <PRIVATE
 PRIMITIVE: <tuple> ( layout -- tuple )

core/classes/union/union.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs classes classes.algebra
 classes.algebra.private classes.builtin classes.private
-combinators definitions kernel kernel.private math math.private
+classes.tuple classes.tuple.private combinators definitions
-quotations sequences sets sorting words ;
+kernel kernel.private math math.private quotations sequences
+slots.private sorting words ;
 IN: classes.union
 
 PREDICATE: union-class < class
@@ -24,32 +25,66 @@ M: class union-of-builtins?
 : empty-union-predicate-quot ( class -- quot )
     drop [ drop f ] ;
 
-: fast-union-mask ( class/builtin-classes -- n )
+: flatten-builtins ( class/builtin-classes -- seq )
-    dup sequence? [ flatten-class ] unless
+    dup sequence? [
+        [ flatten-class ] map concat
+    ] [
+        flatten-class
+    ] if ;
+
+: builtin-union-mask ( builtin-classes -- n )
     0 [ class>type 2^ bitor ] reduce ;
 
-: fast-union-predicate-quot ( class/builtin-classes -- quot )
+: builtin-union-predicate-quot ( class/builtin-classes -- quot )
-    fast-union-mask 1quotation
+    flatten-builtins dup length 1 = [
+        first class>type [ eq? ] curry [ tag ] prepose
+    ] [
+        builtin-union-mask 1quotation
         [ tag 1 swap fixnum-shift-fast ]
         [ fixnum-bitand 0 eq? not ]
-    surround ;
+        surround
+    ] if ;
 
-: slow-union-predicate-quot ( class -- quot )
+: predicate-quot ( predicates -- quot )
-    class-members
+    unclip swap
-    dup [ builtin-class? ] count 1 > [
-        [ builtin-class? ] partition
-        [ predicate-def ] map swap
-        [ fast-union-predicate-quot suffix ] unless-empty
-    ] [
-        [ predicate-def ] map
-    ] if unclip swap
     [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
 
+! this replicates logic in classes.tuple, keep in sync
+: tuple-union-predicate-quot/1 ( tuple-classes -- quot )
+    [ [ eq? ] curry ] map predicate-quot
+    [ 7 slot ] prepose ;
+
+: tuple-union-predicate-quot/n ( echelon tuple-classes -- quot )
+    [ layout-class-offset ] dip
+    [ [ eq? ] curry ] map predicate-quot
+    over [ slot ] curry prepose [ drop f ] [ if ] 2curry
+    swap [ fixnum>= ] curry [ dup 1 slot ] prepose prepose ;
+
+: tuple-union-predicate-quot ( tuple-classes -- quot )
+    [ echelon-of 1 = ] partition
+    [ [ f ] [ tuple-union-predicate-quot/1 ] if-empty ] dip
+    [ echelon-of ] collect-by sort-keys
+    [ tuple-union-predicate-quot/n ] { } assoc>map
+    swap [ suffix ] when* predicate-quot
+    [ layout-of ] prepose [ drop f ] [ if ] 2curry
+    [ dup tuple? ] prepose ;
+
+: full-union-predicate-quot ( class -- quot )
+    class-members
+    [ union-of-builtins? ] partition
+    [ [ f ] [ builtin-union-predicate-quot ] if-empty ] dip
+    [ tuple-class? ] partition
+    [ [ f ] [ tuple-union-predicate-quot ] if-empty ] dip
+    [ predicate-def ] map
+    swap [ suffix ] when*
+    swap [ suffix ] when*
+    predicate-quot ;
+
 : union-predicate-quot ( class -- quot )
     {
         { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
-        { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
+        { [ dup union-of-builtins? ] [ builtin-union-predicate-quot ] }
-        [ slow-union-predicate-quot ]
+        [ full-union-predicate-quot ]
     } cond ;
 
 : define-union-predicate ( class -- )