classes.union: unions of built-in types now have more efficient predicates. Fixes #292

core/classes/union/union-tests.factor

@@ -1,9 +1,10 @@
-USING: alien arrays definitions generic assocs hashtables io
-kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes
+USING: accessors alien arrays definitions generic assocs
+hashtables io kernel math namespaces parser prettyprint
+sequences strings tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
-classes.algebra source-files compiler.units kernel.private
-sorting vocabs io.streams.string eval see ;
+classes.algebra classes.union.private source-files
+compiler.units kernel.private sorting vocabs io.streams.string
+eval see math.private ;
 IN: classes.union.tests
 
 ! DEFER: bah
@@ -49,6 +50,8 @@ UNION: empty-union-2 ;
 
 M: empty-union-2 empty-union-test ;
 
+[ [ drop f ] ] [ \ empty-union-1? def>> ] unit-test
+
 ! Redefining a class didn't update containing unions
 UNION: redefine-bug-1 fixnum ;
 
@@ -90,3 +93,17 @@ M: a-union test-generic ;
 [ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
 
 [ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
+
+! Fast union predicates
+
+[ t ] [ integer union-of-builtins? ] unit-test
+
+[ t ] [ \ integer? def>> \ fixnum-bitand swap member? ] unit-test
+
+[ ] [ "IN: classes.union.tests USE: math UNION: fast-union-1 fixnum ; UNION: fast-union-2 fast-union-1 bignum ;" eval( -- ) ] unit-test
+
+[ t ] [ "fast-union-2?" "classes.union.tests" lookup def>> \ fixnum-bitand swap member? ] unit-test
+
+[ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
+
+[ f ] [ "fast-union-2?" "classes.union.tests" lookup def>> \ fixnum-bitand swap member? ] unit-test

core/classes/union/union.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2004, 2010 Slava Pestov.
+! Copyright (C) 2004, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
 classes.private classes.algebra classes.algebra.private
-namespaces arrays math quotations definitions ;
+classes.builtin kernel.private math.private namespaces arrays
+math quotations definitions ;
 IN: classes.union
 
 PREDICATE: union-class < class
@@ -10,18 +11,42 @@ PREDICATE: union-class < class
 
 <PRIVATE
 
-: union-predicate-quot ( members -- quot )
-    [
-        [ drop f ]
-    ] [
-        unclip "predicate" word-prop swap [
-            "predicate" word-prop [ dup ] prepend
-            [ drop t ]
-        ] { } map>assoc alist>quot
-    ] if-empty ;
+GENERIC: union-of-builtins? ( class -- ? )
+
+M: builtin-class union-of-builtins? drop t ;
+
+M: union-class union-of-builtins?
+    members [ union-of-builtins? ] all? ;
+
+M: class union-of-builtins?
+    drop f ;
+
+: fast-union-mask ( class -- n )
+    [ 0 ] dip flatten-class
+    [ drop class>type 2^ bitor ] assoc-each ;
+
+: empty-union-predicate-quot ( class -- quot )
+    drop [ drop f ] ;
+
+: fast-union-predicate-quot ( class -- quot )
+    fast-union-mask 1quotation
+    [ tag 1 swap fixnum-shift-fast ]
+    [ fixnum-bitand 0 eq? not ]
+    surround ;
+
+: slow-union-predicate-quot ( class -- quot )
+    members [ "predicate" word-prop ] map unclip swap
+    [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
+
+: union-predicate-quot ( class -- quot )
+    {
+        { [ dup members empty? ] [ empty-union-predicate-quot ] }
+        { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
+        [ slow-union-predicate-quot ]
+    } cond ;
 
 : define-union-predicate ( class -- )
-    dup members union-predicate-quot define-predicate ;
+    dup union-predicate-quot define-predicate ;
 
 M: union-class update-class define-union-predicate ;