-USING: bit-sets tools.test bit-arrays ;
+USING: bit-sets tools.test new-sets kernel bit-arrays ;
IN: bit-sets.tests
-[ ?{ t f t f t f } ] [
- ?{ t f f f t f }
- ?{ f f t f t f } bit-set-union
+[ T{ bit-set f ?{ t f t f t f } } ] [
+ T{ bit-set f ?{ t f f f t f } }
+ T{ bit-set f ?{ f f t f t f } } union
] unit-test
-[ ?{ f f f f t f } ] [
- ?{ t f f f t f }
- ?{ f f t f t f } bit-set-intersect
+[ T{ bit-set f ?{ f f f f t f } } ] [
+ T{ bit-set f ?{ t f f f t f } }
+ T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
-[ ?{ t f t f f f } ] [
- ?{ t t t f f f }
- ?{ f t f f t t } bit-set-diff
+[ T{ bit-set f ?{ t f t f f f } } ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f t t } } diff
] unit-test
+
+[ f ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f t t } } subset?
+] unit-test
+
+[ t ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ t ] [
+ { 0 1 2 }
+ T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ f ] [
+ T{ bit-set f ?{ f t f f f f } }
+ T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ f ] [
+ { 1 }
+ T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
+
+[ t V{ 1 2 3 } ] [
+ { 1 2 } 5 <bit-set> set-like
+ [ bit-set? ] keep
+ 3 over adjoin
+ members
+] unit-test
+
+[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
+[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
+[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
+
+[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
+
+[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
+[ 1 <bit-set> dup clone 0 over adjoin ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+USING: kernel accessors sequences byte-arrays bit-arrays math hints new-sets ;
IN: bit-sets
+TUPLE: bit-set { table bit-array read-only } ;
+
+: <bit-set> ( capacity -- bit-set )
+ <bit-array> bit-set boa ;
+
+INSTANCE: bit-set set
+
+M: bit-set in?
+ over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
+
+M: bit-set adjoin
+ ! This is allowed to crash when the elt couldn't go in the set
+ [ t ] 2dip table>> set-nth ;
+
+M: bit-set delete
+ ! This isn't allowed to crash if the elt wasn't in the set
+ over integer? [
+ table>> 2dup bounds-check? [
+ [ f ] 2dip set-nth
+ ] [ 2drop ] if
+ ] [ 2drop ] if ;
+
+! If you do binary set operations with a bitset, it's expected
+! that the other thing can also be represented as a bitset
+! of the same length.
<PRIVATE
: bit-set-map ( seq1 seq2 quot -- seq )
] dip 2map
] 3bi bit-array boa ; inline
+: (bit-set-op) ( set1 set2 -- table1 table2 )
+ [ set-like ] keep [ table>> ] bi@ ; inline
+
+: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
+ [ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
+
PRIVATE>
-: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+M: bit-set union
+ [ bitor ] bit-set-op ;
-HINTS: bit-set-union bit-array bit-array ;
+M: bit-set intersect
+ [ bitand ] bit-set-op ;
-: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+M: bit-set diff
+ [ bitnot bitand ] bit-set-op ;
-HINTS: bit-set-intersect bit-array bit-array ;
+M: bit-set subset?
+ [ intersect ] keep = ;
-: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+M: bit-set members
+ [ table>> length iota ] keep [ in? ] curry filter ;
-HINTS: bit-set-diff bit-array bit-array ;
+M: bit-set set-like
+ ! This crashes if there are keys that can't be put in the bit set
+ over bit-set? [ 2dup [ table>> ] bi@ length = ] [ f ] if
+ [ drop ] [
+ [ members ] dip table>> length <bit-set>
+ [ [ adjoin ] curry each ] keep
+ ] if ;
-: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
\ No newline at end of file
+M: bit-set clone
+ table>> clone bit-set boa ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
+USING: accessors assocs kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.predecessors ;
+compiler.cfg.rpo compiler.cfg.predecessors hash-sets new-sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
SYMBOL: live-vregs
: live-vreg? ( vreg -- ? )
- live-vregs get key? ;
+ live-vregs get in? ;
! vregs which are the result of an allocation
SYMBOL: allocations
: allocation? ( vreg -- ? )
- allocations get key? ;
+ allocations get in? ;
: init-dead-code ( -- )
H{ } clone liveness-graph set
- H{ } clone live-vregs set
- H{ } clone allocations set ;
+ HS{ } clone live-vregs set
+ HS{ } clone allocations set ;
GENERIC: build-liveness-graph ( insn -- )
dup src>> setter-liveness-graph ;
M: ##allot build-liveness-graph
- [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
+ [ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
: (record-live) ( vregs -- )
[
- dup live-vregs get key? [ drop ] [
- [ live-vregs get conjoin ]
+ dup live-vreg? [ drop ] [
+ [ live-vregs get adjoin ]
[ liveness-graph get at (record-live) ]
bi
] if
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
-fry math sets compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors ;
+fry math compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg.loop-detection compiler.cfg.predecessors
+new-sets hash-sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
SYMBOLS: work-list loop-heads visited ;
-: visited? ( bb -- ? ) visited get key? ;
+: visited? ( bb -- ? ) visited get in? ;
: add-to-work-list ( bb -- )
- dup visited get key? [ drop ] [
+ dup visited? [ drop ] [
work-list get push-back
] if ;
: init-linearization-order ( cfg -- )
<dlist> work-list set
- H{ } clone visited set
+ HS{ } clone visited set
entry>> add-to-work-list ;
: (find-alternate-loop-head) ( bb -- bb' )
: process-block ( bb -- )
dup visited? [ drop ] [
[ , ]
- [ visited get conjoin ]
+ [ visited get adjoin ]
[ sorted-successors [ process-successor ] each ]
tri
] if ;
dup linear-order>> [ ] [
dup (linearization-order)
>>linear-order linear-order>>
- ] ?if ;
\ No newline at end of file
+ ] ?if ;
USING: accessors arrays assocs bit-arrays bit-sets fry
hashtables hints kernel locals math namespaces sequences sets
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+QUALIFIED: new-sets
IN: compiler.cfg.ssa.construction.tdmsc
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
SYMBOLS: visited merge-sets levels again? ;
: init-merge-sets ( cfg -- )
- post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+ post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
: compute-levels ( cfg -- )
0 over entry>> associate [
: level ( bb -- n ) levels get at ; inline
-: set-bit ( bit-array n -- )
- [ t ] 2dip swap set-nth ;
-
: update-merge-set ( tmp to -- )
[ merge-sets get ] dip
'[
_
- [ merge-sets get at bit-set-union ]
- [ dupd number>> set-bit ]
+ [ merge-sets get at new-sets:union ]
+ [ number>> over new-sets:adjoin ]
bi
] change-at ;
: visited? ( pair -- ? ) visited get key? ;
: consistent? ( snode lnode -- ? )
- [ merge-sets get at ] bi@ swap bit-set-subset? ;
+ [ merge-sets get at ] bi@ new-sets:subset? ;
: (process-edge) ( from to -- )
f walk [
loop ;
: (merge-set) ( bbs -- flags rpo )
- merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+ merge-sets get '[ _ at ] [ new-sets:union ] map-reduce
cfg get reverse-post-order ; inline
-: filter-by ( flags seq -- seq' )
- [ drop ] selector [ 2each ] dip ;
-
-HINTS: filter-by { bit-array object } ;
-
PRIVATE>
: compute-merge-sets ( cfg -- )
[ compute-merge-set-loop ]
tri ;
-: merge-set-each ( bbs quot: ( bb -- ) -- )
- [ (merge-set) ] dip '[
- swap _ [ drop ] if
- ] 2each ; inline
-
: merge-set ( bbs -- bbs' )
- (merge-set) filter-by ;
+ (merge-set) [ new-sets:members ] dip nths ;
+
+: merge-set-each ( bbs quot: ( bb -- ) -- )
+ [ merge-set ] dip each ; inline
--- /dev/null
+! Copyright (C) 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: new-sets tools.test kernel prettyprint hash-sets sorting ;
+IN: new-sets.tests
+
+[ { } ] [ { } { } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+
+[ { } ] [ { } { } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+
+[ { } ] [ { } { } union ] unit-test
+[ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { } { 1 } intersects? ] unit-test
+
+[ f ] [ { 1 } { } intersects? ] unit-test
+
+[ t ] [ 4 { 2 4 5 } in? ] unit-test
+[ f ] [ 1 { 2 4 5 } in? ] unit-test
+
+[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
+[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
+
+[ t ] [ { 1 2 3 } { 2 1 3 } set= ] unit-test
+[ f ] [ { 2 3 } { 1 2 3 } set= ] unit-test
+[ f ] [ { 1 2 3 } { 2 3 } set= ] unit-test
+
+[ { 1 } ] [ { 1 } members ] unit-test
+
+[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
+[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
+
+[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
+
+[ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
--- /dev/null
+! Copyright (C) 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables kernel
+math sequences parser prettyprint.custom ;
+FROM: sets => prune ;
+IN: new-sets
+! The vocab is called new-sets for now, but only until it gets into core
+! All the code here is in the style that could be put in core
+
+! Set protocol
+MIXIN: set
+GENERIC: adjoin ( elt set -- )
+GENERIC: in? ( elt set -- ? )
+GENERIC: delete ( elt set -- )
+GENERIC: set-like ( set exemplar -- set' )
+GENERIC: fast-set ( set -- set' )
+GENERIC: members ( set -- sequence )
+GENERIC: union ( set1 set2 -- set )
+GENERIC: intersect ( set1 set2 -- set )
+GENERIC: intersects? ( set1 set2 -- ? )
+GENERIC: diff ( set1 set2 -- set )
+GENERIC: subset? ( set1 set2 -- ? )
+GENERIC: set= ( set1 set2 -- ? )
+
+! Defaults for some methods.
+! Override them for efficiency
+
+M: set union
+ [ [ members ] bi@ append ] keep set-like ;
+
+<PRIVATE
+
+: sequence/tester ( set1 set2 -- set1' quot )
+ [ members ] [ fast-set [ in? ] curry ] bi* ; inline
+
+PRIVATE>
+
+M: set intersect
+ [ sequence/tester filter ] keep set-like ;
+
+M: set diff
+ [ sequence/tester [ not ] compose filter ] keep set-like ;
+
+M: set intersects?
+ sequence/tester any? ;
+
+M: set subset?
+ sequence/tester all? ;
+
+M: set set=
+ 2dup subset? [ swap subset? ] [ 2drop f ] if ;
+
+M: set fast-set ;
+
+! Sequences are sets
+INSTANCE: sequence set
+M: sequence in? member? ; inline
+M: sequence adjoin [ delete ] [ push ] 2bi ;
+M: sequence delete remove! drop ; inline
+M: sequence set-like
+ [ dup sequence? [ prune ] [ members ] if ] dip like ;
+M: sequence members fast-set members ;
+
+USE: vocabs.loader
+"hash-sets" require
+
+: combine ( sets -- set )
+ f [ union ] reduce ;
projects / factor.git / commitdiff