diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,12 @@ +Version 1.1.0.0 + +* Added instance for: strict and lazy Texts, ThreadId +* Added hashPtrWithSalt and hashByteArrayWithSalt. +* Faster ByteArray# hashing. +* Fixed a signedness bug that affected ByteString. +* Fix ByteString hashing to work correctly on both 32 and 64-bit + platforms. + Version 1.0.1.1 * Fixed bug in Hashable instance for lazy ByteStrings where diff --git a/Data/Hashable.hs b/Data/Hashable.hs --- a/Data/Hashable.hs +++ b/Data/Hashable.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash #-} +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, + UnliftedFFITypes #-} ------------------------------------------------------------------------ -- | -- Module : Data.Hash -- Copyright : (c) Milan Straka 2010 -- (c) Johan Tibell 2011 +-- (c) Bryan O'Sullivan 2011 -- License : BSD-style -- Maintainer : fox@ucw.cz -- Stability : provisional @@ -27,8 +29,10 @@ -- * Creating new instances -- $blocks , hashPtr + , hashPtrWithSalt #if defined(__GLASGOW_HASKELL__) , hashByteArray + , hashByteArrayWithSalt #endif , combine ) where @@ -42,12 +46,20 @@ import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BL -import Foreign.C (CInt, CString) +import qualified Data.Text as T +import qualified Data.Text.Array as TA +import qualified Data.Text.Internal as T +import qualified Data.Text.Lazy as LT +import Foreign.C (CLong, CString) import Foreign.Ptr (Ptr, castPtr) #if defined(__GLASGOW_HASKELL__) -import GHC.Base (ByteArray#, Int(..), indexWord8Array#) -import GHC.Word (Word8(..)) +import Foreign.C.Types (CInt) +import GHC.Base (ByteArray#) +import GHC.Conc (ThreadId(..)) +import GHC.Prim (ThreadId#) +#else +import Control.Concurrent (ThreadId) #endif ------------------------------------------------------------------------ @@ -143,6 +155,21 @@ {-# SPECIALIZE instance Hashable [Char] #-} hash = foldl' hashAndCombine 0 +-- | Compute the hash of a ThreadId. For GHC, we happen to know a +-- trick to make this fast. +hashThreadId :: ThreadId -> Int +{-# INLINE hashThreadId #-} +#if defined(__GLASGOW_HASKELL__) +hashThreadId (ThreadId t) = hash (fromIntegral (getThreadId t) :: Int) +foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt +#else +hashThreadId = hash . show +#endif + +instance Hashable ThreadId where + hash = hashThreadId + {-# INLINE hash #-} + hashAndCombine :: Hashable h => Int -> h -> Int hashAndCombine acc h = acc `combine` hash h @@ -166,6 +193,24 @@ instance Hashable BL.ByteString where hash = BL.foldlChunks hashByteStringWithSalt 0 +instance Hashable T.Text where + hash (T.Text arr off len) = hashByteArray (TA.aBA arr) + (off `shiftL` 1) (len `shiftL` 1) + +-- The arguments to this function are flipped to make the function +-- easier to use with a left fold. + +-- | Compute a hash value for this 'B.Text', using an initial +-- salt. +hashTextWithSalt :: Int -- ^ salt + -> T.Text -- ^ data to hash + -> Int -- ^ hash value +hashTextWithSalt salt (T.Text arr off len) = + hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1) salt + +instance Hashable LT.Text where + hash = LT.foldlChunks hashTextWithSalt 0 + ------------------------------------------------------------------------ -- * Creating new instances @@ -221,6 +266,8 @@ fromIntegral `fmap` hashCString (castPtr p) (fromIntegral len) (fromIntegral salt) +foreign import ccall unsafe "djb_hash" hashCString + :: CString -> CLong -> CLong -> IO CLong #if defined(__GLASGOW_HASKELL__) -- | Compute a hash value for the content of this 'ByteArray#', @@ -230,31 +277,32 @@ -> Int -- ^ offset, in bytes -> Int -- ^ length, in bytes -> Int -- ^ hash value -hashByteArray ba0 off len = go ba0 off len 0 - where - -- Bernstein's hash - go :: ByteArray# -> Int -> Int -> Int -> Int - go !ba !i !n !h - | i < n = let h' = (h + h `shiftL` 5) `xor` - (fromIntegral $ unsafeIndexWord8 ba i) - in go ba (i + 1) n h' - | otherwise = h +hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len 0 +{-# INLINE hashByteArray #-} --- | Unchecked read of an immutable array. May return garbage or --- crash on an out-of-bounds access. -unsafeIndexWord8 :: ByteArray# -> Int -> Word8 -unsafeIndexWord8 ba (I# i#) = - case indexWord8Array# ba i# of r# -> (W8# r#) -{-# INLINE unsafeIndexWord8 #-} +-- | Compute a hash value for the content of this 'ByteArray#', using +-- an initial salt. +-- +-- This function can for example be used to hash non-contiguous +-- segments of memory as if they were one contiguous segment, by using +-- the output of one hash as the salt for the next. +-- +-- Availability: GHC. +hashByteArrayWithSalt + :: ByteArray# -- ^ data to hash + -> Int -- ^ offset, in bytes + -> Int -- ^ length, in bytes + -> Int -- ^ salt + -> Int -- ^ hash value +hashByteArrayWithSalt ba !off !len !h0 = + fromIntegral $ c_hashByteArray ba (fromIntegral off) (fromIntegral len) + (fromIntegral h0) + +foreign import ccall unsafe "djb_hash_offset" c_hashByteArray + :: ByteArray# -> CLong -> CLong -> CLong -> CLong #endif -- | Combine two given hash values. 'combine' has zero as a left -- identity. combine :: Int -> Int -> Int combine h1 h2 = (h1 + h1 `shiftL` 5) `xor` h2 - ------------------------------------------------------------------------- --- * Foreign imports - -foreign import ccall unsafe "djb_hash" hashCString - :: CString -> CInt -> CInt -> IO CInt diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -53,7 +53,7 @@ data ByteArray = BA { unBA :: !ByteArray# } new :: Int -> ByteArray# -new (I# n#) = unBA $ runST $ ST $ \s1 -> +new (I# n#) = unBA (runST $ ST $ \s1 -> case newByteArray# n# s1 of (# s2, ary #) -> case unsafeFreezeByteArray# ary s2 of - (# s3, ba #) -> (# s3, BA ba #) + (# s3, ba #) -> (# s3, BA ba #)) diff --git a/cbits/hashByteString.c b/cbits/hashByteString.c --- a/cbits/hashByteString.c +++ b/cbits/hashByteString.c @@ -1,9 +1,16 @@ /* Bernstein's hash */ -int djb_hash(const char* str, int len, int hash) { +long djb_hash(const unsigned char* str, long len, long hash) { while (len--) { hash = (hash * 33) ^ *str++; } return hash; +} + +/* Used for ByteArray#s. We can't treat them like pointers in + native Haskell, but we can in unsafe FFI calls. + */ +long djb_hash_offset(const unsigned char* str, long offset, long len, long hash) { + return djb_hash(str + offset, len, hash); } diff --git a/hashable.cabal b/hashable.cabal --- a/hashable.cabal +++ b/hashable.cabal @@ -1,5 +1,5 @@ Name: hashable -Version: 1.0.1.1 +Version: 1.1.0.0 Synopsis: A class for types that can be converted to a hash value Description: This package defines a class, 'Hashable', for types that can be converted to a hash value. This class @@ -9,13 +9,14 @@ Homepage: http://github.com/tibbe/hashable License: BSD3 License-file: LICENSE -Author: Milan Straka -Maintainer: Milan Straka +Author: Milan Straka Johan Tibell +Maintainer: johan.tibell@gmail.com +bug-reports: https://github.com/tibbe/hashable/issues Stability: Provisional Category: Data Build-type: Simple -Cabal-version: >=1.10 +Cabal-version: >=1.8 -- tests/Properties.hs shouldn't have to go here, but the source files -- for the test-suite stanzas don't get picked up by `cabal sdist`. Extra-source-files: @@ -23,27 +24,31 @@ benchmarks/Makefile Library - Default-language: Haskell98 Exposed-modules: Data.Hashable Build-depends: base >= 4.0 && < 5, - bytestring >= 0.9 && < 1.0 + bytestring >= 0.9 && < 1.0, + ghc-prim < 0.3, + text >= 0.11.0.5 && < 0.12 C-sources: cbits/hashByteString.c Ghc-options: -Wall if impl(ghc >= 6.8) Ghc-options: -fwarn-tabs -Test-suite tests - Default-language: Haskell98 - Type: exitcode-stdio-1.0 - Hs-source-dirs: tests - Main-is: Properties.hs - Build-depends: base >= 4.0 && < 5, - hashable, - QuickCheck == 1.2.*, - random == 1.0.* +-- -- Commented out until cabal-install release. +-- Test-suite tests +-- Type: exitcode-stdio-1.0 +-- Hs-source-dirs: tests +-- Main-is: Properties.hs +-- Build-depends: base >= 4.0 && < 5, +-- hashable, +-- test-framework >= 0.3.3 && < 0.4, +-- test-framework-quickcheck2 >= 0.2.9 && < 0.3, +-- QuickCheck >= 2.4.0.1, +-- random == 1.0.*, +-- text >= 0.11.0.5 - Ghc-options: -Wall +-- Ghc-options: -Wall source-repository head type: git diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,36 +1,32 @@ -{-# LANGUAGE BangPatterns, MagicHash, Rank2Types, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash, Rank2Types, + UnboxedTuples #-} -- | Tests for the 'Data.Hashable' module. We test functions by -- comparing the C and Haskell implementations. module Main (main) where -import Data.Hashable (hashByteArray, hashPtr) +import Data.Hashable (hash, hashByteArray, hashPtr) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L import Foreign (unsafePerformIO) import Foreign.Marshal.Array (withArray) import GHC.Base (ByteArray#, Int(..), newByteArray#, unsafeCoerce#, writeWord8Array#) import GHC.ST (ST(..), runST) import GHC.Word (Word8(..)) -import System.Random import Test.QuickCheck -import Test.QuickCheck.Batch +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) ------------------------------------------------------------------------ -- * Properties -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g') -> (fromIntegral x, g') - -instance Random Word8 where - randomR = integralRandomR - random = randomR (minBound,maxBound) +instance Arbitrary T.Text where + arbitrary = T.pack `fmap` arbitrary -instance Arbitrary Word8 where - arbitrary = choose (97, 105) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) +instance Arbitrary L.Text where + arbitrary = L.pack `fmap` arbitrary -- | Validate the implementation by comparing the C and Haskell -- versions. @@ -39,20 +35,49 @@ (hashByteArray (fromList xs) 0 len ==) `fmap` hashPtr p len where len = length xs -tests :: [TestOptions -> IO TestResult] -tests = - [ run pHash - ] +-- | Content equality implies hash equality. +pText :: T.Text -> T.Text -> Bool +pText a b = (a == b) == (hash a == hash b) +-- | Content equality implies hash equality. +pTextLazy :: L.Text -> L.Text -> Bool +pTextLazy a b = (a == b) == (hash a == hash b) + +-- | A small positive integer. +newtype ChunkSize = ChunkSize { unCS :: Int } + deriving (Eq, Ord, Num, Integral, Real, Enum, Show) + +instance Arbitrary ChunkSize where + arbitrary = (ChunkSize . (`mod` maxChunkSize)) `fmap` + (arbitrary `suchThat` ((/=0) . (`mod` maxChunkSize))) + where maxChunkSize = 16 + +-- | Ensure that the rechunk function causes a rechunked string to +-- still match its original form. +pRechunk :: T.Text -> NonEmptyList ChunkSize -> Bool +pRechunk t cs = L.fromStrict t == rechunk t cs + +-- | Content equality implies hash equality. +pLazyRechunked :: T.Text -> NonEmptyList ChunkSize -> Bool +pLazyRechunked t cs = hash (L.fromStrict t) == hash (rechunk t cs) + +-- | Break up a string into chunks of different sizes. +rechunk :: T.Text -> NonEmptyList ChunkSize -> L.Text +rechunk t0 (NonEmpty cs0) = L.fromChunks . go t0 . cycle $ cs0 + where + go t _ | T.null t = [] + go t (c:cs) = a : go b cs + where (a,b) = T.splitAt (unCS c) t + -- This wrapper is required by 'runST'. data ByteArray = BA { unBA :: ByteArray# } -- | Create a 'ByteArray#' from a list of 'Word8' values. fromList :: [Word8] -> ByteArray# -fromList xs0 = unBA $ runST $ ST $ \ s1# -> +fromList xs0 = unBA (runST $ ST $ \ s1# -> case newByteArray# len# s1# of (# s2#, marr# #) -> case go s2# 0 marr# xs0 of - s3# -> (# s3#, BA (unsafeCoerce# marr#) #) + s3# -> (# s3#, BA (unsafeCoerce# marr#) #)) where !(I# len#) = length xs0 go s# _ _ [] = s# @@ -63,12 +88,16 @@ ------------------------------------------------------------------------ -- Test harness -options :: TestOptions -options = TestOptions - { no_of_tests = 1000 - , length_of_tests = 1 - , debug_tests = False - } - main :: IO () -main = runTests "Bernstein's hash" options tests +main = defaultMain tests + +tests :: [Test] +tests = + [ testProperty "bernstein" pHash + , testGroup "text" + [ testProperty "text/strict" pText + , testProperty "text/lazy" pTextLazy + , testProperty "rechunk" pRechunk + , testProperty "text/rechunked" pLazyRechunked + ] + ]