Bit sets use new new set protocol, and compiler.cfg.ssa.construction.tdmsc is updated for it

db4
Daniel Ehrenberg 2010-02-16 15:14:32 -06:00
parent c36ff9dab8
commit 30cc248bb3
5 changed files with 269 additions and 38 deletions

View File

@ -1,17 +1,60 @@
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

View File

@ -1,8 +1,33 @@
! 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 )
@ -14,18 +39,33 @@ IN: bit-sets
] 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 ;
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
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 ;

View File

@ -3,6 +3,7 @@
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
@ -15,7 +16,7 @@ IN: compiler.cfg.ssa.construction.tdmsc
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 [
@ -29,15 +30,12 @@ SYMBOLS: visited merge-sets levels again? ;
: 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 ;
@ -54,7 +52,7 @@ SYMBOLS: visited merge-sets levels again? ;
: 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 [
@ -82,14 +80,9 @@ SYMBOLS: visited merge-sets levels again? ;
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 -- )
@ -101,10 +94,8 @@ PRIVATE>
[ 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

View File

@ -0,0 +1,69 @@
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: new-sets tools.test kernel sorting prettyprint bit-arrays arrays ;
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 } ] [ HS{ 1 2 3 } members natural-sort ] unit-test
[ "HS{ 1 2 3 4 }" ] [ HS{ 1 2 3 4 } unparse ] unit-test
[ t ] [ 1 HS{ 0 1 2 } in? ] unit-test
[ f ] [ 3 HS{ 0 1 2 } in? ] unit-test
[ HS{ 1 2 3 } ] [ 3 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
[ HS{ 1 2 } ] [ 2 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
[ HS{ 1 2 3 } ] [ 4 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
[ HS{ 1 2 } ] [ 3 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
[ HS{ 1 2 } ] [ HS{ 1 2 } fast-set ] unit-test
[ { 1 2 } ] [ HS{ 1 2 } members natural-sort ] unit-test
[ HS{ 1 2 3 4 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } union ] unit-test
[ HS{ 2 3 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersect ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersects? ] unit-test
[ f ] [ HS{ 1 } HS{ 2 3 4 } intersects? ] unit-test
[ f ] [ HS{ 1 } HS{ 2 3 4 } subset? ] unit-test
[ f ] [ HS{ 1 2 3 } HS{ 2 3 4 } subset? ] unit-test
[ t ] [ HS{ 2 3 } HS{ 2 3 4 } subset? ] unit-test
[ t ] [ HS{ } HS{ 2 3 4 } subset? ] unit-test
[ HS{ 1 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } diff ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } set= ] unit-test
[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } = ] unit-test
[ f ] [ HS{ 2 3 } HS{ 2 1 3 } set= ] unit-test
[ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
[ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test

View File

@ -0,0 +1,88 @@
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs hashtables kernel
math sequences parser prettyprint.custom ;
QUALIFIED: sets
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 ;
! Hash sets
! In a better implementation, less memory would be used
TUPLE: hash-set { table hashtable read-only } ;
: <hash-set> ( members -- hash-set )
sets:unique hash-set boa ;
INSTANCE: hash-set set
M: hash-set in? table>> key? ; inline
M: hash-set adjoin table>> dupd set-at ; inline
M: hash-set delete table>> delete-at ; inline
M: hash-set members table>> keys ; inline
M: hash-set set-like
drop dup hash-set? [ members <hash-set> ] unless ;
M: hash-set clone
table>> clone hash-set boa ;
SYNTAX: HS{
\ } [ <hash-set> ] parse-literal ;
M: hash-set pprint* pprint-object ;
M: hash-set pprint-delims drop \ HS{ \ } ;
M: hash-set >pprint-sequence members ;
! Sequences are sets
INSTANCE: sequence set
M: sequence in? member? ; inline
M: sequence adjoin sets:adjoin ; inline
M: sequence delete remove! drop ; inline
M: sequence set-like
[ dup sequence? [ sets:prune ] [ members ] if ] dip
like ;
M: sequence members ;
M: sequence fast-set <hash-set> ;