diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 735a8fcdab..705156ff2c 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -9,7 +9,7 @@ math.integers.private layouts math.order vectors hashtables combinators effects generalizations sequences.generalizations assocs sets combinators.short-circuit sequences.private locals growable stack-checker namespaces compiler.tree.propagation.info -; +hash-sets ; FROM: math => float ; FROM: sets => set ; IN: compiler.tree.propagation.transforms @@ -157,7 +157,7 @@ IN: compiler.tree.propagation.transforms in-d>> first value-info literal>> { { V{ } [ [ drop { } 0 vector boa ] ] } { H{ } [ [ drop 0 ] ] } - { HS{ } [ [ drop f fast-set ] ] } + { HS{ } [ [ drop 0 ] ] } [ drop f ] } case ] "custom-inlining" set-word-prop diff --git a/basis/random/random.factor b/basis/random/random.factor index f425bb96e0..d2dae4335b 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -94,7 +94,12 @@ M: hashtable random M: sets:set random members random ; -M: hash-set random table>> random first ; +M: hash-set random + dup cardinality [ drop f ] [ + [ 0 ] [ array>> ] [ random ] tri* 1 + [ + [ 2dup array-nth tombstone? [ 1 + ] 2dip ] loop + ] times [ 1 - ] dip array-nth + ] if-zero ; : randomize-n-last ( seq n -- seq ) [ dup length dup ] dip - 1 max '[ dup _ > ] diff --git a/core/hash-sets/hash-sets.factor b/core/hash-sets/hash-sets.factor index fa88cf60bd..80cd5e1c9b 100644 --- a/core/hash-sets/hash-sets.factor +++ b/core/hash-sets/hash-sets.factor @@ -1,34 +1,149 @@ ! Copyright (C) 2010 Daniel Ehrenberg +! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs hashtables kernel sequences sets -sets.private ; +USING: accessors arrays hash-sets hashtables.private kernel +kernel.private math math.private sequences sequences.private +sets sets.private slots.private vectors ; IN: hash-sets -! In a better implementation, less memory would be used -TUPLE: hash-set { table hashtable read-only } ; +TUPLE: hash-set +{ count array-capacity } +{ deleted array-capacity } +{ array array } ; -: ( capacity -- hash-set ) - hash-set boa ; inline +fixnum ] dip wrap ; inline + +: probe ( array i probe# -- array i probe# ) + 1 fixnum+fast [ fixnum+fast over wrap ] keep ; inline + +: no-key ( key array -- array n ? ) nip f f ; inline + +: (key@) ( key array i probe# -- array n ? ) + [ 3dup swap array-nth ] dip over ((empty)) eq? + [ 4drop no-key ] [ + [ = ] dip swap + [ drop rot drop t ] + [ probe (key@) ] + if + ] if ; inline recursive + +: key@ ( key hash -- array n ? ) + array>> dup length>> 0 eq? + [ no-key ] [ 2dup hash@ 0 (key@) ] if ; inline + +: ( n -- array ) + 1 + next-power-of-2 2 * ((empty)) ; inline + +: reset-hash ( n hash -- ) + swap >>array init-hash ; inline + +: (new-key@) ( key array i probe# j -- array i j empty? ) + [ 2dup swap array-nth ] 2dip pick tombstone? + [ + rot ((empty)) eq? + [ nip [ drop ] 3dip t ] + [ pick or [ probe ] dip (new-key@) ] + if + ] [ + [ [ pick ] dip = ] 2dip rot + [ nip [ drop ] 3dip f ] + [ [ probe ] dip (new-key@) ] + if + ] if ; inline recursive + +: new-key@ ( key hash -- array n ) + [ array>> 2dup hash@ 0 f (new-key@) ] keep swap + [ over [ hash-deleted- ] [ hash-count+ ] if swap or ] [ 2drop ] if ; inline + +: set-nth-item ( key seq n -- ) + 2 fixnum+fast set-slot ; inline + +: (rehash) ( hash seq -- ) + swap [ dupd new-key@ set-nth-item ] curry each ; inline + +: hash-large? ( hash -- ? ) + [ count>> 3 fixnum*fast 1 fixnum+fast ] + [ array>> length>> 1 fixnum-shift-fast ] bi fixnum> ; inline + +: grow-hash ( hash -- ) + { hash-set } declare [ + [ members { array } declare ] + [ cardinality 1 + ] + [ reset-hash ] tri + ] keep swap (rehash) ; + +: ?grow-hash ( hash -- ) + dup hash-large? [ grow-hash ] [ drop ] if ; inline + +PRIVATE> + +: ( n -- hash ) + hash-set new [ reset-hash ] keep ; inline + +M: hash-set in? ( key hash -- ? ) + key@ 2nip ; + +M: hash-set clear-set ( hash -- ) + [ init-hash ] [ array>> [ drop ((empty)) ] map! drop ] bi ; + +M: hash-set delete ( key hash -- ) + [ nip ] [ key@ ] 2bi [ + [ ((tombstone)) ] 2dip set-nth-item + hash-deleted+ + ] [ + 3drop + ] if ; + +M: hash-set cardinality ( hash -- n ) + [ count>> ] [ deleted>> ] bi - ; inline + +M: hash-set adjoin ( key hash -- ) + dup ?grow-hash dupd new-key@ set-nth-item ; + +> set-array-nth ] + [ [ 1 fixnum+fast { array-capacity } declare ] dip length<< ] + 2bi ; inline + +PRIVATE> + +M: hash-set members + [ array>> [ length ] keep ] [ cardinality ] bi [ + [ + [ array-nth ] dip over tombstone? + [ 2drop ] [ push-unsafe ] if + ] 2curry each-integer + ] keep { } like ; + +M: hash-set clone + (clone) [ clone ] change-array ; inline + +M: hash-set equal? + over hash-set? [ set= ] [ 2drop f ] if ; : >hash-set ( members -- hash-set ) - unique hash-set boa ; inline + dup length [ [ adjoin ] curry each ] keep ; + +M: hash-set set-like + drop dup hash-set? [ ?members >hash-set ] unless ; inline 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 ; -M: hash-set null? table>> assoc-empty? ; -M: hash-set cardinality table>> assoc-size ; + M: hash-set intersect small/large sequence/tester filter >hash-set ; + M: hash-set union (union) >hash-set ; + M: hash-set diff sequence/tester [ not ] compose filter >hash-set ; -M: hash-set clear-set table>> clear-assoc ; + +M: f fast-set drop 0 ; M: sequence fast-set >hash-set ; -M: f fast-set drop H{ } clone hash-set boa ; M: sequence duplicates dup length [ ?adjoin not ] curry filter ;