module Data.BloomFilter.Hash
(
Hashable(..)
, hash32
, hash64
, hashSalt32
, hashSalt64
, hashes
, cheapHashes
, hashOne32
, hashOne64
, hashList32
, hashList64
) where
import Control.Monad (foldM)
import Data.Bits ((.&.), (.|.), xor)
import Data.BloomFilter.Util (FastShift(..))
import Data.List (unfoldr)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.String (CString)
#if __GLASGOW_HASKELL__ >= 704
import Foreign.C.Types (CInt(..), CSize(..))
#else
import Foreign.C.Types (CInt, CSize)
#endif
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray, withArrayLen)
import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)
import Foreign.Storable (Storable, peek, poke, sizeOf)
import System.IO.Unsafe (unsafePerformIO)
import Data.ByteString.Internal (ByteString(..))
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy.Internal as LB
import qualified Data.ByteString.Lazy as LB
#include "HsBaseConfig.h"
foreign import ccall unsafe "lookup3.h _jenkins_hashword" hashWord
:: Ptr Word32 -> CSize -> Word32 -> IO Word32
foreign import ccall unsafe "lookup3.h _jenkins_hashword2" hashWord2
:: Ptr Word32 -> CSize -> Ptr Word32 -> Ptr Word32 -> IO ()
foreign import ccall unsafe "lookup3.h _jenkins_hashlittle" hashLittle
:: Ptr a -> CSize -> Word32 -> IO Word32
foreign import ccall unsafe "lookup3.h _jenkins_hashlittle2" hashLittle2
:: Ptr a -> CSize -> Ptr Word32 -> Ptr Word32 -> IO ()
class Hashable a where
hashIO32 :: a
-> Word32
-> IO Word32
hashIO64 :: a
-> Word64
-> IO Word64
hashIO64 v salt = do
let s1 = fromIntegral (salt `shiftR` 32) .&. maxBound
s2 = fromIntegral salt
h1 <- hashIO32 v s1
h2 <- hashIO32 v s2
return $ (fromIntegral h1 `shiftL` 32) .|. fromIntegral h2
hash32 :: Hashable a => a -> Word32
hash32 = hashSalt32 0x106fc397
hash64 :: Hashable a => a -> Word64
hash64 = hashSalt64 0x106fc397cf62f64d3
hashSalt32 :: Hashable a => Word32
-> a
-> Word32
hashSalt32 salt k = unsafePerformIO $ hashIO32 k salt
hashSalt64 :: Hashable a => Word64
-> a
-> Word64
hashSalt64 salt k = unsafePerformIO $ hashIO64 k salt
hashes :: Hashable a => Int
-> a
-> [Word32]
hashes n v = unfoldr go (n,0x3f56da2d3ddbb9f6)
where go (k,s) | k <= 0 = Nothing
| otherwise = let s' = hashSalt32 s v
in Just (s', (k1,s'))
cheapHashes :: Hashable a => Int
-> a
-> [Word32]
cheapHashes k v = go 0
where go i | i == j = []
| otherwise = hash : go (i + 1)
where !hash = h1 + (h2 `shiftR` i)
h1 = fromIntegral (h `shiftR` 32)
h2 = fromIntegral h
h = hashSalt64 0x9150a946c4a8966e v
j = fromIntegral k
instance Hashable () where
hashIO32 _ salt = return salt
instance Hashable Integer where
hashIO32 k salt | k < 0 = hashIO32 (unfoldr go (k))
(salt `xor` 0x3ece731e9c1c64f8)
| otherwise = hashIO32 (unfoldr go k) salt
where go 0 = Nothing
go i = Just (fromIntegral i :: Word32, i `shiftR` 32)
instance Hashable Bool where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Ordering where
hashIO32 = hashIO32 . fromEnum
hashIO64 = hashIO64 . fromEnum
instance Hashable Char where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Int where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Float where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Double where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Int8 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Int16 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Int32 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Int64 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Word8 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Word16 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Word32 where
hashIO32 = hashOne32
hashIO64 = hashOne64
instance Hashable Word64 where
hashIO32 = hashOne32
hashIO64 = hashOne64
div4 :: CSize -> CSize
div4 k = fromIntegral ((fromIntegral k :: HTYPE_SIZE_T) `shiftR` 2)
alignedHash :: Ptr a -> CSize -> Word32 -> IO Word32
alignedHash ptr bytes salt
| bytes .&. 3 == 0 = hashWord (castPtr ptr) (div4 bytes) salt'
| otherwise = hashLittle ptr bytes salt'
where salt' = fromIntegral salt
with :: Storable a => a -> (Ptr a -> IO b) -> IO b
with val f =
alloca $ \ptr -> do
poke ptr val
f ptr
alignedHash2 :: Ptr a -> CSize -> Word64 -> IO Word64
alignedHash2 ptr bytes salt =
with (fromIntegral salt) $ \sp -> do
let p1 = castPtr sp
p2 = castPtr sp `plusPtr` 4
doubleHash ptr bytes p1 p2
peek sp
doubleHash :: Ptr a -> CSize -> Ptr Word32 -> Ptr Word32 -> IO ()
doubleHash ptr bytes p1 p2
| bytes .&. 3 == 0 = hashWord2 (castPtr ptr) (div4 bytes) p1 p2
| otherwise = hashLittle2 ptr bytes p1 p2
instance Hashable SB.ByteString where
hashIO32 bs salt = unsafeUseAsCStringLen bs $ \ptr len ->
alignedHash ptr (fromIntegral len) salt
hashIO64 bs salt = unsafeUseAsCStringLen bs $ \ptr len ->
alignedHash2 ptr (fromIntegral len) salt
rechunk :: LB.ByteString -> [SB.ByteString]
rechunk s | LB.null s = []
| otherwise = let (pre,suf) = LB.splitAt chunkSize s
in repack pre : rechunk suf
where repack = SB.concat . LB.toChunks
chunkSize = fromIntegral LB.defaultChunkSize
instance Hashable LB.ByteString where
hashIO32 bs salt = foldM (flip hashIO32) salt (rechunk bs)
hashIO64 = hashChunks
instance Hashable a => Hashable (Maybe a) where
hashIO32 Nothing salt = return salt
hashIO32 (Just k) salt = hashIO32 k salt
hashIO64 Nothing salt = return salt
hashIO64 (Just k) salt = hashIO64 k salt
instance (Hashable a, Hashable b) => Hashable (Either a b) where
hashIO32 (Left a) salt = hashIO32 a salt
hashIO32 (Right b) salt = hashIO32 b (salt + 1)
hashIO64 (Left a) salt = hashIO64 a salt
hashIO64 (Right b) salt = hashIO64 b (salt + 1)
instance (Hashable a, Hashable b) => Hashable (a, b) where
hashIO32 (a,b) salt = hashIO32 a salt >>= hashIO32 b
hashIO64 (a,b) salt = hashIO64 a salt >>= hashIO64 b
instance (Hashable a, Hashable b, Hashable c) => Hashable (a, b, c) where
hashIO32 (a,b,c) salt = hashIO32 a salt >>= hashIO32 b >>= hashIO32 c
instance (Hashable a, Hashable b, Hashable c, Hashable d) =>
Hashable (a, b, c, d) where
hashIO32 (a,b,c,d) salt =
hashIO32 a salt >>= hashIO32 b >>= hashIO32 c >>= hashIO32 d
instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) =>
Hashable (a, b, c, d, e) where
hashIO32 (a,b,c,d,e) salt =
hashIO32 a salt >>= hashIO32 b >>= hashIO32 c >>= hashIO32 d >>= hashIO32 e
instance Storable a => Hashable [a] where
hashIO32 = hashList32
hashIO64 = hashList64
hashOne32 :: Storable a => a -> Word32 -> IO Word32
hashOne32 k salt = with k $ \ptr ->
alignedHash ptr (fromIntegral (sizeOf k)) salt
hashOne64 :: Storable a => a -> Word64 -> IO Word64
hashOne64 k salt = with k $ \ptr ->
alignedHash2 ptr (fromIntegral (sizeOf k)) salt
hashList32 :: Storable a => [a] -> Word32 -> IO Word32
hashList32 xs salt =
withArrayLen xs $ \len ptr ->
alignedHash ptr (fromIntegral (len * sizeOf (head xs))) salt
hashList64 :: Storable a => [a] -> Word64 -> IO Word64
hashList64 xs salt =
withArrayLen xs $ \len ptr ->
alignedHash2 ptr (fromIntegral (len * sizeOf (head xs))) salt
unsafeUseAsCStringLen :: SB.ByteString -> (CString -> Int -> IO a) -> IO a
unsafeUseAsCStringLen (PS fp o l) action =
withForeignPtr fp $ \p -> action (p `plusPtr` o) l
type HashState = Ptr Word32
foreign import ccall unsafe "lookup3.h _jenkins_little2_begin" c_begin
:: Ptr Word32 -> Ptr Word32 -> HashState -> IO ()
foreign import ccall unsafe "lookup3.h _jenkins_little2_frag" c_frag
:: Ptr a -> CSize -> HashState -> CSize -> IO CSize
foreign import ccall unsafe "lookup3.h _jenkins_little2_step" c_step
:: Ptr a -> CSize -> HashState -> IO CSize
foreign import ccall unsafe "lookup3.h _jenkins_little2_end" c_end
:: CInt -> Ptr Word32 -> Ptr Word32 -> HashState -> IO ()
unsafeAdjustCStringLen :: SB.ByteString -> Int -> (CString -> Int -> IO a)
-> IO a
unsafeAdjustCStringLen (PS fp o l) d action
| d > l = action nullPtr 0
| otherwise = withForeignPtr fp $ \p -> action (p `plusPtr` (o + d)) (l d)
hashChunks :: LB.ByteString -> Word64 -> IO Word64
hashChunks s salt = do
with (fromIntegral salt) $ \sp -> do
let p1 = castPtr sp
p2 = castPtr sp `plusPtr` 4
allocaArray 3 $ \st -> do
let step :: LB.ByteString -> Int -> IO Int
step (LB.Chunk x xs) off = do
unread <- unsafeAdjustCStringLen x off $ \ptr len ->
c_step ptr (fromIntegral len) st
if unread > 0
then frag xs unread
else step xs 0
step _ _ = return 0
frag :: LB.ByteString -> CSize -> IO Int
frag c@(LB.Chunk x xs) stoff = do
nstoff <- unsafeUseAsCStringLen x $ \ptr len -> do
c_frag ptr (fromIntegral len) st stoff
if nstoff == 12
then step c (fromIntegral (nstoff stoff))
else frag xs nstoff
frag LB.Empty stoff = return (fromIntegral (12 stoff))
c_begin p1 p2 st
unread <- step s 0
c_end (fromIntegral unread) p1 p2 st
peek sp