diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Brandon Simmons + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brandon Simmons nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE CPP , OverloadedStrings #-} +module Main where +# ifdef ASSERTIONS_ON +# error "Sorry, please reconfigure without -finstrumented so that we turn off assertions in library code." +# endif + +import Criterion.Main +import Control.DeepSeq +import Control.Monad +import Control.Concurrent +import qualified Data.Text as T + +import Control.Concurrent.BloomFilter.Internal +import qualified Control.Concurrent.BloomFilter as Bloom +import Data.Hashabler + +import qualified Data.Set as Set +import qualified Data.HashSet as HashSet + +-- import System.IO.Unsafe(unsafePerformIO) +import System.Random + +-- TODO comparisons with: +-- - pure Set +-- - best in class Int (or other specialized) hash map or trie +-- - general hashmap (of Hashable things) +-- - the above, wrapped in an IORef or MVar + +main :: IO () +main = do + assertionsOn <- assertionCanary + when assertionsOn $ + putStrLn $ "!!! WARNING !!! assertions are enabled in library code and may result in " + ++"slower than realistic benchmarks. Try configuring without -finstrumented" + + procs <- getNumCapabilities + if procs < 2 + then putStrLn "!!! WARNING !!!: Some benchmarks are only valid if more than 1 core is available" + else return () + + b_5_20 <- Bloom.new (SipKey 1 1) 5 20 + b_13_20 <- Bloom.new (SipKey 1 1) 13 20 -- needs 128 + + -- This has 0.3% fpr for 10000 elements, so I think can be fairly compared + b_text <- Bloom.new (SipKey 11 22) 3 12 + let txt = "orange" :: T.Text + + let g = mkStdGen 8973459 + chars = randoms g :: [Char] + fakeWords = go chars + go :: [Char] -> [String] + go [] = error "noninfinite list" + go (s:ss) = let (a,as) = splitAt 3 ss + (b,bs) = splitAt 5 as + (c,cs) = splitAt 5 bs + (d,ds) = splitAt 6 cs + (e,es) = splitAt 8 ds + in [s]:a:b:c:d:e:(go es) + + let textWords10k = map T.pack $ take 10000 fakeWords + (wds5k_0, wds5k_1) = splitAt 5000 textWords10k + deepseq textWords10k $ return () + + let hashset10 = HashSet.fromList $ take 10 textWords10k + let hashset100 = HashSet.fromList $ take 100 textWords10k + let hashset10000 = HashSet.fromList $ take 10000 textWords10k + let set10 = Set.fromList $ take 10 textWords10k + let set100 = Set.fromList $ take 100 textWords10k + let set10000 = Set.fromList $ take 10000 textWords10k + + + + defaultMain [ + bgroup "internals" [ + bench "membershipWordAndBits64" $ nf (membershipWordAndBits64 (Hash64 1)) b_5_20 + , bench "membershipWordAndBits128" $ nf (membershipWordAndBits128 (Hash128 1 1)) b_13_20 + ], + + -- For comparing cache behavior with perf, against below: + bgroup "HashSet" $ + [ bench "10K insert" $ whnf (HashSet.fromList) textWords10k ], + bgroup "Set" $ + [ bench "10K insert" $ whnf (Set.fromList) textWords10k ], + + bgroup "different sizes" $ + let benches b = [ + bench "10K inserts" $ whnfIO $ manyInserts b textWords10k + , bench "10K lookups" $ whnfIO $ manyLookups b textWords10k + ] + in + [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bgroup "4096" (benches b) + , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bgroup "16384" (benches b) + , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bgroup "65536" (benches b) + , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bgroup "1MB" (benches b) + , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bgroup "8MB" (benches b) + , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bgroup "64MB" (benches b) + ] + , bgroup "different sizes (concurrency)" $ + {- + -- TODO factor out cost of 'new' in some better way: + [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bench "bigInsertLookup 15k ops" $ whnfIO (largeInsertQueryBench b wds5k_0 wds5k_1) + + , env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (4096)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (16384)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (65536)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (1MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (8MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (64MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1) + -} + let benches b = [ + bench "10K inserts, across 2 threads" $ whnfIO $ manyInsertsTwoThreads b wds5k_0 wds5k_1 + , bench "10K lookups, across 2 threads" $ whnfIO $ manyLookupsTwoThreads b wds5k_0 wds5k_1 + ] + in + [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bgroup "4096" (benches b) + , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bgroup "16384" (benches b) + , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bgroup "65536" (benches b) + , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bgroup "1MB" (benches b) + , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bgroup "8MB" (benches b) + , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bgroup "64MB" (benches b) + ] + , bgroup "lookup insert" [ + bench "siphash64_1_3 for comparison" $ whnf (siphash64_1_3 (SipKey 1 1)) (1::Int) + + -- best case, with no cache effects (I think): + , bench "lookup (64)" $ whnfIO (Bloom.lookup b_5_20 (1::Int)) + , bench "lookup x10 (64)" $ nfIO (mapM_ (Bloom.lookup b_5_20) [1..10]) + , bench "lookup x100 (64)" $ nfIO (mapM_ (Bloom.lookup b_5_20) [1..100]) + , bench "lookup (128)" $ whnfIO (Bloom.lookup b_13_20 (1::Int)) + , bench "lookup x10 (128)" $ nfIO (mapM_ (Bloom.lookup b_13_20) [1..10]) + , bench "lookup x100 (128)" $ nfIO (mapM_ (Bloom.lookup b_13_20) [1..100]) + + , bench "insert (64)" $ whnfIO (Bloom.insert b_5_20 (1::Int)) + , bench "insert x10 (64)" $ nfIO (mapM_ (Bloom.insert b_5_20) [1..10]) + , bench "insert x100 (64)" $ nfIO (mapM_ (Bloom.insert b_5_20) [1..100]) + , bench "insert (128)" $ whnfIO (Bloom.insert b_13_20 (1::Int)) + , bench "insert x10 (128)" $ nfIO (mapM_ (Bloom.insert b_13_20) [1..10]) + , bench "insert x100 (128)" $ nfIO (mapM_ (Bloom.insert b_13_20) [1..100]) + + ], + bgroup "comparisons micro" [ + bench "(just siphash64_1_3 on txt for below)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("orange"::T.Text) + , bench "Bloom.insert (64)" $ whnfIO (Bloom.insert b_text txt) + {- I was concerned that the above might not be valid (perhaps the + - hashing of the Text value was getting reused?), but the following + - convinced me it's all right; we can see differences in size of input + - string reflected in all these benchmarks. I believe bloomInsertPure1 + - reflects the inability to inline Hashable instance machinery (since + - it must remain polymorphic. + , bench "Bloom.insert (64)(validation1)" $ whnf (bloomInsertPure1 b_text) txt + , bench "Bloom.insert (64)(validation2)" $ whnf (bloomInsertPure2 b_text) txt + , bench "Bloom.insert (64)(validation3)" $ whnfIO (Bloom.insert b_text "ora") + , bench "Bloom.insert (64)(validation4)" $ whnf (bloomInsertPure1 b_text) "ora" + , bench "Bloom.insert (64)(validation5)" $ whnf (bloomInsertPure2 b_text) "ora" + , bench "(validation orange)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("orange"::T.Text) + , bench "(validation ora)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("ora"::T.Text) + -} + + , bench "Set.insert into 10" $ whnf (\t-> Set.insert t set10) txt + , bench "Set.insert into 100" $ whnf (\t-> Set.insert t set100) txt + , bench "Set.insert into 10000" $ whnf (\t-> Set.insert t set10000) txt + + , bench "HashSet.insert into 10" $ whnf (\t-> HashSet.insert t hashset10) txt + , bench "HashSet.insert into 100" $ whnf (\t-> HashSet.insert t hashset100) txt + , bench "HashSet.insert into 10000" $ whnf (\t-> HashSet.insert t hashset10000) txt + + , bench "Bloom.lookup (64)" $ whnfIO (Bloom.lookup b_text txt) + + , bench "Set.member of 10" $ whnf (\t-> Set.member t set10) txt + , bench "Set.member of 100" $ whnf (\t-> Set.member t set100) txt + , bench "Set.member of 10000" $ whnf (\t-> Set.member t set10000) txt + + , bench "HashSet.member of 10" $ whnf (\t-> HashSet.member t hashset10) txt + , bench "HashSet.member of 100" $ whnf (\t-> HashSet.member t hashset100) txt + , bench "HashSet.member of 10000" $ whnf (\t-> HashSet.member t hashset10000) txt + ], + bgroup "comparisons big" [ + ], + -- TODO large random lookup and insert benchmark, comparing with single-thread and then with work split. + -- make this how we compare as well? + -- Do this for various types of elements + + bgroup "combining and creation" [ + -- These timings can be subtracted from union timings: + bench "new 14" $ whnfIO $ Bloom.new (SipKey 1 1) 3 14 + , bench "new 20" $ whnfIO $ Bloom.new (SipKey 1 1) 3 20 + + , bench "unionInto (14 -> 14)" $ whnfIO $ unionBench 14 14 + , bench "unionInto (20 -> 14)" $ whnfIO $ unionBench 20 14 -- 20 is 6x + , bench "unionInto (20 -> 20)" $ whnfIO $ unionBench 20 20 + ] + ] + +unionBench :: Int -> Int -> IO () +unionBench bigl littlel = do + b1 <- Bloom.new (SipKey 1 1) 3 bigl + b2 <- Bloom.new (SipKey 1 1) 3 littlel + b1 `Bloom.unionInto` b2 + + +instance NFData (BloomFilter a) where + rnf _ = () + +{- +-- TODO fix both of these and compare with Set/HashSet (wrapped in IORef or MVar for second) +largeInsertQueryBench :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO () +largeInsertQueryBench b payload antipayload = do + forM_ payload $ Bloom.insert b + forM_ (zip payload antipayload) $ \(x,y)-> do + --- can't test, since we're re-using bloom: + _xOk <- Bloom.lookup b x + _yOk <- Bloom.lookup b y -- usually False + -- unless (xOk) $ error "largeInsertQueryBench" + return () + +largeInsertQueryBenchTwoThreads :: Bloom.BloomFilter T.Text -> Int -> [T.Text] -> [T.Text] -> IO () +largeInsertQueryBenchTwoThreads b length_payload payload antipayload = do + t0 <- newEmptyMVar + t1 <- newEmptyMVar + let (payload0,payload1) = splitAt (length_payload `div` 2) payload + let (antipayload0,antipayload1) = splitAt (length_payload `div` 2) antipayload + + let go pld antpld v = do + forM_ pld $ Bloom.insert b + forM_ (zip pld antpld) $ \(x,y)-> do + _xOk <- Bloom.lookup b x + _yOk <- Bloom.lookup b y -- usually False + -- unless (xOk) $ error "largeInsertQueryBench" + return () + putMVar v () + void $ forkIO $ go payload0 antipayload0 t0 + void $ forkIO $ go payload1 antipayload1 t1 + takeMVar t0 >> takeMVar t1 + -} + + +-- These are mostly to check cache behavior, and I don't expect it to matter +-- whether a bloom filter was already "filled with elements" or not. +manyInserts :: Bloom.BloomFilter T.Text -> [T.Text] -> IO () +manyInserts b payload = do + forM_ payload (void . Bloom.insert b) + +manyLookups :: Bloom.BloomFilter T.Text -> [T.Text] -> IO () +manyLookups b payload = do + forM_ payload (void . Bloom.lookup b) + +manyInsertsTwoThreads :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO () +manyInsertsTwoThreads b payload0 payload1 = do + t0 <- newEmptyMVar + t1 <- newEmptyMVar + let go pld v = manyInserts b pld >> putMVar v () + void $ forkIO $ go payload0 t0 + void $ forkIO $ go payload1 t1 + takeMVar t0 >> takeMVar t1 + +manyLookupsTwoThreads :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO () +manyLookupsTwoThreads b payload0 payload1 = do + t0 <- newEmptyMVar + t1 <- newEmptyMVar + let go pld v = manyLookups b pld >> putMVar v () + void $ forkIO $ go payload0 t0 + void $ forkIO $ go payload1 t1 + takeMVar t0 >> takeMVar t1 + + +{- +-- So we can use whnf, and make sure hashes aren't being cached +{-# NOINLINE bloomInsertPure1 #-} +bloomInsertPure1 :: Hashable a => BloomFilter a -> a -> Bool +bloomInsertPure1 b = unsafePerformIO . Bloom.insert b + +bloomInsertPure2 :: Hashable a => BloomFilter a -> a -> Bool +bloomInsertPure2 b = unsafePerformIO . Bloom.insert b +-} diff --git a/core-example/Main.hs b/core-example/Main.hs new file mode 100644 --- /dev/null +++ b/core-example/Main.hs @@ -0,0 +1,8 @@ +module Main(main) where + +import qualified Control.Concurrent.BloomFilter as Bloom + +main = do + b_5_20 <- Bloom.new (Bloom.SipKey 1 1) 5 20 + p <- Bloom.lookup b_5_20 (1::Int) + print p diff --git a/src/Control/Concurrent/BloomFilter.hs b/src/Control/Concurrent/BloomFilter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/BloomFilter.hs @@ -0,0 +1,26 @@ +module Control.Concurrent.BloomFilter ( +{- | A thread-safe mutable bloom filter. Some additional functionality for + advanced users is exposed in "Control.Concurrent.BloomFilter.Internal". + -} + BloomFilter() + , BloomFilterException(..) + -- * Creation + , new + , SipKey(..) + -- * Operations + , insert + , lookup + -- ** Copying and Combining + , unionInto + , intersectionInto + , clone + -- * Serialization + , serialize + , deserialize + -- * Utilities + , fpr + + ) where + +import Control.Concurrent.BloomFilter.Internal +import Prelude hiding (lookup) diff --git a/src/Control/Concurrent/BloomFilter/Internal.hs b/src/Control/Concurrent/BloomFilter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/BloomFilter/Internal.hs @@ -0,0 +1,720 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, CPP, ScopedTypeVariables, DeriveDataTypeable #-} +module Control.Concurrent.BloomFilter.Internal ( +{- | Some additional unsafe, low-level, and internal functions are exposed here + for advanced users. The API should remain stable, except that functions may + be added and no promises are made about the internals of the 'BloomFilter' + type itself. + -} + new + , BloomFilter(..) + , BloomFilterException(..) + , insert + , lookup + , unionInto + , intersectionInto + , clone + , SipKey(..) + , fpr + + , serialize + , unsafeSerialize + , deserialize + , deserializeByteArray + +# ifdef EXPORT_INTERNALS + -- * Internal functions exposed for testing; you shouldn't see these + , membershipWordAndBits64, membershipWordAndBits128 + , maskLog2wRightmostBits + , log2w + , wordSizeInBits + , uncheckedSetBit + , isHash64Enough + , log2lFromArraySize + , assertionCanary + , bytes64, unbytes64 +# endif + ) + where + + +import Data.Bits hiding (unsafeShiftL, unsafeShiftR) +import qualified Data.Bits as BitsHidden +import qualified Data.Primitive.ByteArray as P +import Data.ByteString.Internal +import GHC.ForeignPtr +import Foreign.ForeignPtr +import Foreign.Storable(peekElemOff) +import Data.Primitive.MachDeps +import Data.Primitive.Types(Addr(..)) +import Control.Monad.Primitive(RealWorld) +import Data.Atomics +import Data.Hashabler +import Control.Exception +import Data.Typeable(Typeable) +import Control.Monad +import Data.Word(Word64, Word8) +import Prelude hiding (lookup) + +-- Future operations: +-- - memory-mapped bloomfilter for durability (which of ACID do we get?). See 'vector-mmap' package? +-- - allow opening mmap-ed file directly from serialized form? +-- - approximating number of items, and size of union and intersection +-- - freezing/pure/ST interface (e.g. Data.BloomFilter) +-- - API: +-- - only allow writes in ST (copying for each write is awful) +-- - provide a fromList that uses ST, for convenience +-- - querying and combining can be regural pure interface (Semigroup) +-- +-- - bulk reads and writes, for performance: (especially good for pure interface fromList, etc. +-- fromList implementation possibilities: +-- 1 - allocate new +-- - unsafeInsert all into new (possibly prefetching next block) +-- - non-threadsafe union with previous +-- 2 - hash and sort (as list or something) +-- - memcpy previous +-- - unsafeInsert in order into new +-- 3 - memcpy previous +-- - unsafeInsert new, manually prefetching next. +-- - re-order hashes for in-order cache line access (benchmark this) +-- - consider prefetching +-- - combine inter-word reads and writes. +-- - consider a Scalable Bloom Filter -type approach (or variant): +-- - CAS of linked list of filters +-- - possible linearizability issues. +-- - other operations become tricker or not doable. +-- +-- +-- Future typed interface: +-- - parameterize by length, or at least have separate Bloom64 (faster, uses only 64-bit hashes) and Bloom128 functions. +-- - new takes a type-level nat regardless of whether we carry that around in a parameter +-- - parameterize by k (no big deal being static) +-- - for sipkey: +-- - use NullaryTypeClasses or some more clever solution +-- "The configurations problem is to propagate run-time preferences +-- throughout a program, allowing multiple concurrent configuration sets +-- to coexist safely under statically guaranteed separation..." +-- TODO is this relevant for the other type-level params we imagine? +-- TODO can the two be complimentary?: use a singleton class, but instantiate it dynamically with reflection? per:https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection#dynamically-constructing-type-class-instances +-- - Or use a type lit that corresponds to an environment variable, and tag +-- - the user could shoot himself in the foot by changing the environment and break this scheme +-- but that's probably okay. +-- - what if user wants to pass it as a command line arg or something? Is this equally compatible with windows? +-- +-- - `new` variant that ensures fast 64-bit version. +-- - deserializing, will have type ... -> Either String (BloomFilter x y z a) +-- - we can always check equality of value level nats by doing natVal when deserializing + + + +-- TODO: expose functions that would allow users to shard inserts and lookups +-- and use non-atomic write. e.g. maybe an unsafeInsert (non-threadsafe +-- write) as well as functions that take a user-supplied hash directly. + + + +-- | A mutable bloom filter representing a set of 'Hashable' values of type @a@. +-- +-- A bloom filter is a set-like probabilistic hash-based data structure. +-- Elements can be 'insert'-ed and 'lookup'-ed again. The bloom filter +-- takes a constant amount of memory regardless of the size and number of +-- elements inserted, however as the bloom filter \"grows\" the likelihood of +-- false-positives being returned by 'lookup' increases. 'fpr' can be used to +-- estimate the expected false-positive rate. +data BloomFilter a = BloomFilter { key :: !SipKey + , k :: !Int + , hash64Enough :: Bool + -- ^ if we need no more than 64-bits we can use the faster 'siphash64_1_3' + , l_minus1 :: !Word64 + , log2l :: !Int + , arr :: !(P.MutableByteArray RealWorld) + } + + +-- | Exceptions that may be thrown by operations in this library. +newtype BloomFilterException = BloomFilterException String + deriving (Show, Typeable) + +instance Exception BloomFilterException + +throwBloom :: String -> IO a +throwBloom = throwIO . BloomFilterException + +-- | Create a new bloom filter of elements of type @a@ with the given hash key +-- and parameters. 'fpr' can be useful for calculating the @k@ parameter, or +-- determining a good filter size. +-- +-- The parameters must satisfy the following conditions, otherwise a +-- 'BloomFilterException' will be thrown: +-- +-- - @k > 0@ +-- - @log2l >= 0 && log2l <= wordSizeInBits@ +-- - @log2l + k*(logBase 2 wordSizeInBits) <= 128@ +-- +-- In addition, performance on 64-bit machines will be best when +-- @log2l + k*(logBase 2 wordSizeInBits) <= 64@ where we require only 64 hash +-- bits for each element. (Performance on 32-bit machines will be worse in all +-- cases, as we're doing 64-bit arithmetic.) +-- +-- Example: on a 32-bit machine, the following produces a ~4KB bloom filter of +-- @2^10@ 32-bit words, using 3 bits per element: +-- +-- @ +-- do key <- read <$> getEnv "THE_SECRET_KEY" +-- Bloom.new key 3 10 +-- @ +new :: SipKey + -- ^ The secret key to be used for hashing values for this bloom filter. + -> Int + -- ^ @k@: Number of independent bits of @w@ to which we map an element. 3 is a good choice. + -> Int + -- ^ @log2l@: The size of the filter, in machine words, as a power of 2. e.g. @3@ means @2^3@ or @8@ machine words. + -> IO (BloomFilter a) +new key k log2l = do + -- In typed interface all of these conditions hold: + let !hash64Enough = isHash64Enough log2l k + checkParamInvariants k log2l + + (arr, sizeDataBytes) <- newBloomArr log2l + P.fillByteArray arr 0 sizeDataBytes (0x00) + + return $ BloomFilter { l_minus1 = (2^log2l)-1, .. } + +-- factored out for deserialization: +checkParamInvariants :: Int -> Int -> IO () +checkParamInvariants k log2l = do + unless (k > 0) $ + throwBloom "in 'new', k must be > 0" + unless (log2l >= 0) $ + throwBloom "in 'new', log2l must be >= 0" + +-- We leave a buffer at the end of the data portion of the filter large enough +-- to store metadata for serialization, so we don't have to do any copying for +-- ser/deser. But we don't concern ourselves with populating or maintaining +-- metadata except during our serialization and deserialization routines; that +-- memory may be dirty. +newBloomArr :: Int -> IO (P.MutableByteArray RealWorld, Int) +newBloomArr log2l = do + let !sizeDataBytes = sIZEOF_INT `uncheckedShiftL` log2l + -- aligned: we assume atomic reads (no word tearing): + -- pinned: for performance, and so we can "serialize" to bytestring without + -- copying, and do other future FFI stuff + arr <- P.newAlignedPinnedByteArray (sizeDataBytes+sIZEOF_METADATA) aLIGNMENT_INT + return (arr,sizeDataBytes) + +log2lFromArraySize :: Int{-bytes-} -> IO Int +log2lFromArraySize sz = + either throwBloom return $ do + let dataSzBytes = sz - sIZEOF_METADATA + log2lFloat = logBase 2 ((fromIntegral dataSzBytes / fromIntegral sIZEOF_INT) :: Float) + log2l = floor log2lFloat + unless (dataSzBytes >= sIZEOF_INT) $ Left "Array is not large enough to be a serialized bloom filter" + unless (fromIntegral log2l == log2lFloat) $ Left "Array is an unexpected size for a serialized bloom filter" + return log2l + + + +membershipWordAndBits64 :: Hash64 a -> BloomFilter a -> (Int, Int) +{-# INLINE membershipWordAndBits64 #-} +membershipWordAndBits64 !(Hash64 h) = \ !(BloomFilter{ .. }) -> + assert (isHash64Enough log2l k) $ + -- From right: take all member bits, then take membership word. NOTE: for + -- union on different size filters to work we must not e.g. take the + -- leftmost log2l bits; we need lower-order bits to be the same between the + -- two filters. + let !memberWord = fromIntegral $ + l_minus1 .&. (h `uncheckedShiftR` fromIntegral (k*log2w)) + !wordToOr = fst $ setKMemberBits 0x00 k h + + in (memberWord, wordToOr) + +membershipWordAndBits128 :: Hash128 a -> BloomFilter a -> (Int, Int) +{-# INLINE membershipWordAndBits128 #-} +membershipWordAndBits128 (Hash128 h_0 h_1) = \(BloomFilter{ .. }) -> + assert (not $ isHash64Enough log2l k) $ + -- Isolate member word by taking from lowest bits of h_0, take member bits + -- starting from right of h_1, possibly using leftmost from h_0 which we + -- splice onto the end as we shift and consume h_1: + let !memberWord = fromIntegral $ l_minus1 .&. h_0 + !bitsReqd_h_0 = k*log2w - 64 + + !wordToOr = + if bitsReqd_h_0 <= 0 + then fst $ setKMemberBits 0x00 k h_1 + else -- we'll shift right just enough so we can OR with the last bit of h_1 shifted right: + let !bitsReqd_h_0_withOffs = bitsReqd_h_0 + (64 `rem` log2w) + !h_0_alignedMasked = + -- clear right: + (h_0 `uncheckedShiftR` (64 - bitsReqd_h_0)) -- n.b. conditional guards shift + -- align at offset: + `uncheckedShiftL` (64 - bitsReqd_h_0_withOffs) + !initialKToTake = bitsReqd_h_0_withOffs `quot` log2w + (!wordToOrPart0, !h_1_shifted) = setKMemberBits 0x00 initialKToTake h_1 + + in assert (initialKToTake > 0) $ + fst $ setKMemberBits wordToOrPart0 (k-initialKToTake) (h_1_shifted.|.h_0_alignedMasked) + + in (memberWord, wordToOr) + + + +setKMemberBits :: Int -> Int -> Word64 -> (Int, Word64) +{-# INLINE setKMemberBits #-} +setKMemberBits !wd 0 h' = (wd, h') +setKMemberBits !wd !k' !h' = + -- possible cast to 32-bit Int but we only need rightmost 5 or 6 bits: + let !memberBit = fromIntegral h' .&. maskLog2wRightmostBits + in setKMemberBits (wd `uncheckedSetBit` memberBit) (k'-1) (h' `uncheckedShiftR` log2w) + + + +membershipWordAndBitsFor :: (Hashable a)=> BloomFilter a -> a -> (Int, Int) +{-# INLINE membershipWordAndBitsFor #-} +membershipWordAndBitsFor bloom@(BloomFilter{..}) a + | hash64Enough = membershipWordAndBits64 (siphash64_1_3 key a) bloom + | otherwise = membershipWordAndBits128 (siphash128 key a) bloom + + +-- True if we can get enough hash bits from a Word64, and a runtime check +-- sanity check of our arguments to 'new'. This is probably in "enough for +-- anyone" territory currently: +isHash64Enough :: Int -> Int -> Bool +{-# INLINE isHash64Enough #-} +isHash64Enough log2l k = + let bitsReqd = log2l + k*log2w + in if bitsReqd > 128 + then throw $ BloomFilterException "The passed parameters require over the maximum of 128 hash bits supported. Make sure: (log2l + k*(logBase 2 wordSizeInBits)) <= 128" + else if (log2l > wordSizeInBits) + then throw $ BloomFilterException "You asked for (log2l > 64). We have no way to address memory in that range, and anyway that's way too big." + else bitsReqd <= 64 + +maskLog2wRightmostBits :: Int -- 2^log2w - 1 +maskLog2wRightmostBits | sIZEOF_INT == 8 = 63 + | otherwise = 31 + +wordSizeInBits :: Int +wordSizeInBits = sIZEOF_INT * 8 + +log2w :: Int -- logBase 2 wordSizeInBits +log2w | sIZEOF_INT == 8 = 6 + | otherwise = 5 + +uncheckedSetBit :: Int -> Int -> Int +{-# INLINE uncheckedSetBit #-} +uncheckedSetBit x i = x .|. (1 `uncheckedShiftL` i) + +uncheckedShiftR :: (Num a, FiniteBits a, Ord a) => a -> Int -> a +{-# INLINE uncheckedShiftR #-} +uncheckedShiftR a = \x-> + assert (a >= 0) $ -- make sure we don't smear sign w/ a bad fromIntegral cast + assert (x < finiteBitSize a) $ + assert (x >= 0) $ + a `BitsHidden.unsafeShiftR` x +uncheckedShiftL :: (Num a, FiniteBits a, Ord a) => a -> Int -> a +{-# INLINE uncheckedShiftL #-} +uncheckedShiftL a = \x-> + assert (a >= 0) $ + assert (x < finiteBitSize a) $ + assert (x >= 0) $ + a `BitsHidden.unsafeShiftL` x + + +-- | /O(size_of_element)/. Atomically insert a new element into the bloom +-- filter. +-- +-- This returns 'True' if the element /did not exist/ before the insert, and +-- 'False' if the element did already exist (subject to false-positives; see +-- 'lookup'). Note that this is reversed from @lookup@. +insert :: Hashable a=> BloomFilter a -> a -> IO Bool +{-# INLINE insert #-} +insert bloom@(BloomFilter{..}) = \a-> do + let (!memberWord, !wordToOr) = membershipWordAndBitsFor bloom a + oldWord <- fetchOrIntArray arr memberWord wordToOr + return $! (oldWord .|. wordToOr) /= oldWord + +-- | /O(size_of_element)/. Look up the value in the bloom filter, returning +-- 'True' if the element is possibly in the set, and 'False' if the element is +-- /certainly not/ in the set. +-- +-- The likelihood that this returns 'True' on an element that was not +-- previously 'insert'-ed depends on the parameters the filter was created +-- with, and the number of elements already inserted. The 'fpr' function can +-- help you estimate this. +lookup :: Hashable a=> BloomFilter a -> a -> IO Bool +{-# INLINE lookup #-} +lookup bloom@(BloomFilter{..}) = \a-> do + let (!memberWord, !wordToOr) = membershipWordAndBitsFor bloom a + existingWord <- P.readByteArray arr memberWord + return $! (existingWord .|. wordToOr) == existingWord + + + + +-- | /O(l_src+l_target)/. Write all elements in the first bloom filter into the +-- second. This operation is lossless; ignoring writes to the source bloom +-- filter that happen during this operation (see below), the target bloom +-- filter will be identical to the filter produced had the elements been +-- inserted into the target originally. +-- +-- The source and target must have been created with the same key and +-- @k@-value. In addition the target must not be larger (i.e. the @l@-value) +-- than the source, /and/ they must both use 128/64 bit hashes. This throws a +-- 'BloomFilterException' when those constraints are not met. +-- +-- This operation is not linearizable with respect to 'insert'-type operations; +-- elements being written to the source bloomfilter during this operation may +-- or may not make it into the target "at random". +unionInto :: BloomFilter a -- ^ Source, left unmodified. + -> BloomFilter a -- ^ Target, receiving elements from source. + -> IO () +unionInto = combine fetchOrIntArray + + + +-- | /O(l_src+l_target)/. Make @target@ the intersection of the source and +-- target sets. This operation is "lossy" in that the false positive ratio of +-- target after the operation may be higher than if the elements forming the +-- intersection had been 'insert'-ed directly into target. +-- +-- The constraints and comments re. linearizability in 'unionInto' also apply +-- here. +intersectionInto :: BloomFilter a -- ^ Source, left unmodified. + -> BloomFilter a -- ^ Target, receiving elements from source. + -> IO () +intersectionInto = combine fetchAndIntArray + + +-- internal +combine :: (P.MutableByteArray RealWorld -> Int -> Int -> IO x) + -> BloomFilter a -> BloomFilter a -> IO () +{-# INLINE combine #-} +combine f = \src target -> do + unless (key src == key target) $ throwBloom $ + "SipKey of the source BloomFilter does not match target" + unless (k src == k target) $ throwBloom $ + "k of the source BloomFilter does not match target" + unless (log2l src >= log2l target) $ throwBloom $ + "log2l of the source BloomFilter is smaller than the target" + unless (hash64Enough src == hash64Enough target) $ throwBloom $ + "either the source or target BloomFilter requires 128 hash bits while the other requires 64" + + let target_l_minus1 = fromIntegral $ l_minus1 target + src_l_minus1 = fromIntegral $ l_minus1 src + + -- unless source and target are the same size we must "shrink" source to + -- size of target onto an intermediate array first (necessary to support + -- the AND for intersection, and also faster because it uses fewer atomic + -- primops onto target): + srcArrShrunk <- + if target_l_minus1 == src_l_minus1 + then return (arr src) + else assert (target_l_minus1 < src_l_minus1) $ do + (srcArrShrunk, sizeDataBytes) <- newBloomArr $ log2l target + -- initialize new array with an efficient copy of first chunk from + -- source: + P.copyMutableByteArray srcArrShrunk 0 (arr src) 0 sizeDataBytes + + forM_ [(target_l_minus1+1).. src_l_minus1] $ \srcWordIx -> do + let !targetWordIx = srcWordIx .&. target_l_minus1 + srcWord <- P.readByteArray (arr src) srcWordIx + assert (targetWordIx <= target_l_minus1) $ + nonatomicFetchOrIntArray srcArrShrunk targetWordIx srcWord + + assert (P.sizeofMutableByteArray srcArrShrunk == + P.sizeofMutableByteArray (arr target)) $ + return srcArrShrunk + + forM_ [0.. target_l_minus1] $ \ix -> do + srcWord <- P.readByteArray srcArrShrunk ix + f (arr target) ix srcWord + +-- | Create a copy of the input @BloomFilter@. +-- +-- This operation is not linearizable with respect to 'insert'-type operations; +-- elements being written to the source bloomfilter during this operation may +-- or may not make it into the target "at random". +clone :: BloomFilter a -> IO (BloomFilter a) +clone BloomFilter{..} = do + (arrCopy, sizeDataBytes) <- newBloomArr log2l + P.copyMutableByteArray arrCopy 0 arr 0 sizeDataBytes + return $ + BloomFilter { arr = arrCopy, .. } + + +nonatomicFetchOrIntArray :: P.MutableByteArray RealWorld -> Int -> Int -> IO Int +nonatomicFetchOrIntArray ar ix wd = do + !before <- P.readByteArray ar ix + P.writeByteArray ar ix (before .|. wd) + return before + + +{- +-- This is the corrected equation from 'Supplementary File: A Comment on “Fast +-- Bloom Filters and Their Generalization”'. Unfortunately since we're going to need to approximate factorial even to calculate this. +-- compute this without moving into log space and probably approximating the +-- factorials which might defeat the purpose of using this more accurate +-- function to begin with. +fpr :: Int -- ^ @n@: Number of elements in filter + -> Int -- ^ @l@: Size of filter, in machine words + -> Int -- ^ @k@: Number of bits to map an element to + -> Float +fpr nI lI kI = + let w = 64 -- TODO word-size in bits + n = fromIntegral nI + l = fromIntegral lI + k = fromIntegral kI + in summation 0 n $ \x-> + (combination n x) * + ((1/l) ** x) * + ((1 - (1/l)) ** (n-x)) * + (factorial w / (w ** k*(x+1)) ) * + (summation 1 w $ \i-> + (summation 1 i $ \j-> + ((j ** k*x) * i**k) / + (factorial (w-i) * factorial j * factorial (i-j)) + ) + ) +-} + +-- This is my attempt at translating the FPR equation from "Fast Bloom Filters +-- and their Generalizations" with the following modifications: +-- - calculations within summation performed in log space +-- - use Stirling's approximation of factorial for larger `n` +-- - scale `n` and `l` together for large `n`; the paper graphs FPR against +-- this ratio so I guess this is justified, and it seems to work. + +-- | An estimate of the false-positive rate for a bloom-1 filter. For a filter +-- with the provided parameters and having @n@ elements, the value returned +-- here is the percentage, over the course of many queries for elements /not/ in +-- the filter, of those queries which would be expected to return an incorrect +-- @True@ result. +-- +-- This function is slow but the complexity is bounded and can accept inputs of +-- any size. +fpr :: Int -- ^ @n@: Number of elements in filter + -> Int -- ^ @l@: Size of filter, in machine words + -> Int -- ^ @k@: Number of bits to map an element to + -> Int -- ^ @w@: word-size in bits (e.g. 32 or 64) + -> Double +fpr nI lI kI wI = + summation 0 n $ \x-> + e ** ( + (logCombination n x) + + (x * (negate $ log l)) + + ((n-x) * (log(l-1) - log l)) + + (k* log(1 - ((1 - (1/w)) ** (x*k)))) + ) + + where + n = min 32000 (fromIntegral nI) + l = fromIntegral lI * (n/fromIntegral nI) + + k = fromIntegral kI + w = fromIntegral wI + e = exp 1 + -- / x \ + -- log \ y / + logCombination x y + | y <= x = logFactorial x - (logFactorial y + logFactorial (x - y)) + | otherwise = log 0 -- TODO okay? + + logFactorial x + -- TODO memoize in array: + | x <= 500 = sum $ map log [1..x] + -- else use Stirling's approximation when error doesn't seem to affect + | otherwise = x * log x - x + log (sqrt (2*pi*x)) + + summation low hi = sum . \f-> map f [low..hi] + + + +-- ------------------------------------------------------------------ +-- Serialization +-- ------------------------------------------------------------------ + + +-- For now we just prepare to throw an error if the +sIZEOF_METADATA, mETADATA_WORDS :: Int +sIZEOF_METADATA = 8*mETADATA_WORDS +mETADATA_WORDS = 8 + +sERIALIZATION_VERSION :: Word64 +sERIALIZATION_VERSION = 0 + + +-- Return metadata for serialization from the ADT +metadataBytes :: StableHashable a=> BloomFilter a -> [Word8] +metadataBytes bl@BloomFilter{..} = + let keyHash = hashSipKey key + bs = + [ sERIALIZATION_VERSION -- serialization format version + , tpHashOf bl -- for verifying we deserialize to the correct element type + , hashWord64 keyHash -- for verifying key (we don't wish to store it) + , tpHashOf keyHash -- ensures sanity of the hashing of our key + , fromIntegral wordSizeInBits + , fromIntegral k + , fromIntegral log2l + , 0x0000 -- some padding for the hell of it; we can make the above more compact later too, if we want forward compatibility. + ] >>= bytes64 + in assert (length bs == sIZEOF_METADATA) $ + bs + +-- A client may be concerned about keeping her SipKey secret; we have two decent options: +-- 1. store the key in the serialized bloom filter, and force the user to use encryption +-- 2. make the user handle managing keys, and store a hash of the key to +-- ensure sanity when the user provides the key again for deserialization +-- We've chosen (2), mostly because if we omit the key the filter is completely +-- opaque and secure, and we wish to experiment with mmap which a user of +-- encryption couldn't use if they wanted to make sure their key never landed +-- on disk. +-- +-- We hash the key with itself and presume (read "hope") that this doesn't leak +-- any information about the key: +hashSipKey :: SipKey -> Hash64 (Word64, Word64) +hashSipKey k@(SipKey w0 w1) = siphash64 k (w0, w1) + +populateMetadata :: StableHashable a=> BloomFilter a -> IO () +populateMetadata b@BloomFilter{..} = do + let !sizeDataBytes = sIZEOF_INT `uncheckedShiftL` log2l + assert (P.sizeofMutableByteArray arr == sizeDataBytes + sIZEOF_METADATA) $ return () + forM_ (zip [sizeDataBytes..] $ metadataBytes b) $ + uncurry (P.writeByteArray arr) + +-- | Serialize a bloom filter to a strict @ByteString@, which can be +-- 'deserialize'-ed once again. Only a hash of the 'SipKey' is stored in the +-- serialized format. +-- +-- This operation is not linearizable with respect to 'insert'-type operations; +-- elements being written to the source bloomfilter during this operation may +-- or may not make it into the serialized @ByteString@ "at random". +serialize :: StableHashable a=> BloomFilter a -> IO ByteString +serialize bl = clone bl >>= unsafeSerialize + +-- | Serialize a bloom filter to a strict @ByteString@, which can be +-- 'deserialize'-ed once again. Only a hash of the 'SipKey' is stored in the +-- serialized format. This operation is very fast and does no copying. +-- +-- This is unsafe in that the source @BloomFilter@ must not be modified after +-- this operation, otherwise the ByteString will change, breaking referential +-- transparency. Use 'serialize' if uncertain. +unsafeSerialize :: StableHashable a=> BloomFilter a -> IO ByteString +unsafeSerialize b@BloomFilter{..} = do + populateMetadata b + let addr = (\(Addr x)-> x) $ P.mutableByteArrayContents arr + arr' = (\(P.MutableByteArray x) -> x) arr + return $ + PS (ForeignPtr addr (PlainPtr arr')) 0 (P.sizeofMutableByteArray arr) + +-- | Deserialize a 'BloomFilter' from a @ByteString@ created with 'serialize' +-- or 'unsafeSerialize'. The key that was used to create the bloom filter is +-- not stored for security, and must be provided here. However if the key +-- provided does not match the key it was originally created with, a +-- 'BloomFilterException' will be thrown. +deserialize :: StableHashable a=> SipKey -> ByteString -> IO (BloomFilter a) +deserialize key (PS fp@(ForeignPtr _ arrWrapped) off len) = do + log2l <- log2lFromArraySize len + -- It would be possible to create an 'unsafeDeserialize' which could + -- deserialize without this extra copy, where 'off' and 'len' are unused + -- (i.e. we can use the MutableByteArray directly), however we still have + -- the issue of finalizers; I think we would need to keep the ForeignPtr + -- around and make sure to touch it. However we can still offer our own IO + -- functions (e.g. an mmap routine) that does no extra copying. + (arr, _) <- newBloomArr log2l + + -- Copy ByteString data to a fresh MutableByteArray: + case arrWrapped of + PlainPtr arrDirty -> P.copyMutableByteArray arr 0 (P.MutableByteArray arrDirty) off len + MallocPtr arrDirty _ -> P.copyMutableByteArray arr 0 (P.MutableByteArray arrDirty) off len + -- If we don't have access to the MutableByteArray we do a slow + -- byte-at-a-time copy: + _ -> withForeignPtr fp $ \ptr-> + forM_ (zip (take len [off..]) [0..]) $ \(ptrBytOff,targetBytIx)-> + peekElemOff ptr ptrBytOff >>= P.writeByteArray arr targetBytIx + + touchForeignPtr fp + deserializeByteArray key arr + + +-- | A low-level deserialization routine. This is very fast, and does no copying. +deserializeByteArray :: forall a. StableHashable a=> SipKey -> P.MutableByteArray RealWorld -> IO (BloomFilter a) +deserializeByteArray key arr = do + let len = P.sizeofMutableByteArray arr + log2lActual <- log2lFromArraySize len + let metadataBytesIx = sIZEOF_INT `uncheckedShiftL` log2lActual + assert (metadataBytesIx + sIZEOF_METADATA == len) $ return () + -- read bytes-at-a-time (endianness) and reconstruct metadata: + byts <- forM (take sIZEOF_METADATA [metadataBytesIx..]) $ P.readByteArray arr + let go [] = [] + go (b0:b1:b2:b3:b4:b5:b6:b7:bs) = unbytes64 [b0,b1,b2,b3,b4,b5,b6,b7] : go bs + go _ = error "Bug: somehow sIZEOF_METADATA could not be chunked evenly into Word64s" + case go byts of + m@[version,tpHashBlParam,keyHash,tpHashKeyHash,wdSzBits,k64,log2l64,_pad] -> + assert (length m == mETADATA_WORDS) $ do + let log2l = fromIntegral log2l64 + k = fromIntegral k64 + hash64Enough = isHash64Enough log2l k + l_minus1 = (2^log2l)-1 + blDirty :: BloomFilter a + blDirty = BloomFilter{..} -- defined here so we can use as proxy for param below. + + let check b = unless b . throwBloom + + check (version == sERIALIZATION_VERSION) $ + if version > sERIALIZATION_VERSION + then "This bloomfilter was serialized with a new version of unagi-bloomfilter than the one in use." + else "This bloomfilter was serialized with an older and incompatible version of unagi-bloomfilter than the one in use." + -- This for now but we will offer forward compatibility, if possible, should serialization ever need to change. + check (tpHashBlParam == tpHashOf blDirty) + "This serialized bloom filter contained elements of a different type than you were expecting, or was created with an incompatible Hashable instance. See StableHashable." + let keyHashExpected = hashSipKey key + tpHashKeyHashExpected = tpHashOf keyHashExpected + check (tpHashKeyHashExpected == tpHashKeyHash) + "Could not validate key. This serialized bloom filter was created with an incompatible Hashable instance. See StableHashable." + check (keyHash == hashWord64 keyHashExpected) + "The supplied key does not match the key that was used to create the serialized bloom filter." + check (fromIntegral wdSzBits == wordSizeInBits) $ + "Serialized bloom filters are not currently cross-architecture compatible. Word size in bits when the filter was created was "++(show wdSzBits)++", but on the local machine is "++(show wordSizeInBits) + check (fromIntegral k == k64 && fromIntegral log2l == log2l64) $ + "k or log2l could not fit in Int. This indicates corruption, or a bug: "++(show (k,k64,log2l,log2l64)) + checkParamInvariants k log2l + + return blDirty + + _ -> error "Bug: somehow we returned the wrong number of metadata words" + + + +tpHashOf :: StableHashable a => proxy a -> Word64 +tpHashOf = typeHashWord . typeHashOfProxy + +bytes64 :: Word64 -> [Word8] +{-# INLINE bytes64 #-} +bytes64 wd = [ shifted 56, shifted 48, shifted 40, shifted 32 + , shifted 24, shifted 16, shifted 8, fromIntegral wd] + where shifted = fromIntegral . uncheckedShiftR wd + +unbytes64 :: [Word8] -> Word64 +{-# INLINE unbytes64 #-} +unbytes64 [b0,b1,b2,b3,b4,b5,b6,b7] = + unshifted b0 56 .|. unshifted b1 48 .|. unshifted b2 40 .|. unshifted b3 32 .|. + unshifted b4 24 .|. unshifted b5 16 .|. unshifted b6 8 .|. fromIntegral b7 + where unshifted = uncheckedShiftL . fromIntegral +unbytes64 _ = error "unbytes64" + + + +-- ------------------------------------------------------------------ +-- Etc. +-- ------------------------------------------------------------------ + + +# ifdef EXPORT_INTERNALS +-- This could go anywhere, and lets us ensure that assertions are turned on +-- when running test suite. +assertionCanary :: IO Bool +assertionCanary = do + assertionsWorking <- try $ assert False $ return () + return $ + case assertionsWorking of + Left (AssertionFailed _) -> True + _ -> False +# endif diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,675 @@ +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns #-} +module Main (main) where + +import Control.Concurrent.BloomFilter.Internal +import qualified Control.Concurrent.BloomFilter as Bloom +import Data.Hashabler + +import Test.QuickCheck hiding ((.&.)) +import Data.Primitive.ByteArray +import Data.Primitive.MachDeps +import Data.Bits +import qualified Data.ByteString as B +import Control.Monad +import Control.Concurrent +import Data.Word +import Control.Exception +import Text.Printf +import Data.List +import System.Random +import Control.Applicative +import Prelude + +main :: IO () +main = do +# ifdef ASSERTIONS_ON + checkAssertionsOn +# else + putStrLn "!!! WARNING !!!: assertions not turned on in library code. configure with -finstrumented (first a `cabal clean` may be necessary) if you want to run tests with assertions enabled (it's good to test with both)" +# endif + procs <- getNumCapabilities + if procs < 2 + then putStrLn "!!! WARNING !!!: Some tests are only effective if more than 1 core is available" + else return () + + -- test helper sanity: -------- + unless ((fromBits64 $ replicate 64 '1') == (maxBound :: Word64) && + fromBits64 ((replicate 62 '0') ++ "11") == 3) $ + error "fromBits64 helper borked" + + + -- uncheckedSetBit: -------- + quickCheckErr 10000 $ \(Large i) -> + all (\b-> ((i::Int) `setBit` b) == (i `uncheckedSetBit` b)) + [0.. wordSizeInBits-1] + + + -- log2w -------- + unless ((fromIntegral log2w :: Float) + == logBase 2 (fromIntegral wordSizeInBits) + && (2^log2w == wordSizeInBits)) $ + error "log2w /= logBase 2 wordSizeInBits" + + + -- maskLog2wRightmostBits -------- + let w = (2^^log2w) :: Float + unless ((w-1) == fromIntegral maskLog2wRightmostBits) $ + error "maskLog2wRightmostBits is ill-defined" + quickCheckErr 10000 $ \(Large i) -> + fromIntegral (i .&. maskLog2wRightmostBits) < w + + + -- hash64Enough: -------- + let sz33MB = 22 + kThatJustFits = (64-sz33MB) `div` log2w + do newOnlyNeeds64 <- Bloom.new (SipKey 1 1) kThatJustFits sz33MB + unless (hash64Enough newOnlyNeeds64) $ + error "These parameters should have produced a bloom requiring only 64 hash bits" + newNeeds128 <- Bloom.new (SipKey 1 1) (kThatJustFits+1) sz33MB + unless (not $ hash64Enough newNeeds128) $ + error "These parameters should have produced a bloom requiring just a bit more than 64-bits!" + + -- for membershipWordAndBits128 and membershipWordAndBits64: + membershipWordTests + + -- Creation/Insertion/FPR unit tests: + createInsertFprTests + smallBloomTest + insertSaturateTest + insertConcurrentTest + highFprTest + + expectedExceptionsTest + + -- combining operations: + unionSmokeTest + unionTests + intersectionTests + + serializationTests + + putStrLn "TESTS PASSED" + +-- Test exceptions that should only be possible to raise in untyped interface: +expectedExceptionsTest :: IO () +expectedExceptionsTest = do + let assertRaises io = catch (io >> error "Expected BloomFilterException to be raised.") + (\e -> (e :: BloomFilterException) `seq` return ()) + nw :: Int -> Int -> IO (Bloom.BloomFilter Int) + nw = Bloom.new (SipKey 1 1) + -- `k` not > 0 + assertRaises $ nw 0 0 + -- `log2l` not >= 0 + assertRaises $ nw 1 (-1) + -- `log2l` too damn big + assertRaises $ nw 1 65 + -- requiring > 128 hash bits: + assertRaises $ nw ((120 `div` log2w) + 1) 8 + assertRaises $ nw 3 ((128 - 3*log2w) + 1) + +-- Try to get all bits of a small filter filled and force many configurations: +insertSaturateTest :: IO () +insertSaturateTest = do + randKey <- (,) <$> randomIO <*> randomIO + bl <- Bloom.new (uncurry SipKey randKey) 2 2 + forM_ [(1::Int)..500] $ \el-> do + void $ Bloom.insert bl el + truePos <- Bloom.lookup bl el + unless truePos $ + error $ "insertSaturateTest: Somehow got a false neg after insertion: "++(show (el, randKey)) + forM_ [0..3] $ \ix-> do + wd <- readByteArray (arr bl) ix + let fill = popCount (wd :: Word) + when (fill < (wordSizeInBits - 10)) $ + error $ "Bloomfilter doesn't look like it was saturated like we expected " + ++(show fill)++" "++(show randKey) + + +insertConcurrentTest :: IO () +insertConcurrentTest = do + let k = 6 + forM_ [0..12] $ \log2l-> do + let key = SipKey 23452345 (fromIntegral log2l) + b <- Bloom.new key k log2l + let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l)) + let (payload0,payload1) = splitAt szDataBytes [1..(szDataBytes * 2)] + done0 <- newEmptyMVar + done1 <- newEmptyMVar + void $ forkIO ((forM_ payload0 $ Bloom.insert b) >> putMVar done0 ()) + void $ forkIO ((forM_ payload1 $ Bloom.insert b) >> putMVar done1 ()) + takeMVar done0 >> takeMVar done1 + + control <- Bloom.new key k log2l + forM_ (payload0++payload1) $ Bloom.insert control + + equalBloom b control + + + +-- Smoke test for very small bloom filters: +smallBloomTest :: IO () +smallBloomTest = + forM_ [0..2] $ \ourLog2l-> do + randKey <- (,) <$> randomIO <*> randomIO + bl <- Bloom.new (uncurry SipKey randKey) 3 ourLog2l + forM_ [1,2::Int] $ \el-> do + likelyNotPresent <- Bloom.insert bl el + truePos <- Bloom.lookup bl el + unless truePos $ + error $ "smallBloomTest: Somehow got a false neg after insertion: "++(show (ourLog2l, el, randKey)) + unless likelyNotPresent $ + error $ "smallBloomTest: got unlikely failure, please report: "++(show (ourLog2l, el, randKey)) + + +membershipWordTests :: IO () +membershipWordTests = do + let sz33MB = 22 + -- membershipWordAndBits64 -------- + do let membershipWord = "1101001001001001001011" + let h | wordSizeInBits == 64 = Hash64 $ fromBits64 $ membershipWord++" 001111 001110 001101 001100 001011 001010 001001" + | otherwise = Hash64 $ fromBits64 $ "1111111"++membershipWord++" 01111 01110 01101 01100 01011 01010 01001" + -- \ \ 7 membership bits (15..9) / + -- \____ unused + newOnlyNeeds64 <- Bloom.new (SipKey 1 1) 7 sz33MB + assert (hash64Enough newOnlyNeeds64) $ return () + let (memberWordOut, wordToOr) = + membershipWordAndBits64 h newOnlyNeeds64 + + let memberWordExpected = fromIntegral $ fromBits64 (replicate (64-22) '0' ++ membershipWord) + wordToOrExpected = fromIntegral $ fromBits64 $ -- casts to 32-bit Int on 32-bit arch: + "000000000000000000000000000000000000000000000000 1111111 000000000" + + unless (memberWordOut == memberWordExpected) $ + error $ "membershipWordAndBits64 memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut) + unless (wordToOr == wordToOrExpected) $ + error $ "membershipWordAndBits64 wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr) + + do + -- first test filling exactly 64-bits: + let membershipWord = "1001" -- n.b. remaining bits divisible by log2w on both 32 and 64-bits + let kFilling64 | wordSizeInBits == 64 = 10 + | otherwise = 12 + memberBitsToSet = take kFilling64 [3..] + assert (maximum memberBitsToSet <= (wordSizeInBits-1)) $ return () + let kPayload = concatMap memberWordPaddedBinStr $ memberBitsToSet + h = Hash64 $ fromBits64 $ + membershipWord++kPayload + newNeedsExactly64 <- Bloom.new (SipKey 1 1) kFilling64 (length membershipWord) + assert (hash64Enough newNeedsExactly64) $ return () + -- + -- shared with next test: + let wordToOrExpected = foldl' setBit 0 memberBitsToSet + do + let memberWordExpected = 9 + let (memberWordOut, wordToOr) = + membershipWordAndBits64 h newNeedsExactly64 + + unless (memberWordOut == memberWordExpected) $ + error $ "membershipWordAndBits64-full memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut) + unless (wordToOr == wordToOrExpected) $ + error $ "membershipWordAndBits64-full wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr) + + + -- membershipWordAndBits128 -------- + + -- repeat above, but with one bit more in `l` so we need a single bit from h_1 -------- + let membershipWord' = "10001" --17 + h' = let h_0 = fromBits64 $ take (64-length membershipWord') (cycle "10") ++ membershipWord' + h_1 = fromBits64 $ take (64-length kPayload) (cycle "110") ++ kPayload + in Hash128 h_0 h_1 + newJustNeeds128 <- Bloom.new (SipKey 1 1) kFilling64 (length membershipWord') + assert (not $ hash64Enough newJustNeeds128) $ return () + do + let (memberWordOut, wordToOr) = + membershipWordAndBits128 h' newJustNeeds128 + let memberWordExpected = 17 + + unless (memberWordOut == memberWordExpected) $ + error $ "membershipWordAndBitsJust128 memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut) + unless (wordToOr == wordToOrExpected) $ + error $ "membershipWordAndBitsJust128 wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr) + + + -- need all 128 bits -------- + do let kFillingAll128 | wordSizeInBits == 64 = 20 + | otherwise = 24 + memberWordExpected = 170 + membershipWord'' = printf "%08b" memberWordExpected + memberWords = concatMap memberWordPaddedBinStr [1..kFillingAll128] + h128 = Hash128 (fromBits64 $ ks_0++membershipWord'') (fromBits64 ks_1) + where (ks_0, ks_1) = splitAt ((length memberWords) - 64) memberWords + newNeedsAll128 <- Bloom.new (SipKey 1 1) kFillingAll128 (length membershipWord'') + assert (not $ hash64Enough newNeedsAll128) $ return () + let wordToOrExpected' = foldl' setBit 0 [1..kFillingAll128] + + let (memberWordOut, wordToOr) = + membershipWordAndBits128 h128 newNeedsAll128 + unless (memberWordOut == memberWordExpected) $ + error $ "membershipWordAndBits128-full memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut) + unless (wordToOr == wordToOrExpected') $ + error $ "membershipWordAndBits128-full wordToOr: expected "++(show wordToOrExpected')++" but got "++(show wordToOr) + + -- need less than 128 bits, with 1s fill -------- + do let kJustOver = 13 + memberWordExpected = 170 + membershipWord'' = printf "%08b" memberWordExpected + memberWords = concatMap memberWordPaddedBinStr [1..kJustOver] + h128 = Hash128 (fromBits64 $ ks_0++pad_0++membershipWord'') (fromBits64 $ pad_1++ks_1) + where (ks_0, ks_1) = splitAt ((length memberWords) - 64) memberWords + pad_0 = replicate (64 - (length membershipWord'' + length ks_0)) '1' + pad_1 = replicate (64 - (length ks_1)) '1' + newJustOver <- Bloom.new (SipKey 1 1) kJustOver (length membershipWord'') + assert (not $ hash64Enough newJustOver) $ return () + let wordToOrExpected' = foldl' setBit 0 [1..kJustOver] + + let (memberWordOut, wordToOr) = + membershipWordAndBits128 h128 newJustOver + unless (memberWordOut == memberWordExpected) $ + error $ "membershipWordAndBits128-fullx memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut) + unless (wordToOr == wordToOrExpected') $ + error $ "membershipWordAndBits128-fullx wordToOr: expected "++(show wordToOrExpected')++" but got "++(show wordToOr) + + + + +-- set a unique bit in each source and target word, check exact expected individual bits +unionSmokeTest :: IO () +unionSmokeTest = do + b2 <- Bloom.new (SipKey 1 1) 3 1 + b8 <- Bloom.new (SipKey 1 1) 3 3 + let wds8 = zip [0..] $ map (2^) $ take 8 [(3::Int)..] + let f (ix,v) (x1,x2) | even ix = (x1.|.v, x2) + | otherwise = (x1, x2.|.v) + let (expected_1,expected_2) = foldr f (2,4) wds8 + + writeByteArray (arr b2) 0 (2::Word) + writeByteArray (arr b2) 1 (4::Word) + + forM_ wds8 $ \(ix,v)-> + writeByteArray (arr b8) ix (v::Word) + + b8 `unionInto` b2 + actual_1 <- readByteArray (arr b2) 0 + actual_2 <- readByteArray (arr b2) 1 + unless (actual_1 == expected_1 && actual_2 == expected_2 && actual_1 > 0 && actual_2 > 0) $ + error $ "Union insane: "++(show [expected_1,actual_1, expected_2, actual_2]) + + -- check identical size: + b8' <- Bloom.new (SipKey 1 1) 3 3 + b8 `unionInto` b8' + forM_ wds8 $ \(ix,v)-> do + v' <- readByteArray (arr b8') ix + unless (v == v') $ + error "Union smoke test on identical length filters failed." + +unionTests :: IO () +unionTests = do + forM_ [19,20] $ \bigl-> forM_ [10..bigl] $ \littlel -> + forM_ ([3,11,12,13]++ if log2w == 6 then [10] else []) $ \ourk -> do -- for 64 and 128 + b1 <- Bloom.new (SipKey 1 1) ourk bigl + b2 <- Bloom.new (SipKey 1 1) ourk littlel + let xs = [200..600] :: [Int] + let ys = [400..800] :: [Int] + let nots = [0..199] + let xsys = [200..800] + mapM_ (Bloom.insert b1) xs + mapM_ (Bloom.insert b2) ys + b1 `Bloom.unionInto` b2 + forM_ nots $ \v-> do + exsts <- Bloom.lookup b2 v + when exsts $ error $ (show (bigl,littlel,v,ourk))++": Found unexpected element" + forM_ xsys $ \v-> do + exsts <- Bloom.lookup b2 v + unless exsts $ error $ (show (bigl,littlel,v,ourk))++": Could not find expected element." + + forM_ [0..10] $ \bigl-> forM_ [0..bigl] $ \littlel -> do + forM_ [2,14] $ \ourk -> do + b1 <- Bloom.new (SipKey 2 2) ourk bigl + b2 <- Bloom.new (SipKey 2 2) ourk littlel + void $ Bloom.insert b1 'a' + void $ Bloom.insert b2 'b' + b1 `Bloom.unionInto` b2 + forM_ "cdefghijkl" $ \v-> do + exsts <- Bloom.lookup b2 v + when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element" + forM_ "ab" $ \v-> do + exsts <- Bloom.lookup b2 v + unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element." + + -- another to excercise 128-bit a little more: + forM_ [16,17] $ \bigl-> + forM_ [9..18] $ \ourk -> do + let littlel = 16 + b1 <- Bloom.new (SipKey 2 2) ourk bigl + b2 <- Bloom.new (SipKey 2 2) ourk littlel + void $ Bloom.insert b1 'a' + void $ Bloom.insert b2 'b' + b1 `Bloom.unionInto` b2 + forM_ "cdefghijkl" $ \v-> do + exsts <- Bloom.lookup b2 v + when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element" + forM_ "ab" $ \v-> do + exsts <- Bloom.lookup b2 v + unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element." + + -- and using all 128 bits. + let kFillingAll128 | wordSizeInBits == 64 = 20 + | otherwise = 24 + b1 <- Bloom.new (SipKey 2 2) kFillingAll128 8 + b2 <- Bloom.new (SipKey 2 2) kFillingAll128 7 + void $ Bloom.insert b1 'a' + void $ Bloom.insert b2 'b' + b1 `Bloom.unionInto` b2 + forM_ "cdefghijkl" $ \v-> do + exsts <- Bloom.lookup b2 v + when exsts $ error $ ": Found unexpected element" + forM_ "ab" $ \v-> do + exsts <- Bloom.lookup b2 v + unless exsts $ error $ ": Could not find expected element." + + +-- the union tests are sufficient to test 'combine'. Just do a sanity check here. +intersectionTests :: IO () +intersectionTests = + forM_ [18,19] $ \bigl-> forM_ [10..bigl] $ \littlel -> + forM_ [5,14] $ \ourk -> do + b1 <- Bloom.new (SipKey 3 1) ourk bigl + b2 <- Bloom.new (SipKey 3 1) ourk littlel + let xs = [200..600] :: [Int] + let ys = [400..800] :: [Int] + let nots = [199..399]++[601..801] + let xsys = [400..600] + mapM_ (Bloom.insert b1) xs + mapM_ (Bloom.insert b2) ys + b1 `Bloom.intersectionInto` b2 + forM_ nots $ \v-> do + exsts <- Bloom.lookup b2 v + when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element" + forM_ xsys $ \v-> do + exsts <- Bloom.lookup b2 v + unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element." + +serializationTests :: IO () +serializationTests = do + quickCheckErr 1000 $ \(Large wd64)-> + wd64 == (unbytes64 . bytes64 $ wd64) + equalBloomSane + -- test log2lFromArraySize: + forM_ [(1,0), (2,1), (3,2), (4,8), (5, 12)] $ \args-> do + BloomFilter{..} <- uncurry (Bloom.new (SipKey 848 734783)) args + log2lCalc <- log2lFromArraySize (sizeofMutableByteArray arr) + unless (log2l == log2lCalc) $ + error $ "log2lFromArraySize mismatch: "++(show (args,log2l,log2lCalc)) + + serializeRoundtripsTest + serializeGoldenTests + +-- For validating that we can serialize and deserialize across machines, and +-- try to handle forwards compatibility (later). +serializeGoldenTests :: IO () +serializeGoldenTests = do + if sIZEOF_INT == 8 + then + forM_ [(1,0), (2,1), (3,2), (3,7), (4, 10)] $ \(k, log2l)-> do + let key = SipKey 983745 476835 + b <- Bloom.new key k log2l + let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l)) + payload <- forM [1..(szDataBytes * 2)] $ \x-> do + void $ Bloom.insert b x + return x + + let path = "tests/serialized/"++(show k)++"_"++(show log2l)++".64.bytestring" + bSerNow <- unsafeSerialize b + -- B.writeFile path bSerNow -- UNCOMMENT TO REGENERATE: + bSerStored <- B.readFile path + unless (bSerNow == bSerStored) $ + error $ "Deserialized stored bloom did not match: "++path + + b' <- Bloom.deserialize key bSerStored + forM_ payload $ \x-> do + present <- Bloom.lookup b' x + unless present $ error $ "Did not find all expected elements in: "++path + + else + -- TODO. Don't have a 32-bit machine to generate filters from. + return () + +serializeRoundtripsTest :: IO () +serializeRoundtripsTest = do + let key = SipKey 87345 8723 + forM_ [(1,0), (2,1), (3,2), (3,7), (3, 14)] $ \(k, log2l)-> do + b <- Bloom.new key k log2l + let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l)) + forM_ [1..(szDataBytes * 2)] $ \x-> do + void $ Bloom.insert b x + + bSer <- Bloom.serialize b + bUnsafeSer <- unsafeSerialize b + unless (bSer == bUnsafeSer) $ + error $ "Unsafe and safe serialize produced different bytestrings with"++(show (k,log2l)) + b' <- Bloom.deserialize key bSer + b'U <- Bloom.deserialize key bUnsafeSer + equalBloom b b' + equalBloom b b'U + + -- Now mangle and unmangle the bytestring to excercise offset/length, etc. + -- in deserialization: + let (!dc,!ba) = B.splitAt 5 $ B.reverse bUnsafeSer + !bax = ba `B.snoc` 0xFF + !xabcd = B.reverse bax `B.append` B.reverse dc + let !bUnsafeSer' = B.drop 1 xabcd + unless (bUnsafeSer == bUnsafeSer') $ error "Didn't mangle/unmangle properly" + b'U' <- Bloom.deserialize key bUnsafeSer' + equalBloom b b'U' + + +equalBloomSane :: IO () +equalBloomSane = do + let key = SipKey 99 100 + forM_ [(1,0), (2,1), (3,2), (4,8), (5, 12)] $ \(k, log2l)-> do + b0 <- Bloom.new key k log2l + b1 <- Bloom.new key k log2l + b2 <- Bloom.new key k log2l + let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l)) + forM_ [1..(szDataBytes * 2)] $ \x-> do + void $ Bloom.insert b0 x + void $ Bloom.insert b1 x + void $ Bloom.insert b2 x + equalBloom b0 b1 + -- modify in metadata region, and make sure equal: + writeByteArray (arr b0) szDataBytes (0xFF::Word8) + writeByteArray (arr b0) (sizeofMutableByteArray (arr b0) -1) (0xFF:: Word8) + equalBloom b0 b1 + + -- ensure we catch differences + writeByteArray (arr b0) (szDataBytes-1) (0x02::Word8) -- last data byte + throws1 <- try (equalBloom b0 b1) + writeByteArray (arr b2) (szDataBytes-1) (0x02::Word8) -- last data byte + equalBloom b0 b2 + writeByteArray (arr b2) 0 (0xFF::Word8) -- first data byte + throws2 <- try (equalBloom b0 b2) + case [throws1 :: Either SomeException (), throws2] of + [Left _, Left _] -> return () + es -> error $ "equalBloom didn't detect differences: "++(show es) + + + +{- + A NOTE ON TESTING FPR (from the paper) + +"consideration when implementing Bloom-1 filters. To +ensure that the results obtained using Eq. (5) are accurate, +a Bloom-1 filter was implemented in Matlab using ideal +hash functions and simulated for the same parameters. In +each simulation, 10,000 Fast Bloom filters are generated +by inserting random elements until the specified load is +achieved. Then their false positive rate is evaluated doing +10^6 random queries of non member elements. The average +results were checked against those obtained with Eq. (5). +This was done for false positive rates larger than 10-6 +. In all cases, differences were smaller than 0.5%." +-} + +createInsertFprTests :: IO () +createInsertFprTests = + let bloomParams = [ + -- all params with low FPR: + (2, 1, 2), + (4, 1, 3), + (500, 8, 3), + (1000, 8, 10), + (500, 8, 15), + (500, 8, 20), + (5000000, 22, 3)] + in forM_ bloomParams $ \param@(payloadSz, ourLog2l, ourK)-> do + let !loadedFpr = fpr payloadSz (2^ourLog2l) ourK wordSizeInBits + payload = take payloadSz [2,4..] :: [Int] + antiPayloadSz = 10000 + antiPayload = take antiPayloadSz [1,3..] + randKey <- (,) <$> randomIO <*> randomIO + bl <- Bloom.new (uncurry SipKey randKey) ourK ourLog2l + + allNeg <- mapM (Bloom.lookup bl) payload + unless (all not allNeg) $ + error $ "Expected empty: "++(show param)++"\n"++(show randKey)++(show allNeg) + + falsesAndFPs <- mapM (Bloom.insert bl) payload + -- This should on average be less than `loadedFpr` calculated on fully-loaded + -- bloom filter: + let insertionFprMeasured = + (fromIntegral $ length $ filter not falsesAndFPs) / (fromIntegral payloadSz) + allTruePositives <- mapM (Bloom.lookup bl) payload + unless (and allTruePositives) $ + error $ "Expected all true positives"++(show param)++"\n"++(show randKey) + + falsePs <- mapM (Bloom.lookup bl) antiPayload + let !loadedFprMeasured = + (fromIntegral $ length $ filter id falsePs) / (fromIntegral antiPayloadSz) + + -- TODO proper statistical measure of accuracy of measured FPR + unless (all (< 0.01) [insertionFprMeasured, loadedFprMeasured]) $ + error $ "Measured unexpectedly high FPR. Possible fluke; please retry tests: " + ++(show param)++"\n"++(show randKey) + unless ((abs $ loadedFprMeasured - loadedFpr) < 0.005) $ + error $ "Measured FPR deviated from calculated FPR more than we expected: " + ++(show param)++"\n"++(show randKey) + + allTruePositivesIns <- mapM (Bloom.insert bl) payload + unless (all not allTruePositivesIns) $ + error $ "Expected all true positives (i.e. insert failures): " + ++(show param)++"\n"++(show randKey) + + +-- spot check our `fpr` function at higher values: +highFprTest :: IO () +highFprTest = do + let bloomParams = [ + -- params with double-digit pct FPR + (50000, 10, 3) + , (65000, 10, 3) -- 84.8% calculated . I guess error only affects smaller filters significantly? + , (5000, 8, 3) + , (5000, 8, 10) + , (500, 6, 1) + , (1000, 5, 2) + + , (200, 5, 2) -- low single-digit FPR + , (500, 6, 2) + +-- TODO commented values below deviated slightly out of our allowed range after +-- changing to siphash64_1_3. Figure out and add back. + + -- for small sizes, high-ish loads + -- , (625, 4, 2) -- 51% measured, 48% calculated + , (625, 3, 2) -- 83% measured, 78% calculated + , (700, 3, 2) + -- , (750, 3, 2) + , (750, 3, 3) + -- 50% fp or lower: + -- , (350, 3, 2) + , (200, 3, 2) + , (150, 3, 2) + -- > 90% fpr + , (2000, 4, 2) + , (2000, 4, 3) + + , (2500, 5, 2) + , (2450, 5, 2) + , (2400, 5, 2) + ] + in forM_ bloomParams $ \param@(payloadSz, ourLog2l, ourK)-> do + let !loadedFpr = fpr payloadSz (2^ourLog2l) ourK wordSizeInBits + payload = take payloadSz [2,4..] :: [Int] + antiPayloadSz = 200000 + antiPayload = take antiPayloadSz [1,3..] + randKey <- (,) <$> randomIO <*> randomIO + bl <- Bloom.new (uncurry SipKey randKey) ourK ourLog2l + mapM_ (Bloom.insert bl) payload + + falsePs <- mapM (Bloom.lookup bl) antiPayload + let !loadedFprMeasured = + (fromIntegral $ length $ filter id falsePs) / (fromIntegral antiPayloadSz) + + unless ((abs $ loadedFprMeasured - loadedFpr) < 0.03) $ + error $ "Measured high FPR deviated from calculated FPR more than we expected: " + ++(fmtPct loadedFprMeasured)++" "++(fmtPct loadedFpr) + ++(show param)++"\n"++(show randKey) + + +fmtPct :: Double -> String +fmtPct x = printf "%.2f%%" (x*100) + + +# ifdef ASSERTIONS_ON +checkAssertionsOn :: IO () +checkAssertionsOn = do + -- Make sure testing environment is sane: + assertionsWorking <- try $ assert False $ return () + assertionsWorkingInLib <- assertionCanary + case assertionsWorking of + Left (AssertionFailed _) + | assertionsWorkingInLib -> putStrLn "Assertions: On" + _ -> error "Assertions aren't working" +# endif + + +-- Test helpers: +fromBits64 :: String -> Word64 +fromBits64 bsDirty = + let bs = zip [0..] $ reverse $ filter (\b-> b == '0' || b == '1') bsDirty + in if length bs /= 64 + then error "Expecting 64-bits" + else foldr (\(nth,c) wd-> if c == '1' then (wd `setBit` nth) else wd) 0x00 bs + +memberWordPaddedBinStr :: Int -> String +memberWordPaddedBinStr n + | n > wordSizeInBits = error "memberBitStr" + | otherwise = printf ("%0"++(show log2w)++"b") n + + +-- Utilites: --------------------------------- +quickCheckErr :: Testable prop => Int -> prop -> IO () +quickCheckErr n p = + quickCheckWithResult stdArgs{ maxSuccess = n , chatty = False } p + >>= maybeErr + + where maybeErr (Success _ _ _) = return () + maybeErr e = error $ show e + +-- TODO eventually could replace this with an exported lib function (e.g. Eq on frozen BloomFilters) +-- easiest might just be unsafeSerialize + Eq for ByteString +equalBloom :: BloomFilter a -> BloomFilter a -> IO () +equalBloom b0 b1 = do + unless ((key b0, k b0, hash64Enough b0, l_minus1 b0, log2l b0) == (key b1, k b1, hash64Enough b1, l_minus1 b1, log2l b1)) $ + error "Can't compare arrays, since params aren't the same" + let sz0 = sizeofMutableByteArray (arr b0) + unless (sz0 == (sizeofMutableByteArray $ arr b1)) $ + error "Array sizes differ" + + let dataWords = floor ((2::Float)^(log2l b0)) + forM_ [0..(dataWords -1)] $ \wordIx -> do + w0 <- readByteArray (arr b0) wordIx + w1 <- readByteArray (arr b1) wordIx + unless ((w0 :: Word) == w1) $ + error $ "Arrays differ at ix: "++(show wordIx) + + diff --git a/unagi-bloomfilter.cabal b/unagi-bloomfilter.cabal new file mode 100644 --- /dev/null +++ b/unagi-bloomfilter.cabal @@ -0,0 +1,144 @@ +name: unagi-bloomfilter +version: 0.1.0.0 +synopsis: A fast, cache-efficient, concurrent bloom filter +description: + This library implements a fast concurrent bloom filter, based on bloom-1 from + "Fast Bloom Filters and Their Generalization" by Y Qiao, et al. + . + A bloom filter is a probabilistic, constant-space, set-like data structure + supporting insertion and membership queries. This implementation is backed by + SipHash so can safely consume untrusted inputs. + . + The implementation here compares favorably with traditional set + implementations in a single-threaded context: + . + <> + . + Unfortunately writes in particular don't seem to scale currently; i.e. + distributing writes across multiple threads may be /slower/ than in a + single-threaded context, because of memory effects. We plan to export + functionality that would support using the filter here in a concurrent + context with better memory behavior (e.g. a server that shards to a + thread-pool which handles only a portion of the bloom array). + . + <> + . + +homepage: http://github.com/jberryman/unagi-bloomfilter +license: BSD3 +license-file: LICENSE +author: Brandon Simmons +maintainer: brandon.m.simmons@gmail.com +-- copyright: +category: Concurrency +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/jberryman/unagi-bloomfilter.git + +Flag dev + Description: To build tests, executables and benchmarks do `configure -fdev --enable-tests` and run the built executables by hand (i.e. not with `cabal test` etc.; we put all our different executables in test-suite sections in order to hide their dependencies from hackage) + Default: False + -- TODO did this solve our issues with having executable sections and hackage deps?: + Manual: True + +Flag instrumented + Description: Enables assertions in library code. When --enable-library-profiling and --enable-executable-profiling is turned on, you can get stacktraces as well + Default: False + Manual: True + +library + if flag(dev) + CPP-Options: -DEXPORT_INTERNALS + if flag(instrumented) + ghc-options: -fno-ignore-asserts + -- TODO stacktraces don't seem to show anything useful. Maybe because of INLINEs?: + -- ghc-prof-options: "-with-rtsopts=-xc" -fprof-auto -fprof-auto-calls + + exposed-modules: Control.Concurrent.BloomFilter + , Control.Concurrent.BloomFilter.Internal + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + , atomic-primops >= 0.8 + , primitive + , bytestring + , hashabler >= 1.3.0 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs -O2 -funbox-strict-fields + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: Main.hs + -- other-modules: + + ghc-options: -Wall -O2 -threaded -funbox-strict-fields -fno-ignore-asserts "-with-rtsopts=-N" + if flag(instrumented) + ghc-prof-options: "-with-rtsopts=-xc" -fprof-auto -fprof-auto-calls + + if flag(instrumented) + CPP-Options: -DASSERTIONS_ON + if flag(dev) + buildable: True + build-depends: base + , QuickCheck + , random + , unagi-bloomfilter + , primitive + , bytestring + , hashabler + else + buildable: False + + +benchmark bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + ghc-options: -Wall -O2 -threaded -funbox-strict-fields + ghc-options: "-with-rtsopts=-N -A50M -qa" + hs-source-dirs: benchmarks + if flag(instrumented) + CPP-Options: -DASSERTIONS_ON + if flag(dev) + buildable: True + build-depends: base + , criterion + , unagi-bloomfilter + , unordered-containers + , containers + , text + , deepseq + , random + , hashabler + else + buildable: False + + +executable dev-example + if !flag(dev) + buildable: False + else + build-depends: + base + , unagi-bloomfilter + + -- ghc-options: -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques -ddump-core-stats -ddump-inlinings + ghc-options: -O2 -rtsopts + -- for ghc bug(?) https://ghc.haskell.org/trac/ghc/ticket/11263 + ghc-options: -fsimpl-tick-factor=200 + + -- Either do threaded for eventlogging and simple timing... + -- ghc-options: -threaded -eventlog + -- and run e.g. with +RTS -N -l + + hs-source-dirs: core-example + main-is: Main.hs + default-language: Haskell2010 +