steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

classes.union: faster builtin-class check, for example sequence?.

clean-macosx-x86-64
John Benediktsson 2019-11-06 14:13:13 -08:00
parent 17aa52f51c
commit 12dc9e7ab7
1 changed files with 14 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
core/classes/union/union.factor
View File

@ -3,7 +3,7 @@
USING: accessors assocs classes classes.algebra USING: accessors assocs classes classes.algebra
classes.algebra.private classes.builtin classes.private classes.algebra.private classes.builtin classes.private
combinators definitions kernel kernel.private math math.private combinators definitions kernel kernel.private math math.private
quotations sequences sets words ; quotations sequences sets sorting words ;
IN: classes.union IN: classes.union
PREDICATE: union-class < class PREDICATE: union-class < class
@ -21,20 +21,28 @@ M: union-class union-of-builtins?
M: class union-of-builtins? M: class union-of-builtins?
drop f ; drop f ;
: fast-union-mask ( class -- n )
flatten-class 0 [ class>type 2^ bitor ] reduce ;
: empty-union-predicate-quot ( class -- quot ) : empty-union-predicate-quot ( class -- quot )
drop [ drop f ] ; drop [ drop f ] ;
: fast-union-predicate-quot ( class -- quot ) : fast-union-mask ( class/builtin-classes -- n )
dup sequence? [ flatten-class ] unless
0 [ class>type 2^ bitor ] reduce ;
: fast-union-predicate-quot ( class/builtin-classes -- quot )
fast-union-mask 1quotation fast-union-mask 1quotation
[ tag 1 swap fixnum-shift-fast ] [ tag 1 swap fixnum-shift-fast ]
[ fixnum-bitand 0 eq? not ] [ fixnum-bitand 0 eq? not ]
surround ; surround ;
: slow-union-predicate-quot ( class -- quot ) : slow-union-predicate-quot ( class -- quot )
class-members [ predicate-def ] map unclip swap class-members
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 ; [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
: union-predicate-quot ( class -- quot ) : union-predicate-quot ( class -- quot )