diff --git a/Data/Hashable.hs b/Data/Hashable.hs --- a/Data/Hashable.hs +++ b/Data/Hashable.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, - UnliftedFFITypes #-} +{-# LANGUAGE CPP #-} ------------------------------------------------------------------------ -- | --- Module : Data.Hash +-- Module : Data.Hashable -- Copyright : (c) Milan Straka 2010 -- (c) Johan Tibell 2011 --- (c) Bryan O'Sullivan 2011 +-- (c) Bryan O'Sullivan 2011, 2012 -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional @@ -15,337 +14,120 @@ -- This module defines a class, 'Hashable', for types that can be -- converted to a hash value. This class exists for the benefit of -- hashing-based data structures. The module provides instances for --- basic types and a way to combine hash values. +-- most standard types. Efficient instances for other types can be +-- generated automatically and effortlessly using the generics support +-- in GHC 7.2 and above. -- --- The 'hash' function should be as collision-free as possible, which --- means that the 'hash' function must map the inputs to the hash --- values as evenly as possible. +-- The easiest way to get started is to use the 'hash' function. Here +-- is an example session with @ghci@. +-- +-- > Prelude> import Data.Hashable +-- > Prelude> hash "foo" +-- > 60853164 module Data.Hashable ( -- * Computing hash values - Hashable(..) + hash + , Hashable(..) + -- ** Avalanche behavior + -- $avalanche + -- * Creating new instances + -- | There are two ways to create new instances: by deriving + -- instances automatically using GHC's generic programming + -- support or by writing instances manually. + + -- ** Generic instances + -- $generics + + -- *** Understanding a compiler error + -- $generic_err + + -- ** Writing instances by hand -- $blocks + , hashUsing , hashPtr , hashPtrWithSalt #if defined(__GLASGOW_HASKELL__) , hashByteArray , hashByteArrayWithSalt #endif - , combine + -- ** Hashing types with multiple constructors + -- $ctors ) where -import Control.Exception (assert) -import Data.Bits (bitSize, shiftL, shiftR, xor) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word, Word8, Word16, Word32, Word64) -import Data.List (foldl') -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString.Lazy as BL -#if !MIN_VERSION_bytestring(0,10,0) -import qualified Data.ByteString.Lazy.Internal as BL -- foldlChunks -#endif -#if defined(__GLASGOW_HASKELL__) -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 -#endif -import Foreign.C (CString) -#if __GLASGOW_HASKELL__ >= 703 -import Foreign.C (CLong(..)) -#else -import Foreign.C (CLong) -#endif -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (alignment, peek, sizeOf) -import System.IO.Unsafe (unsafePerformIO) - --- Byte arrays and Integers. -#if defined(__GLASGOW_HASKELL__) -import GHC.Base (ByteArray#) -# ifdef VERSION_integer_gmp -import GHC.Exts (Int(..)) -import GHC.Integer.GMP.Internals (Integer(..)) -# endif -#endif - --- ThreadId -#if defined(__GLASGOW_HASKELL__) -import GHC.Conc (ThreadId(..)) -import GHC.Prim (ThreadId#) -# if __GLASGOW_HASKELL__ >= 703 -import Foreign.C.Types (CInt(..)) -# else -import Foreign.C.Types (CInt) -# endif -#else -import Control.Concurrent (ThreadId) -#endif - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -import System.Mem.StableName -#endif - -import Data.Typeable -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Fingerprint.Type(Fingerprint(..)) -import Data.Typeable.Internal(TypeRep(..)) +import Data.Hashable.Class +#ifdef GENERICS +import Data.Hashable.Generic () #endif -#include "MachDeps.h" - -infixl 0 `combine`, `hashWithSalt` - ------------------------------------------------------------------------- --- * Computing hash values - --- | A default salt used in the default implementation of 'hashWithSalt'. --- It is specified by FNV-1 hash as a default salt for hashing string like --- types. -defaultSalt :: Int -defaultSalt = 2166136261 -{-# INLINE defaultSalt #-} - --- | The class of types that can be converted to a hash value. +-- $avalanche -- --- Minimal implementation: 'hash' or 'hashWithSalt'. -class Hashable a where - -- | Return a hash value for the argument. - -- - -- The general contract of 'hash' is: - -- - -- * This integer need not remain consistent from one execution - -- of an application to another execution of the same - -- application. - -- - -- * If two values are equal according to the '==' method, then - -- applying the 'hash' method on each of the two values must - -- produce the same integer result. - -- - -- * It is /not/ required that if two values are unequal - -- according to the '==' method, then applying the 'hash' - -- method on each of the two values must produce distinct - -- integer results. However, the programmer should be aware - -- that producing distinct integer results for unequal values - -- may improve the performance of hashing-based data - -- structures. - hash :: a -> Int - hash = hashWithSalt defaultSalt - - -- | Return a hash value for the argument, using the given salt. - -- - -- This method can be used to compute different hash values for - -- the same input by providing a different salt in each - -- application of the method. - -- - -- The contract for 'hashWithSalt' is the same as for 'hash', with - -- the additional requirement that any instance that defines - -- 'hashWithSalt' must make use of the salt in its implementation. - hashWithSalt :: Int -> a -> Int - hashWithSalt salt x = salt `combine` hash x - -instance Hashable () where hash _ = 0 - -instance Hashable Bool where hash x = case x of { True -> 1; False -> 0 } - -instance Hashable Int where hash = id -instance Hashable Int8 where hash = fromIntegral -instance Hashable Int16 where hash = fromIntegral -instance Hashable Int32 where hash = fromIntegral -instance Hashable Int64 where - hash n - | bitSize (undefined :: Int) == 64 = fromIntegral n - | otherwise = fromIntegral (fromIntegral n `xor` - (fromIntegral n `shiftR` 32 :: Word64)) - -instance Hashable Word where hash = fromIntegral -instance Hashable Word8 where hash = fromIntegral -instance Hashable Word16 where hash = fromIntegral -instance Hashable Word32 where hash = fromIntegral -instance Hashable Word64 where - hash n - | bitSize (undefined :: Int) == 64 = fromIntegral n - | otherwise = fromIntegral (n `xor` (n `shiftR` 32)) - -instance Hashable Integer where -#if defined(__GLASGOW_HASKELL__) && defined(VERSION_integer_gmp) - hash (S# int) = I# int - hash n@(J# size byteArray) | n >= fromIntegral (minBound :: Int) && n <= fromIntegral (maxBound :: Int) = fromInteger n - | otherwise = hashByteArrayWithSalt byteArray 0 (SIZEOF_HSWORD * (I# size)) 0 - - hashWithSalt salt (S# int) = salt `combine` I# int - hashWithSalt salt n@(J# size byteArray) | n >= fromIntegral (minBound :: Int) && n <= fromIntegral (maxBound :: Int) = salt `combine` fromInteger n - | otherwise = hashByteArrayWithSalt byteArray 0 (SIZEOF_HSWORD * (I# size)) salt -#else - hashWithSalt salt = foldl' hashWithSalt salt . go - where - go n | inBounds n = [fromIntegral n :: Int] - | otherwise = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS) - maxInt = fromIntegral (maxBound :: Int) - inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt -#endif - -instance (Integral a, Hashable a) => Hashable (Ratio a) where - {-# SPECIALIZE instance Hashable (Ratio Integer) #-} - hash a = hash (numerator a) `hashWithSalt` denominator a - hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a - -instance Hashable Float where - hash x - | isIEEE x = - assert (sizeOf x >= sizeOf (0::Word32) && - alignment x >= alignment (0::Word32)) $ - hash ((unsafePerformIO $ with x $ peek . castPtr) :: Word32) - | otherwise = hash (show x) - -instance Hashable Double where - hash x - | isIEEE x = - assert (sizeOf x >= sizeOf (0::Word64) && - alignment x >= alignment (0::Word64)) $ - hash ((unsafePerformIO $ with x $ peek . castPtr) :: Word64) - | otherwise = hash (show x) - -instance Hashable Char where hash = fromEnum - --- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int. --- It is used as data constructor distinguisher. GHC computes its value during --- compilation. -distinguisher :: Int -distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3 -{-# INLINE distinguisher #-} - -instance Hashable a => Hashable (Maybe a) where - hash Nothing = 0 - hash (Just a) = distinguisher `hashWithSalt` a - hashWithSalt s Nothing = s `combine` 0 - hashWithSalt s (Just a) = s `combine` distinguisher `hashWithSalt` a - -instance (Hashable a, Hashable b) => Hashable (Either a b) where - hash (Left a) = 0 `hashWithSalt` a - hash (Right b) = distinguisher `hashWithSalt` b - hashWithSalt s (Left a) = s `combine` 0 `hashWithSalt` a - hashWithSalt s (Right b) = s `combine` distinguisher `hashWithSalt` b - -instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where - hash (a1, a2) = hash a1 `hashWithSalt` a2 - hashWithSalt s (a1, a2) = s `hashWithSalt` a1 `hashWithSalt` a2 - -instance (Hashable a1, Hashable a2, Hashable a3) => Hashable (a1, a2, a3) where - hash (a1, a2, a3) = hash a1 `hashWithSalt` a2 `hashWithSalt` a3 - hashWithSalt s (a1, a2, a3) = s `hashWithSalt` a1 `hashWithSalt` a2 - `hashWithSalt` a3 - -instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4) => - Hashable (a1, a2, a3, a4) where - hash (a1, a2, a3, a4) = hash a1 `hashWithSalt` a2 - `hashWithSalt` a3 `hashWithSalt` a4 - hashWithSalt s (a1, a2, a3, a4) = s `hashWithSalt` a1 `hashWithSalt` a2 - `hashWithSalt` a3 `hashWithSalt` a4 - -instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5) - => Hashable (a1, a2, a3, a4, a5) where - hash (a1, a2, a3, a4, a5) = - hash a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 - hashWithSalt s (a1, a2, a3, a4, a5) = - s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 - -instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, - Hashable a6) => Hashable (a1, a2, a3, a4, a5, a6) where - hash (a1, a2, a3, a4, a5, a6) = - hash a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 - hashWithSalt s (a1, a2, a3, a4, a5, a6) = - s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 - -instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, - Hashable a6, Hashable a7) => - Hashable (a1, a2, a3, a4, a5, a6, a7) where - hash (a1, a2, a3, a4, a5, a6, a7) = - hash a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 - hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) = - s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -instance Hashable (StableName a) where - hash = hashStableName -#endif - -instance Hashable a => Hashable [a] where - {-# SPECIALIZE instance Hashable [Char] #-} - hashWithSalt = foldl' hashWithSalt - -instance Hashable B.ByteString where - hashWithSalt salt bs = B.inlinePerformIO $ - B.unsafeUseAsCStringLen bs $ \(p, len) -> - hashPtrWithSalt p (fromIntegral len) salt - -instance Hashable BL.ByteString where - hashWithSalt salt = BL.foldlChunks hashWithSalt salt - -#if defined(__GLASGOW_HASKELL__) -instance Hashable T.Text where - hashWithSalt salt (T.Text arr off len) = - hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1) - salt - -instance Hashable LT.Text where - hashWithSalt salt = LT.foldlChunks hashWithSalt salt -#endif - - --- | 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 #-} - - --- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly. -hashTypeRep :: TypeRep -> Int -{-# INLINE hashTypeRep #-} -#if __GLASGOW_HASKELL__ >= 702 --- Fingerprint is just the MD5, so taking any Int from it is fine -hashTypeRep (TypeRep (Fingerprint x _) _ _) = fromIntegral x -#elif __GLASGOW_HASKELL__ >= 606 -hashTypeRep = B.inlinePerformIO . typeRepKey -#else -hashTypeRep = hash . show -#endif - -instance Hashable TypeRep where - hash = hashTypeRep - {-# INLINE hash #-} +-- A good hash function has a 50% probability of flipping every bit of +-- its result in response to a change of just one bit in its +-- input. This property is called /avalanche/. To be truly general +-- purpose, hash functions must have strong avalanche behavior. +-- +-- All of the 'Hashable' instances provided by this module have +-- excellent avalanche properties. +-- $generics +-- +-- Beginning with GHC 7.2, the recommended way to make instances of +-- 'Hashable' for most types is to use the compiler's support for +-- automatically generating default instances. +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import GHC.Generics (Generic) +-- > import Data.Hashable +-- > +-- > data Foo a = Foo a String +-- > deriving (Eq, Generic) +-- > +-- > instance Hashable a => Hashable (Foo a) +-- > +-- > data Colour = Red | Green | Blue +-- > deriving Generic +-- > +-- > instance Hashable Colour +-- +-- If you omit a body for the instance declaration, GHC will generate +-- a default instance that correctly and efficiently hashes every +-- constructor and parameter. ------------------------------------------------------------------------- --- * Creating new instances +-- $generic_err +-- +-- Suppose you intend to use the generic machinery to automatically +-- generate a 'Hashable' instance. +-- +-- > data Oops = Oops +-- > -- forgot to add "deriving Generic" here! +-- > +-- > instance Hashable Oops +-- +-- And imagine that, as in the example above, you forget to add a +-- \"@deriving 'Generic'@\" clause to your data type. At compile time, +-- you will get an error message from GHC that begins roughly as +-- follows: +-- +-- > No instance for (GHashable (Rep Oops)) +-- +-- This error can be confusing, as 'GHashable' is not exported (it is +-- an internal typeclass used by this library's generics machinery). +-- The correct fix is simply to add the missing \"@deriving +-- 'Generic'@\". -- $blocks -- +-- To maintain high quality hashes, new 'Hashable' instances should be +-- built using existing 'Hashable' instances, combinators, and hash +-- functions. +-- -- The functions below can be used when creating new instances of --- 'Hashable'. For example, for many string-like types the +-- 'Hashable'. For many string-like types the -- 'hashWithSalt' method can be defined in terms of either -- 'hashPtrWithSalt' or 'hashByteArrayWithSalt'. Here's how you could -- implement an instance for the 'B.ByteString' data type, from the @@ -362,83 +144,78 @@ -- > B.unsafeUseAsCStringLen bs $ \(p, len) -> -- > hashPtrWithSalt p (fromIntegral len) salt -- --- Use 'hashWithSalt' to create a hash value from several values, --- using this recipe: +-- Use 'hashWithSalt' to compute a hash from several values, using +-- this recipe: -- --- > instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where --- > hash (a1, a2) = hash a1 `hashWithSalt` a2 +-- > data Product a b = P a b +-- > +-- > instance (Hashable a, Hashable b) => Hashable (Product a b) where +-- > hashWithSalt s (P a b) = s `hashWithSalt` a `hashWithSalt` b -- --- You can combine multiple hash values using 'combine', using this --- recipe: +-- You can chain hashes together using 'hashWithSalt', by following +-- this recipe: -- --- > combineTwo h1 h2 = 17 `combine` h1 `combine` h2 +-- > combineTwo h1 h2 = h1 `hashWithSalt` h2 + +-- $ctors -- --- As zero is a left identity of 'combine', a nonzero "seed" is used --- so that the number of combined hash values affects the final --- result, even if the first hash values are zero. The value 17 is --- arbitrary. +-- For a type with several value constructors, there are a few +-- possible approaches to writing a 'Hashable' instance. -- --- When possible, use 'hashWithSalt' to compute a hash value from --- multiple values instead of computing separate hashes for each value --- and then combining them using 'combine'. - --- | Compute a hash value for the content of this pointer. -hashPtr :: Ptr a -- ^ pointer to the data to hash - -> Int -- ^ length, in bytes - -> IO Int -- ^ hash value -hashPtr p len = hashPtrWithSalt p len defaultSalt - --- | Compute a hash value for the content of this pointer, using an --- initial salt. +-- If the type is an instance of 'Enum', the easiest (and safest) path +-- is to convert it to an 'Int', and use the existing 'Hashable' +-- instance for 'Int'. -- --- 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. -hashPtrWithSalt :: Ptr a -- ^ pointer to the data to hash - -> Int -- ^ length, in bytes - -> Int -- ^ salt - -> IO Int -- ^ hash value -hashPtrWithSalt p len salt = - fromIntegral `fmap` c_hashCString (castPtr p) (fromIntegral len) - (fromIntegral salt) - -foreign import ccall unsafe "hashable_fnv_hash" c_hashCString - :: CString -> CLong -> CLong -> IO CLong - -#if defined(__GLASGOW_HASKELL__) --- | Compute a hash value for the content of this 'ByteArray#', --- beginning at the specified offset, using specified number of bytes. --- Availability: GHC. -hashByteArray :: ByteArray# -- ^ data to hash - -> Int -- ^ offset, in bytes - -> Int -- ^ length, in bytes - -> Int -- ^ hash value -hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt -{-# INLINE hashByteArray #-} - --- | Compute a hash value for the content of this 'ByteArray#', using --- an initial salt. +-- > data Color = Red | Green | Blue +-- > deriving Enum +-- > +-- > instance Hashable Color where +-- > hashWithSalt = hashUsing fromEnum -- --- 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. +-- This instance benefits from the fact that the 'Hashable' instance +-- for 'Int' has excellent avalanche properties. -- --- 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 "hashable_fnv_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 * 16777619) `xor` h2 +-- In contrast, a very weak hash function would be: +-- +-- > terribleHash :: Color -> Int +-- > terribleHash salt = fromEnum +-- +-- This has terrible avalanche properties, as the salt is ignored, and +-- every input is mapped to a small integer. +-- +-- If the type's constructors accept parameters, it can be important +-- to distinguish the constructors. +-- +-- > data Time = Days Int +-- > | Weeks Int +-- > | Months Int +-- +-- The weak hash function below guarantees a high probability of days, +-- weeks, and months all colliding when hashed. +-- +-- > veryBadHash :: Time -> Int +-- > veryBadHash (Days d) = hash d +-- > veryBadHash (Weeks w) = hash w +-- > veryBadHash (Months m) = hash m +-- +-- It is easy to distinguish the constructors using the `hashWithSalt` +-- function. +-- +-- > instance Hashable Time where +-- > hashWithSalt s (Days n) = s `hashWithSalt` +-- > (0::Int) `hashWithSalt` n +-- > hashWithSalt s (Weeks n) = s `hashWithSalt` +-- > (1::Int) `hashWithSalt` n +-- > hashWithSalt s (Months n) = s `hashWithSalt` +-- > (2::Int) `hashWithSalt` n +-- +-- If a constructor accepts multiple parameters, their hashes can be +-- chained. +-- +-- > data Date = Date Int Int Int +-- > +-- > instance Hashable Date where +-- > hashWithSalt s (Date yr mo dy) = +-- > s `hashWithSalt` +-- > yr `hashWithSalt` +-- > mo `hashWithSalt` dy diff --git a/Data/Hashable/Class.hs b/Data/Hashable/Class.hs new file mode 100644 --- /dev/null +++ b/Data/Hashable/Class.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, + ScopedTypeVariables, UnliftedFFITypes #-} +#ifdef GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts #-} +#endif + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable.Class +-- Copyright : (c) Milan Straka 2010 +-- (c) Johan Tibell 2011 +-- (c) Bryan O'Sullivan 2011, 2012 +-- License : BSD-style +-- Maintainer : johan.tibell@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- This module defines a class, 'Hashable', for types that can be +-- converted to a hash value. This class exists for the benefit of +-- hashing-based data structures. The module provides instances for +-- most standard types. + +module Data.Hashable.Class + ( + -- * Computing hash values + Hashable(..) +#ifdef GENERICS + -- ** Support for generics + , GHashable(..) +#endif + , hash + + -- * Creating new instances + , hashUsing + , hashPtr + , hashPtrWithSalt +#if defined(__GLASGOW_HASKELL__) + , hashByteArray + , hashByteArrayWithSalt +#endif + ) where + +import Control.Exception (assert) +import Data.Bits (shiftL, xor) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.List (foldl') +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL +#if defined(__GLASGOW_HASKELL__) +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 TL +import qualified Data.Text.Lazy.Internal as TL +# ifdef GENERICS +import GHC.Generics +# endif +#endif +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C (CSize(..)) +#else +import Foreign.C (CSize) +#endif +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (alignment, peek, sizeOf) +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Marshal.Array (advancePtr, allocaArray) + +-- Byte arrays and Integers. +#if defined(__GLASGOW_HASKELL__) +import GHC.Base (ByteArray#) +# ifdef VERSION_integer_gmp +import GHC.Exts (Int(..)) +import GHC.Integer.GMP.Internals (Integer(..)) +# else +import Data.Bits (shiftR) +# endif +#endif + +-- ThreadId +#if defined(__GLASGOW_HASKELL__) +import GHC.Conc (ThreadId(..)) +import GHC.Prim (ThreadId#) +# if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CInt(..)) +# else +import Foreign.C.Types (CInt) +# endif +#else +import Control.Concurrent (ThreadId) +#endif + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +import System.Mem.StableName +#endif + +import Data.Typeable +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Fingerprint.Type(Fingerprint(..)) +import Data.Typeable.Internal(TypeRep(..)) +#endif + +#ifndef FIXED_SALT +import Data.Hashable.RandomSource (getRandomBytes_) +import Foreign.Marshal.Alloc (alloca) +#endif + +#include "MachDeps.h" + +infixl 0 `hashWithSalt` + +------------------------------------------------------------------------ +-- * Computing hash values + +-- | A default salt used in the implementation of 'hash'. +-- +-- To reduce the probability of hash collisions, the value of the +-- default salt will vary from one program invocation to the next +-- unless this package is compiled with the @fixed-salt@ flag set. +defaultSalt :: Int + +#ifdef FIXED_SALT + +defaultSalt = 0xdc36d1615b7400a4 +{-# INLINE defaultSalt #-} + +#else + +defaultSalt = unsafePerformIO . alloca $ \p -> do + getRandomBytes_ "defaultSalt" p (sizeOf (undefined :: Int)) + peek p +{-# NOINLINE defaultSalt #-} + +#endif + +-- | The class of types that can be converted to a hash value. +class Hashable a where + -- | Return a hash value for the argument, using the given salt. + -- + -- The general contract of 'hashWithSalt' is: + -- + -- * If a value is hashed using the same salt during distinct + -- runs of an application, the result must remain the + -- same. (This is necessary to make it possible to store hashes + -- on persistent media.) + -- + -- * If two values are equal according to the '==' method, then + -- applying the 'hashWithSalt' method on each of the two values + -- /must/ produce the same integer result if the same salt is + -- used in each case. + -- + -- * It is /not/ required that if two values are unequal + -- according to the '==' method, then applying the + -- 'hashWithSalt' method on each of the two values must produce + -- distinct integer results. (Every programmer will be aware + -- that producing distinct integer results for unequal values + -- will improve the performance of hashing-based data + -- structures.) + -- + -- This method can be used to compute different hash values for + -- the same input by providing a different salt in each + -- application of the method. This implies that any instance that + -- defines 'hashWithSalt' /must/ make use of the salt in its + -- implementation. + hashWithSalt :: Int -> a -> Int + +#ifdef GENERICS + default hashWithSalt :: (Generic a, GHashable (Rep a)) => Int -> a -> Int + hashWithSalt salt = ghashWithSalt salt . from + +-- | The class of types that can be generically hashed. +class GHashable f where + ghashWithSalt :: Int -> f a -> Int +#endif + +-- | Return a hash value for the argument. Defined in terms of +-- 'hashWithSalt' and a default salt. +-- +-- At application startup time, the default salt is initialized with a +-- new value from the system's cryptographic pseudo-random number +-- generator. This means that the result of 'hash' will vary from one +-- application run to the next. +-- +-- If you need hashes that do not vary from run to run, use +-- 'hashWithSalt' instead, and supply a salt of your choosing. (Be +-- aware that if you hash untrusted, uncontrolled input data using a +-- fixed salt, you may expose your application to hash collision +-- attacks.) +hash :: Hashable a => a -> Int +hash = hashWithSalt defaultSalt + +-- | Transform a value into a 'Hashable' value, then hash the +-- transformed value using the given salt. +-- +-- This is a useful shorthand in cases where a type can easily be +-- mapped to another type that is already an instance of 'Hashable'. +-- Example: +-- +-- > data Foo = Foo | Bar +-- > deriving (Enum) +-- > +-- > instance Hashable Foo where +-- > hashWithSalt = hashUsing fromEnum +hashUsing :: (Hashable b) => + (a -> b) -- ^ Transformation function. + -> Int -- ^ Salt. + -> a -- ^ Value to transform. + -> Int +hashUsing f salt x = hashWithSalt salt (f x) +{-# INLINE hashUsing #-} + +instance Hashable Int where hashWithSalt = hashNative +instance Hashable Int8 where hashWithSalt = hashNative +instance Hashable Int16 where hashWithSalt = hashNative +instance Hashable Int32 where hashWithSalt = hashNative +instance Hashable Int64 where hashWithSalt = hash64 + +instance Hashable Word where hashWithSalt = hashNative +instance Hashable Word8 where hashWithSalt = hashNative +instance Hashable Word16 where hashWithSalt = hashNative +instance Hashable Word32 where hashWithSalt = hashNative +instance Hashable Word64 where hashWithSalt = hash64 + +instance Hashable () where hashWithSalt = hashUsing fromEnum +instance Hashable Bool where hashWithSalt = hashUsing fromEnum +instance Hashable Ordering where hashWithSalt = hashUsing fromEnum +instance Hashable Char where hashWithSalt = hashUsing fromEnum + +-- | Hash an integer of at most the native width supported by the +-- machine. +hashNative :: (Integral a) => Int -> a -> Int +hashNative salt = fromIntegral . go . xor (fromIntegral salt) . fromIntegral + where +#if WORD_SIZE_IN_BITS == 32 + go = c_wang32 +#else + go = c_wang64 +#endif + +-- | Hash a 64-bit integer. +hash64 :: (Integral a) => Int -> a -> Int +hash64 salt = fromIntegral . c_wang64 . xor (fromIntegral salt) . fromIntegral + +instance Hashable Integer where +#if defined(__GLASGOW_HASKELL__) && defined(VERSION_integer_gmp) + hashWithSalt salt (S# int) = hashWithSalt salt (I# int) + hashWithSalt salt n@(J# size byteArray) + | n >= minInt && n <= maxInt = hashWithSalt salt (fromInteger n :: Int) + | otherwise = let numBytes = SIZEOF_HSWORD * (I# size) + in hashByteArrayWithSalt byteArray 0 numBytes salt + where minInt = fromIntegral (minBound :: Int) + maxInt = fromIntegral (maxBound :: Int) +#else + hashWithSalt salt = foldl' hashWithSalt salt . go + where + go n | inBounds n = [fromIntegral n :: Int] + | otherwise = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS) + maxInt = fromIntegral (maxBound :: Int) + inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt +#endif + +instance (Integral a, Hashable a) => Hashable (Ratio a) where + {-# SPECIALIZE instance Hashable (Ratio Integer) #-} + hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a + +instance Hashable Float where + hashWithSalt salt x + | isIEEE x = + assert (sizeOf x >= sizeOf (0::Word32) && + alignment x >= alignment (0::Word32)) $ + hashWithSalt salt + ((unsafePerformIO $ with x $ peek . castPtr) :: Word32) + | otherwise = hashWithSalt salt (show x) + +instance Hashable Double where + hashWithSalt salt x + | isIEEE x = + assert (sizeOf x >= sizeOf (0::Word64) && + alignment x >= alignment (0::Word64)) $ + hashWithSalt salt + ((unsafePerformIO $ with x $ peek . castPtr) :: Word64) + | otherwise = hashWithSalt salt (show x) + +-- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int. +-- It is used as data constructor distinguisher. GHC computes its value during +-- compilation. +distinguisher :: Int +distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3 +{-# INLINE distinguisher #-} + +instance Hashable a => Hashable (Maybe a) where + hashWithSalt s Nothing = hashWithSalt s (0::Int) + hashWithSalt s (Just a) = hashWithSalt s a `hashWithSalt` distinguisher + +instance (Hashable a, Hashable b) => Hashable (Either a b) where + hashWithSalt s (Left a) = hashWithSalt s a + hashWithSalt s (Right b) = hashWithSalt s b `hashWithSalt` distinguisher + +instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where + hashWithSalt s (a1, a2) = s `hashWithSalt` a1 `hashWithSalt` a2 + +instance (Hashable a1, Hashable a2, Hashable a3) => Hashable (a1, a2, a3) where + hashWithSalt s (a1, a2, a3) = s `hashWithSalt` a1 `hashWithSalt` a2 + `hashWithSalt` a3 + +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4) => + Hashable (a1, a2, a3, a4) where + hashWithSalt s (a1, a2, a3, a4) = s `hashWithSalt` a1 `hashWithSalt` a2 + `hashWithSalt` a3 `hashWithSalt` a4 + +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5) + => Hashable (a1, a2, a3, a4, a5) where + hashWithSalt s (a1, a2, a3, a4, a5) = + s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 + `hashWithSalt` a4 `hashWithSalt` a5 + +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, + Hashable a6) => Hashable (a1, a2, a3, a4, a5, a6) where + hashWithSalt s (a1, a2, a3, a4, a5, a6) = + s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 + `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 + +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, + Hashable a6, Hashable a7) => + Hashable (a1, a2, a3, a4, a5, a6, a7) where + hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) = + s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 + `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +instance Hashable (StableName a) where + hashWithSalt = hashUsing hashStableName +#endif + +instance Hashable a => Hashable [a] where + hashWithSalt = foldl' hashWithSalt + +{-# RULES "hashWithSalt/String" + forall s v. hashWithSalt s (v::[Char]) = hashWithSalt s (T.pack v) #-} + +{-# RULES "hash/String" + forall v. hash (v::[Char]) = hash (T.pack v) #-} + +instance Hashable B.ByteString where + hashWithSalt salt bs = B.inlinePerformIO $ + B.unsafeUseAsCStringLen bs $ \(p, len) -> + hashPtrWithSalt p (fromIntegral len) salt + +instance Hashable BL.ByteString where + hashWithSalt = hashLazyByteStringWithSalt + +#if defined(__GLASGOW_HASKELL__) +instance Hashable T.Text where + hashWithSalt salt (T.Text arr off len) = + hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1) + salt + +instance Hashable TL.Text where + hashWithSalt = hashLazyTextWithSalt +#endif + + +-- | 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 + hashWithSalt = hashUsing hashThreadId + {-# INLINE hashWithSalt #-} + + +-- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly. +hashTypeRep :: Int -> TypeRep -> Int +{-# INLINE hashTypeRep #-} +#if __GLASGOW_HASKELL__ >= 702 +-- Fingerprint is just the MD5, so taking any Int from it is fine +hashTypeRep salt (TypeRep (Fingerprint x _) _ _) = hashWithSalt salt x +#elif __GLASGOW_HASKELL__ >= 606 +hashTypeRep = hashUsing (B.inlinePerformIO . typeRepKey) +#else +hashTypeRep = hashUsing show +#endif + +instance Hashable TypeRep where + hashWithSalt = hashTypeRep + {-# INLINE hashWithSalt #-} + +-- | Compute a hash value for the content of this pointer. +hashPtr :: Ptr a -- ^ pointer to the data to hash + -> Int -- ^ length, in bytes + -> IO Int -- ^ hash value +hashPtr p len = hashPtrWithSalt p len defaultSalt + +-- | Compute a hash value for the content of this pointer, 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. +hashPtrWithSalt :: Ptr a -- ^ pointer to the data to hash + -> Int -- ^ length, in bytes + -> Int -- ^ salt + -> IO Int -- ^ hash value +hashPtrWithSalt p len salt = + fromIntegral `fmap` c_siphash24 k0 (fromSalt salt) (castPtr p) + (fromIntegral len) + +k0 :: Word64 +k0 = 0x56e2b8a0aee1721a +{-# INLINE k0 #-} + +hashLazyByteStringWithSalt :: Int -> BL.ByteString -> Int +hashLazyByteStringWithSalt salt cs0 = unsafePerformIO . allocaArray 5 $ \v -> do + c_siphash_init k0 (fromSalt salt) v + let go !buffered !totallen (BL.Chunk c cs) = + B.unsafeUseAsCStringLen c $ \(ptr, len) -> do + let len' = fromIntegral len + buffered' <- c_siphash24_chunk buffered v (castPtr ptr) len' (-1) + go buffered' (totallen + len') cs + go buffered totallen _ = do + _ <- c_siphash24_chunk buffered v nullPtr 0 totallen + fromIntegral `fmap` peek (v `advancePtr` 4) + go 0 0 cs0 + +#if defined(__GLASGOW_HASKELL__) +hashLazyTextWithSalt :: Int -> TL.Text -> Int +hashLazyTextWithSalt salt cs0 = unsafePerformIO . allocaArray 5 $ \v -> do + c_siphash_init k0 (fromSalt salt) v + let go !buffered !totallen (TL.Chunk (T.Text arr off len) cs) = do + let len' = fromIntegral (len `shiftL` 1) + buffered' <- c_siphash24_chunk_offset buffered v (TA.aBA arr) + (fromIntegral (off `shiftL` 1)) len' (-1) + go buffered' (totallen + len') cs + go buffered totallen _ = do + _ <- c_siphash24_chunk buffered v nullPtr 0 totallen + fromIntegral `fmap` peek (v `advancePtr` 4) + go 0 0 cs0 +#endif + +fromSalt :: Int -> Word64 +#if WORD_SIZE_IN_BITS == 64 +fromSalt = fromIntegral +#else +fromSalt v = fromIntegral v `xor` k1 + +k1 :: Word64 +k1 = 0x7654954208bdfef9 +{-# INLINE k1 #-} +#endif + +foreign import ccall unsafe "hashable_siphash24" c_siphash24 + :: Word64 -> Word64 -> Ptr Word8 -> CSize -> IO Word64 + +#if defined(__GLASGOW_HASKELL__) +-- | Compute a hash value for the content of this 'ByteArray#', +-- beginning at the specified offset, using specified number of bytes. +-- Availability: GHC. +hashByteArray :: ByteArray# -- ^ data to hash + -> Int -- ^ offset, in bytes + -> Int -- ^ length, in bytes + -> Int -- ^ hash value +hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt +{-# INLINE hashByteArray #-} + +-- | 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 !h = + fromIntegral $ + c_siphash24_offset k0 (fromSalt h) ba (fromIntegral off) (fromIntegral len) + +foreign import ccall unsafe "hashable_siphash24_offset" c_siphash24_offset + :: Word64 -> Word64 -> ByteArray# -> CSize -> CSize -> Word64 + +foreign import ccall unsafe "hashable_siphash24_chunk_offset" + c_siphash24_chunk_offset + :: CInt -> Ptr Word64 -> ByteArray# -> CSize -> CSize -> CSize -> IO CInt +#endif + +#if WORD_SIZE_IN_BITS == 32 +foreign import ccall unsafe "hashable_wang_32" c_wang32 + :: Word32 -> Word32 +#endif + +foreign import ccall unsafe "hashable_wang_64" c_wang64 + :: Word64 -> Word64 + +foreign import ccall unsafe "hashable_siphash_init" c_siphash_init + :: Word64 -> Word64 -> Ptr Word64 -> IO () + +foreign import ccall unsafe "hashable_siphash24_chunk" c_siphash24_chunk + :: CInt -> Ptr Word64 -> Ptr Word8 -> CSize -> CSize -> IO CInt diff --git a/Data/Hashable/Generic.hs b/Data/Hashable/Generic.hs new file mode 100644 --- /dev/null +++ b/Data/Hashable/Generic.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable.Generic +-- Copyright : (c) Bryan O'Sullivan 2012 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : provisional +-- Portability : GHC >= 7.2 +-- +-- Hashable support for GHC generics. + +module Data.Hashable.Generic + ( + ) where + +import Data.Bits (Bits, shiftR) +import Data.Hashable.Class +import GHC.Generics + +-- Type without constructors +instance GHashable V1 where + ghashWithSalt salt _ = hashWithSalt salt () + +-- Constructor without arguments +instance GHashable U1 where + ghashWithSalt salt U1 = hashWithSalt salt () + +instance (GHashable a, GHashable b) => GHashable (a :*: b) where + ghashWithSalt salt (x :*: y) = salt `ghashWithSalt` x `ghashWithSalt` y + +-- Metadata (constructor name, etc) +instance GHashable a => GHashable (M1 i c a) where + ghashWithSalt salt = ghashWithSalt salt . unM1 + +-- Constants, additional parameters, and rank-1 recursion +instance Hashable a => GHashable (K1 i a) where + ghashWithSalt = hashUsing unK1 + +class GSum f where + hashSum :: Int -> Int -> Int -> f a -> Int + +instance (GSum a, GSum b, GHashable a, GHashable b, + SumSize a, SumSize b) => GHashable (a :+: b) where + ghashWithSalt salt = hashSum salt 0 size + where size = unTagged (sumSize :: Tagged (a :+: b)) + +instance (GSum a, GSum b, GHashable a, GHashable b) => GSum (a :+: b) where + hashSum !salt !code !size s = case s of + L1 x -> hashSum salt code sizeL x + R1 x -> hashSum salt (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE hashSum #-} + +instance GHashable a => GSum (C1 c a) where + hashSum !salt !code _ x = salt `hashWithSalt` code `ghashWithSalt` x + {-# INLINE hashSum #-} + +class SumSize f where + sumSize :: Tagged f + +newtype Tagged (s :: * -> *) = Tagged {unTagged :: Int} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a) + + unTagged (sumSize :: Tagged b) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/Data/Hashable/RandomSource.hs b/Data/Hashable/RandomSource.hs new file mode 100644 --- /dev/null +++ b/Data/Hashable/RandomSource.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Data.Hashable.RandomSource + ( + getRandomBytes + , getRandomBytes_ + ) where + +import Data.ByteString as B +import Data.ByteString.Internal (create) +import Foreign.C.Error (throwErrnoIfMinus1_) +#if MIN_VERSION_base(4,5,0) +import Foreign.C.Types (CInt(CInt)) +#else +import Foreign.C.Types (CInt) +#endif +import Foreign.Ptr (Ptr) + +getRandomBytes :: Int -> IO ByteString +getRandomBytes nbytes + | nbytes <= 0 = return B.empty + | otherwise = create nbytes $ flip (getRandomBytes_ "getRandomBytes") nbytes + +getRandomBytes_ :: String -> Ptr a -> Int -> IO () +getRandomBytes_ what ptr nbytes = do + throwErrnoIfMinus1_ what $ c_getRandomBytes ptr (fromIntegral nbytes) + +foreign import ccall unsafe "hashable_getRandomBytes" c_getRandomBytes + :: Ptr a -> CInt -> IO CInt diff --git a/Data/Hashable/SipHash.hs b/Data/Hashable/SipHash.hs new file mode 100644 --- /dev/null +++ b/Data/Hashable/SipHash.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Data.Hashable.SipHash + ( + LE64 + , Sip + , fromWord64 + , fullBlock + , lastBlock + , finalize + , hashByteString + ) where + +#include "MachDeps.h" + +import Data.Bits ((.|.), (.&.), rotateL, shiftL, xor) +#if MIN_VERSION_base(4,5,0) +import Data.Bits (unsafeShiftL) +#endif +import Data.Word (Word8, Word64) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Data.ByteString.Internal (ByteString(PS), inlinePerformIO) +import Foreign.Storable (peek) +import Numeric (showHex) + +newtype LE64 = LE64 { fromLE64 :: Word64 } + deriving (Eq) + +instance Show LE64 where + show (LE64 !v) = let s = showHex v "" + in "0x" ++ replicate (16 - length s) '0' ++ s + +data Sip = Sip { + v0 :: {-# UNPACK #-} !Word64, v1 :: {-# UNPACK #-} !Word64 + , v2 :: {-# UNPACK #-} !Word64, v3 :: {-# UNPACK #-} !Word64 + } + +fromWord64 :: Word64 -> LE64 +#ifndef WORDS_BIGENDIAN +fromWord64 = LE64 +#else +#error big endian support TBD +#endif + +initState :: (Sip -> r) -> Word64 -> Word64 -> r +initState k k0 k1 = k (Sip s0 s1 s2 s3) + where !s0 = (k0 `xor` 0x736f6d6570736575) + !s1 = (k1 `xor` 0x646f72616e646f6d) + !s2 = (k0 `xor` 0x6c7967656e657261) + !s3 = (k1 `xor` 0x7465646279746573) + +sipRound :: (Sip -> r) -> Sip -> r +sipRound k Sip{..} = k (Sip v0_c v1_d v2_c v3_d) + where v0_a = v0 + v1 + v2_a = v2 + v3 + v1_a = v1 `rotateL` 13 + v3_a = v3 `rotateL` 16 + v1_b = v1_a `xor` v0_a + v3_b = v3_a `xor` v2_a + v0_b = v0_a `rotateL` 32 + v2_b = v2_a + v1_b + v0_c = v0_b + v3_b + v1_c = v1_b `rotateL` 17 + v3_c = v3_b `rotateL` 21 + v1_d = v1_c `xor` v2_b + v3_d = v3_c `xor` v0_c + v2_c = v2_b `rotateL` 32 + +fullBlock :: Int -> LE64 -> (Sip -> r) -> Sip -> r +fullBlock c m k st@Sip{..} + | c == 2 = sipRound (sipRound k') st' + | otherwise = runRounds c k' st' + where k' st1@Sip{..} = k st1{ v0 = v0 `xor` fromLE64 m } + st' = st{ v3 = v3 `xor` fromLE64 m } +{-# INLINE fullBlock #-} + +runRounds :: Int -> (Sip -> r) -> Sip -> r +runRounds c k = go 0 + where go i st + | i < c = sipRound (go (i+1)) st + | otherwise = k st +{-# INLINE runRounds #-} + +lastBlock :: Int -> Int -> LE64 -> (Sip -> r) -> Sip -> r +lastBlock !c !len !m k st = +#ifndef WORDS_BIGENDIAN + fullBlock c (LE64 m') k st +#else +#error big endian support TBD +#endif + where m' = fromLE64 m .|. ((fromIntegral len .&. 0xff) `shiftL` 56) +{-# INLINE lastBlock #-} + +finalize :: Int -> (Word64 -> r) -> Sip -> r +finalize d k st@Sip{..} + | d == 4 = sipRound (sipRound (sipRound (sipRound k'))) st' + | otherwise = runRounds d k' st' + where k' Sip{..} = k $! v0 `xor` v1 `xor` v2 `xor` v3 + st' = st{ v2 = v2 `xor` 0xff } +{-# INLINE finalize #-} + +hashByteString :: Int -> Int -> Word64 -> Word64 -> ByteString -> Word64 +hashByteString !c !d k0 k1 (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \basePtr -> + let ptr0 = basePtr `plusPtr` off + scant = len .&. 7 + endBlocks = ptr0 `plusPtr` (len - scant) + go !ptr st + | ptr == endBlocks = readLast ptr + | otherwise = do + m <- peekLE64 ptr + fullBlock c m (go (ptr `plusPtr` 8)) st + where + zero !m _ _ = lastBlock c len (LE64 m) (finalize d return) st + one k m p s = do + w <- fromIntegral `fmap` peekByte p + k (m .|. (w `unsafeShiftL` s)) (p `plusPtr` 1) (s+8) + readLast p = + case scant of + 0 -> zero 0 p (0::Int) + 1 -> one zero 0 p 0 + 2 -> one (one zero) 0 p 0 + 3 -> one (one (one zero)) 0 p 0 + 4 -> one (one (one (one zero))) 0 p 0 + 5 -> one (one (one (one (one zero)))) 0 p 0 + 6 -> one (one (one (one (one (one zero))))) 0 p 0 + _ -> one (one (one (one (one (one (one zero)))))) 0 p 0 + in initState (go ptr0) k0 k1 + +peekByte :: Ptr Word8 -> IO Word8 +peekByte = peek + +peekLE64 :: Ptr Word8 -> IO LE64 +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) +-- platforms on which unaligned loads are legal and usually fast +peekLE64 p = LE64 `fmap` peek (castPtr p) +#else +peekLE64 p = do + let peek8 d = fromIntegral `fmap` peekByte (p `plusPtr` d) + b0 <- peek8 0 + b1 <- peek8 1 + b2 <- peek8 2 + b3 <- peek8 3 + b4 <- peek8 4 + b5 <- peek8 5 + b6 <- peek8 6 + b7 <- peek8 7 + let !w = (b7 `shiftL` 56) .|. (b6 `shiftL` 48) .|. (b5 `shiftL` 40) .|. + (b4 `shiftL` 32) .|. (b3 `shiftL` 24) .|. (b2 `shiftL` 16) .|. + (b1 `shiftL` 8) .|. b0 + return (fromWord64 w) +#endif + +#if !MIN_VERSION_base(4,5,0) +unsafeShiftL :: Word64 -> Int -> Word64 +unsafeShiftL = shiftL +#endif diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,13 +1,25 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, + UnboxedTuples #-} module Main (main) where import Control.Monad.ST import Criterion.Main import Data.Hashable +import Data.Hashable.SipHash +import Data.Int import Foreign.ForeignPtr import GHC.Exts import GHC.ST (ST(..)) +import Data.Word +import Foreign.C.Types (CInt(..), CLong(..), CSize(..)) +import Foreign.Ptr +import Data.ByteString.Internal +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Crypto.MAC.SipHash as HS +import qualified Data.ByteString.Char8 as B8 -- Benchmark English words (5 and 8), base64 encoded integers (11), -- SHA1 hashes as hex (40), and large blobs (1 Mb). @@ -18,20 +30,69 @@ fp8 <- mallocForeignPtrBytes 8 fp11 <- mallocForeignPtrBytes 11 fp40 <- mallocForeignPtrBytes 40 + fp128 <- mallocForeignPtrBytes 128 + fp512 <- mallocForeignPtrBytes 512 let !mb = 2^(20 :: Int) -- 1 Mb fp1Mb <- mallocForeignPtrBytes mb - + -- We don't care about the contents of these either. - let !ba5 = new 5 - !ba8 = new 8 - !ba11 = new 11 - !ba40 = new 40 - !ba1Mb = new mb - + let !ba5 = new 5; !ba8 = new 8; !ba11 = new 11; !ba40 = new 40 + !ba128 = new 128; !ba512 = new 512; !ba1Mb = new mb + + s5 = ['\0'..'\4']; s8 = ['\0'..'\7']; s11 = ['\0'..'\10'] + s40 = ['\0'..'\39']; s128 = ['\0'..'\127']; s512 = ['\0'..'\511'] + s1Mb = ['\0'..'\999999'] + + !bs5 = B8.pack s5; !bs8 = B8.pack s8; !bs11 = B8.pack s11 + !bs40 = B8.pack s40; !bs128 = B8.pack s128; !bs512 = B8.pack s512 + !bs1Mb = B8.pack s1Mb + + blmeg = BL.take (fromIntegral mb) . BL.fromChunks . repeat + bl5 = BL.fromChunks [bs5]; bl8 = BL.fromChunks [bs8] + bl11 = BL.fromChunks [bs11]; bl40 = BL.fromChunks [bs40] + bl128 = BL.fromChunks [bs128]; bl512 = BL.fromChunks [bs512] + bl1Mb_40 = blmeg bs40; bl1Mb_128 = blmeg bs128 + bl1Mb_64k = blmeg (B8.take 65536 bs1Mb) + + !t5 = T.pack s5; !t8 = T.pack s8; !t11 = T.pack s11 + !t40 = T.pack s40; !t128 = T.pack s128; !t512 = T.pack s512 + !t1Mb = T.pack s1Mb + + tlmeg = TL.take (fromIntegral mb) . TL.fromChunks . repeat + tl5 = TL.fromStrict t5; tl8 = TL.fromStrict t8 + tl11 = TL.fromStrict t11; tl40 = TL.fromStrict t40 + tl128 = TL.fromStrict t128; tl512 = TL.fromChunks (replicate 4 t128) + tl1Mb_40 = tlmeg t40; tl1Mb_128 = tlmeg t128 + tl1Mb_64k = tlmeg (T.take 65536 t1Mb) + + let k0 = 0x4a7330fae70f52e8 + k1 = 0x919ea5953a9a1ec9 + sipHash = hashByteString 2 4 k0 k1 + hsSipHash = HS.hash (HS.SipKey k0 k1) + cSipHash (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \ptr -> + return $! c_siphash 2 4 k0 k1 (ptr `plusPtr` off) (fromIntegral len) + cSipHash24 (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \ptr -> + return $! c_siphash24 k0 k1 (ptr `plusPtr` off) (fromIntegral len) + fnvHash (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \ptr -> + return $! fnv_hash (ptr `plusPtr` off) (fromIntegral len) 2166136261 +#ifdef HAVE_SSE + sse2SipHash (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \ptr -> + return $! sse2_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len) + sse41SipHash (PS fp off len) = + inlinePerformIO . withForeignPtr fp $ \ptr -> + return $! sse41_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len) +#endif + withForeignPtr fp5 $ \ p5 -> withForeignPtr fp8 $ \ p8 -> withForeignPtr fp11 $ \ p11 -> withForeignPtr fp40 $ \ p40 -> + withForeignPtr fp128 $ \ p128 -> + withForeignPtr fp512 $ \ p512 -> withForeignPtr fp1Mb $ \ p1Mb -> defaultMain [ bgroup "hashPtr" @@ -39,6 +100,8 @@ , bench "8" $ hashPtr p8 8 , bench "11" $ hashPtr p11 11 , bench "40" $ hashPtr p40 40 + , bench "128" $ hashPtr p128 128 + , bench "512" $ hashPtr p512 512 , bench "2^20" $ hashPtr p1Mb mb ] , bgroup "hashByteArray" @@ -46,8 +109,144 @@ , bench "8" $ whnf (hashByteArray ba8 0) 8 , bench "11" $ whnf (hashByteArray ba11 0) 11 , bench "40" $ whnf (hashByteArray ba40 0) 40 + , bench "128" $ whnf (hashByteArray ba128 0) 128 + , bench "512" $ whnf (hashByteArray ba512 0) 512 , bench "2^20" $ whnf (hashByteArray ba1Mb 0) mb ] + , bgroup "hash" + [ bgroup "ByteString" + [ bgroup "strict" + [ bench "5" $ whnf hash bs5 + , bench "8" $ whnf hash bs8 + , bench "11" $ whnf hash bs11 + , bench "40" $ whnf hash bs40 + , bench "128" $ whnf hash bs128 + , bench "512" $ whnf hash bs512 + , bench "2^20" $ whnf hash bs1Mb + ] + , bgroup "lazy" + [ bench "5" $ whnf hash bl5 + , bench "8" $ whnf hash bl8 + , bench "11" $ whnf hash bl11 + , bench "40" $ whnf hash bl40 + , bench "128" $ whnf hash bl128 + , bench "512" $ whnf hash bl512 + , bench "2^20_40" $ whnf hash bl1Mb_40 + , bench "2^20_128" $ whnf hash bl1Mb_128 + , bench "2^20_64k" $ whnf hash bl1Mb_64k + ] + ] + , bgroup "String" + [ bench "5" $ whnf hash s5 + , bench "8" $ whnf hash s8 + , bench "11" $ whnf hash s11 + , bench "40" $ whnf hash s40 + , bench "128" $ whnf hash s128 + , bench "512" $ whnf hash s512 + , bench "2^20" $ whnf hash s1Mb + ] + , bgroup "Text" + [ bgroup "strict" + [ bench "5" $ whnf hash t5 + , bench "8" $ whnf hash t8 + , bench "11" $ whnf hash t11 + , bench "40" $ whnf hash t40 + , bench "128" $ whnf hash t128 + , bench "512" $ whnf hash t512 + , bench "2^20" $ whnf hash t1Mb + ] + , bgroup "lazy" + [ bench "5" $ whnf hash tl5 + , bench "8" $ whnf hash tl8 + , bench "11" $ whnf hash tl11 + , bench "40" $ whnf hash tl40 + , bench "128" $ whnf hash tl128 + , bench "512" $ whnf hash tl512 + , bench "2^20_40" $ whnf hash tl1Mb_40 + , bench "2^20_128" $ whnf hash tl1Mb_128 + , bench "2^20_64k" $ whnf hash tl1Mb_64k + ] + ] + , bench "Int8" $ whnf hash (0xef :: Int8) + , bench "Int16" $ whnf hash (0x7eef :: Int16) + , bench "Int32" $ whnf hash (0x7eadbeef :: Int32) + , bench "Int" $ whnf hash (0x7eadbeefdeadbeef :: Int) + , bench "Int64" $ whnf hash (0x7eadbeefdeadbeef :: Int64) + , bench "Double" $ whnf hash (0.3780675796601578 :: Double) + ] + , bgroup "sipHash" + [ bench "5" $ whnf sipHash bs5 + , bench "8" $ whnf sipHash bs8 + , bench "11" $ whnf sipHash bs11 + , bench "40" $ whnf sipHash bs40 + , bench "128" $ whnf sipHash bs128 + , bench "512" $ whnf sipHash bs512 + , bench "2^20" $ whnf sipHash bs1Mb + ] + , bgroup "cSipHash" + [ bench "5" $ whnf cSipHash bs5 + , bench "8" $ whnf cSipHash bs8 + , bench "11" $ whnf cSipHash bs11 + , bench "40" $ whnf cSipHash bs40 + , bench "128" $ whnf cSipHash bs128 + , bench "512" $ whnf cSipHash bs512 + , bench "2^20" $ whnf cSipHash bs1Mb + ] + , bgroup "cSipHash24" + [ bench "5" $ whnf cSipHash24 bs5 + , bench "8" $ whnf cSipHash24 bs8 + , bench "11" $ whnf cSipHash24 bs11 + , bench "40" $ whnf cSipHash24 bs40 + , bench "128" $ whnf cSipHash24 bs128 + , bench "512" $ whnf cSipHash24 bs512 + , bench "2^20" $ whnf cSipHash24 bs1Mb + ] +#ifdef HAVE_SSE + , bgroup "sse2SipHash" + [ bench "5" $ whnf sse2SipHash bs5 + , bench "8" $ whnf sse2SipHash bs8 + , bench "11" $ whnf sse2SipHash bs11 + , bench "40" $ whnf sse2SipHash bs40 + , bench "128" $ whnf sse2SipHash bs128 + , bench "512" $ whnf sse2SipHash bs512 + , bench "2^20" $ whnf sse2SipHash bs1Mb + ] + , bgroup "sse41SipHash" + [ bench "5" $ whnf sse41SipHash bs5 + , bench "8" $ whnf sse41SipHash bs8 + , bench "11" $ whnf sse41SipHash bs11 + , bench "40" $ whnf sse41SipHash bs40 + , bench "128" $ whnf sse41SipHash bs128 + , bench "512" $ whnf sse41SipHash bs512 + , bench "2^20" $ whnf sse41SipHash bs1Mb + ] +#endif + , bgroup "pkgSipHash" + [ bench "5" $ whnf hsSipHash bs5 + , bench "8" $ whnf hsSipHash bs8 + , bench "11" $ whnf hsSipHash bs11 + , bench "40" $ whnf hsSipHash bs40 + , bench "128" $ whnf hsSipHash bs128 + , bench "512" $ whnf hsSipHash bs512 + , bench "2^20" $ whnf hsSipHash bs1Mb + ] + , bgroup "fnv" + [ bench "5" $ whnf fnvHash bs5 + , bench "8" $ whnf fnvHash bs8 + , bench "11" $ whnf fnvHash bs11 + , bench "40" $ whnf fnvHash bs40 + , bench "128" $ whnf fnvHash bs128 + , bench "512" $ whnf fnvHash bs512 + , bench "2^20" $ whnf fnvHash bs1Mb + ] + , bgroup "Int" + [ bench "id32" $ whnf id (0x7eadbeef :: Int32) + , bench "id64" $ whnf id (0x7eadbeefdeadbeef :: Int64) + , bench "wang32" $ whnf hash_wang_32 0xdeadbeef + , bench "wang64" $ whnf hash_wang_64 0xdeadbeefdeadbeef + , bench "jenkins32a" $ whnf hash_jenkins_32a 0xdeadbeef + , bench "jenkins32b" $ whnf hash_jenkins_32b 0xdeadbeef + ] ] data ByteArray = BA { unBA :: !ByteArray# } @@ -57,3 +256,26 @@ case newByteArray# n# s1 of (# s2, ary #) -> case unsafeFreezeByteArray# ary s2 of (# s3, ba #) -> (# s3, BA ba #)) + +foreign import ccall unsafe "hashable_siphash" c_siphash + :: CInt -> CInt -> Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 +foreign import ccall unsafe "hashable_siphash24" c_siphash24 + :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 +#ifdef HAVE_SSE +foreign import ccall unsafe "hashable_siphash24_sse2" sse2_siphash + :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 +foreign import ccall unsafe "hashable_siphash24_sse41" sse41_siphash + :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 +#endif + +foreign import ccall unsafe "hashable_fnv_hash" fnv_hash + :: Ptr Word8 -> CLong -> CLong -> CLong + +foreign import ccall unsafe "hashable_wang_32" hash_wang_32 + :: Word32 -> Word32 +foreign import ccall unsafe "hashable_wang_64" hash_wang_64 + :: Word64 -> Word64 +foreign import ccall unsafe "hash_jenkins_32a" hash_jenkins_32a + :: Word32 -> Word32 +foreign import ccall unsafe "hash_jenkins_32b" hash_jenkins_32b + :: Word32 -> Word32 diff --git a/benchmarks/Makefile b/benchmarks/Makefile deleted file mode 100644 --- a/benchmarks/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -package := hashable -version := $(shell awk '/^Version:/{print $$2}' ../$(package).cabal) -lib := ../dist/build/libHS$(package)-$(version).a -ghc := ghc -ghc-flags := -Wall -O -hide-all-packages \ - -package-conf ../dist/package.conf.inplace -package base \ - -package hashable -package criterion \ - -package deepseq -package ghc-prim - -%.o: %.hs - $(ghc) $(ghc-flags) -c -o $@ $< - -programs := bench - -.PHONY: all -all: $(programs) - -bench: $(lib) Benchmarks.o - ranlib $(lib) - $(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib) - -.PHONY: clean -clean: - -find . \( -name '*.o' -o -name '*.hi' \) -exec rm {} \; - -rm -f $(programs) diff --git a/benchmarks/cbits/fnv.c b/benchmarks/cbits/fnv.c new file mode 100644 --- /dev/null +++ b/benchmarks/cbits/fnv.c @@ -0,0 +1,53 @@ +/* +Copyright Johan Tibell 2011 + +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 Johan Tibell 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. +*/ + +/* FNV-1 hash + * + * The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/ + * The FNV-1 hash is public domain: http://isthe.com/chongo/tech/comp/fnv/#public_domain + */ +long hashable_fnv_hash(const unsigned char* str, long len, long hash) { + + while (len--) { + hash = (hash * 16777619) ^ *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 hashable_fnv_hash_offset(const unsigned char* str, long offset, long len, long hash) { + return hashable_fnv_hash(str + offset, len, hash); +} diff --git a/benchmarks/cbits/inthash.c b/benchmarks/cbits/inthash.c new file mode 100644 --- /dev/null +++ b/benchmarks/cbits/inthash.c @@ -0,0 +1,28 @@ +#include + +/* + * 32-bit hashes by Bob Jenkins. + */ + +uint32_t hash_jenkins_32a(uint32_t a) +{ + a = (a+0x7ed55d16) + (a<<12); + a = (a^0xc761c23c) ^ (a>>19); + a = (a+0x165667b1) + (a<<5); + a = (a+0xd3a2646c) ^ (a<<9); + a = (a+0xfd7046c5) + (a<<3); + a = (a^0xb55a4f09) ^ (a>>16); + return a; +} + +uint32_t hash_jenkins_32b(uint32_t a) +{ + a -= (a<<6); + a ^= (a>>17); + a -= (a<<9); + a ^= (a<<4); + a -= (a<<3); + a ^= (a<<10); + a ^= (a>>15); + return a; +} diff --git a/cbits/getRandomBytes.c b/cbits/getRandomBytes.c new file mode 100644 --- /dev/null +++ b/cbits/getRandomBytes.c @@ -0,0 +1,93 @@ +/* +Copyright Bryan O'Sullivan 2012 + +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 Johan Tibell 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. +*/ + +#include "MachDeps.h" + +int hashable_getRandomBytes(unsigned char *dest, int nbytes); + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + +#include +#include + +int hashable_getRandomBytes(unsigned char *dest, int nbytes) +{ + HCRYPTPROV hCryptProv; + int ret; + + if (!CryptAcquireContextA(&hCryptProv, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT)) + return -1; + + ret = CryptGenRandom(hCryptProv, (DWORD) nbytes, (BYTE *) dest) ? nbytes : -1; + + CryptReleaseContext(hCryptProv, 0); + + bail: + return ret; +} + +#else + +#include +#include +#include + +/* Assumptions: /dev/urandom exists and does something sane, and does + not block. */ + +int hashable_getRandomBytes(unsigned char *dest, int nbytes) +{ + ssize_t off, nread; + int fd; + + fd = open("/dev/urandom", O_RDONLY); + if (fd == -1) + return -1; + + for (off = 0; nbytes > 0; nbytes -= nread) { + nread = read(fd, dest + off, nbytes); + off += nread; + if (nread == -1) { + off = -1; + break; + } + } + + bail: + close(fd); + + return off; +} + +#endif diff --git a/cbits/hashByteString.c b/cbits/hashByteString.c deleted file mode 100644 --- a/cbits/hashByteString.c +++ /dev/null @@ -1,53 +0,0 @@ -/* -Copyright Johan Tibell 2011 - -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 Johan Tibell 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. -*/ - -/* FNV-1 hash - * - * The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/ - * The FNV-1 hash is public domain: http://isthe.com/chongo/tech/comp/fnv/#public_domain - */ -long hashable_fnv_hash(const unsigned char* str, long len, long hash) { - - while (len--) { - hash = (hash * 16777619) ^ *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 hashable_fnv_hash_offset(const unsigned char* str, long offset, long len, long hash) { - return hashable_fnv_hash(str + offset, len, hash); -} diff --git a/cbits/inthash.c b/cbits/inthash.c new file mode 100644 --- /dev/null +++ b/cbits/inthash.c @@ -0,0 +1,29 @@ +/* + * These hash functions were developed by Thomas Wang. + * + * http://www.concentric.net/~ttwang/tech/inthash.htm + */ + +#include + +uint32_t hashable_wang_32(uint32_t a) +{ + a = (a ^ 61) ^ (a >> 16); + a = a + (a << 3); + a = a ^ (a >> 4); + a = a * 0x27d4eb2d; + a = a ^ (a >> 15); + return a; +} + +uint64_t hashable_wang_64(uint64_t key) +{ + key = (~key) + (key << 21); // key = (key << 21) - key - 1; + key = key ^ ((key >> 24) | (key << 40)); + key = (key + (key << 3)) + (key << 8); // key * 265 + key = key ^ ((key >> 14) | (key << 50)); + key = (key + (key << 2)) + (key << 4); // key * 21 + key = key ^ ((key >> 28) | (key << 36)); + key = key + (key << 31); + return key; +} diff --git a/cbits/siphash-sse2.c b/cbits/siphash-sse2.c new file mode 100644 --- /dev/null +++ b/cbits/siphash-sse2.c @@ -0,0 +1,72 @@ +/* + * The original code was developed by Samuel Neves, and has been + * only lightly modified. + * + * Used with permission. + */ +#include +#include "siphash.h" + +#define _mm_roti_epi64(x, c) ((16 == (c)) ? _mm_shufflelo_epi16((x), _MM_SHUFFLE(2,1,0,3)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c)))) + +u64 hashable_siphash24_sse2(u64 ik0, u64 ik1, const u8 *m, size_t n) +{ + __m128i v0, v1, v2, v3; + __m128i k0, k1; + __m128i mi, mask, len; + size_t i, k; + union { u64 gpr; __m128i xmm; } hash; + + k0 = _mm_loadl_epi64((__m128i*)(&ik0)); + k1 = _mm_loadl_epi64((__m128i*)(&ik1)); + + v0 = _mm_xor_si128(k0, _mm_set_epi32(0, 0, 0x736f6d65, 0x70736575)); + v1 = _mm_xor_si128(k1, _mm_set_epi32(0, 0, 0x646f7261, 0x6e646f6d)); + v2 = _mm_xor_si128(k0, _mm_set_epi32(0, 0, 0x6c796765, 0x6e657261)); + v3 = _mm_xor_si128(k1, _mm_set_epi32(0, 0, 0x74656462, 0x79746573)); + +#define HALF_ROUND(a,b,c,d,s,t) \ + do \ + { \ + a = _mm_add_epi64(a, b); c = _mm_add_epi64(c, d); \ + b = _mm_roti_epi64(b, s); d = _mm_roti_epi64(d, t); \ + b = _mm_xor_si128(b, a); d = _mm_xor_si128(d, c); \ + } while(0) + +#define COMPRESS(v0,v1,v2,v3) \ + do \ + { \ + HALF_ROUND(v0,v1,v2,v3,13,16); \ + v0 = _mm_shufflelo_epi16(v0, _MM_SHUFFLE(1,0,3,2)); \ + HALF_ROUND(v2,v1,v0,v3,17,21); \ + v2 = _mm_shufflelo_epi16(v2, _MM_SHUFFLE(1,0,3,2)); \ + } while(0) + + for(i = 0; i < (n-n%8); i += 8) + { + mi = _mm_loadl_epi64((__m128i*)(m + i)); + v3 = _mm_xor_si128(v3, mi); + for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v0,v1,v2,v3); + v0 = _mm_xor_si128(v0, mi); + } + + mi = _mm_loadl_epi64((__m128i*)(m + i)); + len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0); + mask = _mm_srli_epi64(_mm_set_epi32(0, 0, 0xffffffff, 0xffffffff), 8*(8-n%8)); + mi = _mm_xor_si128(_mm_and_si128(mi, mask), len); + + v3 = _mm_xor_si128(v3, mi); + for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v0,v1,v2,v3); + v0 = _mm_xor_si128(v0, mi); + + v2 = _mm_xor_si128(v2, _mm_set_epi32(0, 0, 0, 0xff)); + for(k = 0; k < SIPHASH_FINALROUNDS; ++k) COMPRESS(v0,v1,v2,v3); + + v0 = _mm_xor_si128(_mm_xor_si128(v0, v1), _mm_xor_si128(v2, v3)); + hash.xmm = v0; + +#undef COMPRESS +#undef HALF_ROUND + //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32); + return hash.gpr; +} diff --git a/cbits/siphash-sse41.c b/cbits/siphash-sse41.c new file mode 100644 --- /dev/null +++ b/cbits/siphash-sse41.c @@ -0,0 +1,84 @@ +/* + * The original code was developed by Samuel Neves, and has been + * only lightly modified. + * + * Used with permission. + */ +#include +#include "siphash.h" + +// Specialized for siphash, do not reuse +#define rotate16(x) _mm_shufflehi_epi16((x), _MM_SHUFFLE(2,1,0,3)) + +#define _mm_roti_epi64(x, c) (((c) == 16) ? rotate16((x)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c)))) +//#define _mm_roti_epi64(x, c) _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c))) + + +u64 hashable_siphash24_sse41(u64 _k0, u64 _k1, const unsigned char *m, size_t n) +{ + __m128i v0, v1, v02, v13; + __m128i k0; + __m128i mi, mask, len, h; + const __m128i zero = _mm_setzero_si128(); + size_t i, k; + union { u64 gpr; __m128i xmm; } hash; + unsigned char key[16]; + + ((u64 *)key)[0] = _k0; + ((u64 *)key)[1] = _k1; + + k0 = _mm_loadu_si128((__m128i*)(key + 0)); + + v0 = _mm_xor_si128(k0, _mm_set_epi32(0x646f7261, 0x6e646f6d, 0x736f6d65, 0x70736575)); + v1 = _mm_xor_si128(k0, _mm_set_epi32(0x74656462, 0x79746573, 0x6c796765, 0x6e657261)); + + v02 = _mm_unpacklo_epi64(v0, v1); + v13 = _mm_unpackhi_epi64(v0, v1); + +#define HALF_ROUND(a,b,s,t) \ +do \ +{ \ + __m128i b1,b2; \ + a = _mm_add_epi64(a, b); \ + b1 = _mm_roti_epi64(b, s); b2 = _mm_roti_epi64(b, t); b = _mm_blend_epi16(b1, b2, 0xF0); \ + b = _mm_xor_si128(b, a); \ +} while(0) + +#define COMPRESS(v02,v13) \ + do \ + { \ + HALF_ROUND(v02,v13,13,16); \ + v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \ + HALF_ROUND(v02,v13,17,21); \ + v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \ + } while(0) + + for(i = 0; i < (n-n%8); i += 8) + { + mi = _mm_loadl_epi64((__m128i*)(m + i)); + v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi)); + for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13); + v02 = _mm_xor_si128(v02, mi); + } + + mi = _mm_loadl_epi64((__m128i*)(m + i)); + len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0); + mask = _mm_srli_epi64(_mm_set_epi32(0, 0, 0xffffffff, 0xffffffff), 8*(8-n%8)); + mi = _mm_xor_si128(_mm_and_si128(mi, mask), len); + + v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi)); + for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13); + v02 = _mm_xor_si128(v02, mi); + + v02 = _mm_xor_si128(v02, _mm_set_epi32(0, 0xff, 0, 0)); + for(k = 0; k < SIPHASH_FINALROUNDS; ++k) COMPRESS(v02,v13); + + v0 = _mm_xor_si128(v02, v13); + v0 = _mm_xor_si128(v0, _mm_castps_si128(_mm_movehl_ps(_mm_castsi128_ps(zero), _mm_castsi128_ps(v0)))); + hash.xmm = v0; + +#undef COMPRESS +#undef HALF_ROUND + //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32); + return hash.gpr; +} diff --git a/cbits/siphash.c b/cbits/siphash.c new file mode 100644 --- /dev/null +++ b/cbits/siphash.c @@ -0,0 +1,247 @@ +/* Almost a verbatim copy of the reference implementation. */ + +#include +#include "siphash.h" + +#define ROTL(x,b) (u64)(((x) << (b)) | ((x) >> (64 - (b)))) + +#define SIPROUND \ + do { \ + v0 += v1; v1=ROTL(v1,13); v1 ^= v0; v0=ROTL(v0,32); \ + v2 += v3; v3=ROTL(v3,16); v3 ^= v2; \ + v0 += v3; v3=ROTL(v3,21); v3 ^= v0; \ + v2 += v1; v1=ROTL(v1,17); v1 ^= v2; v2=ROTL(v2,32); \ + } while(0) + +#if defined(__i386) +# define _siphash24 plain_siphash24 +#endif + +static inline u64 odd_read(const u8 *p, int count, u64 val, int shift) +{ + switch (count) { + case 7: val |= ((u64)p[6]) << (shift + 48); + case 6: val |= ((u64)p[5]) << (shift + 40); + case 5: val |= ((u64)p[4]) << (shift + 32); + case 4: val |= ((u64)p[3]) << (shift + 24); + case 3: val |= ((u64)p[2]) << (shift + 16); + case 2: val |= ((u64)p[1]) << (shift + 8); + case 1: val |= ((u64)p[0]) << shift; + } + return val; +} + +static inline u64 _siphash(int c, int d, u64 k0, u64 k1, + const u8 *str, size_t len) +{ + u64 v0 = 0x736f6d6570736575ull ^ k0; + u64 v1 = 0x646f72616e646f6dull ^ k1; + u64 v2 = 0x6c7967656e657261ull ^ k0; + u64 v3 = 0x7465646279746573ull ^ k1; + const u8 *end, *p; + u64 b; + int i; + + for (p = str, end = str + (len & ~7); p < end; p += 8) { + u64 m = *(u64 *) p; + v3 ^= m; + if (c == 2) { + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < c; i++) + SIPROUND; + } + v0 ^= m; + } + + b = odd_read(p, len & 7, ((u64) len) << 56, 0); + + v3 ^= b; + if (c == 2) { + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < c; i++) + SIPROUND; + } + v0 ^= b; + + v2 ^= 0xff; + if (d == 4) { + SIPROUND; + SIPROUND; + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < d; i++) + SIPROUND; + } + b = v0 ^ v1 ^ v2 ^ v3; + return b; +} + + +static inline u64 _siphash24(u64 k0, u64 k1, const u8 *str, size_t len) +{ + return _siphash(2, 4, k0, k1, str, len); +} + +#if defined(__i386) +# undef _siphash24 + +static u64 (*_siphash24)(u64 k0, u64 k1, const u8 *, size_t); + +static void maybe_use_sse() + __attribute__((constructor)); + +static void maybe_use_sse() +{ + uint32_t eax = 1, ebx, ecx, edx; + + __asm volatile + ("mov %%ebx, %%edi;" /* 32bit PIC: don't clobber ebx */ + "cpuid;" + "mov %%ebx, %%esi;" + "mov %%edi, %%ebx;" + :"+a" (eax), "=S" (ebx), "=c" (ecx), "=d" (edx) + : :"edi"); + + if (edx & (1 << 26)) + _siphash24 = hashable_siphash24_sse2; + if (ecx & (1 << 19)) + _siphash24 = hashable_siphash24_sse41; + else + _siphash24 = plain_siphash24; +} + +#endif + +u64 hashable_siphash(int c, int d, u64 k0, u64 k1, const u8 *str, size_t len) +{ + return _siphash(c, d, k0, k1, str, len); +} + +u64 hashable_siphash24(u64 k0, u64 k1, const u8 *str, size_t len) +{ + return _siphash24(k0, k1, str, len); +} + +/* Used for ByteArray#s. We can't treat them like pointers in + native Haskell, but we can in unsafe FFI calls. + */ +u64 hashable_siphash24_offset(u64 k0, u64 k1, + const u8 *str, size_t off, size_t len) +{ + return _siphash24(k0, k1, str + off, len); +} + +static int _siphash_chunk(int c, int d, int buffered, u64 v[5], + const u8 *str, size_t len, size_t totallen) +{ + u64 v0 = v[0], v1 = v[1], v2 = v[2], v3 = v[3], m, b; + const u8 *p, *end; + u64 carry = 0; + int i; + + if (buffered > 0) { + int unbuffered = 8 - buffered; + int tobuffer = unbuffered > len ? len : unbuffered; + int shift = buffered << 3; + + m = odd_read(str, tobuffer, v[4], shift); + str += tobuffer; + buffered += tobuffer; + len -= tobuffer; + + if (buffered < 8) + carry = m; + else { + v3 ^= m; + if (c == 2) { + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < c; i++) + SIPROUND; + } + v0 ^= m; + buffered = 0; + m = 0; + } + } + + for (p = str, end = str + (len & ~7); p < end; p += 8) { + m = *(u64 *) p; + v3 ^= m; + if (c == 2) { + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < c; i++) + SIPROUND; + } + v0 ^= m; + } + + b = odd_read(p, len & 7, 0, 0); + + if (totallen == -1) { + v[0] = v0; + v[1] = v1; + v[2] = v2; + v[3] = v3; + v[4] = b | carry; + + return buffered + (len & 7); + } + + b |= ((u64) totallen) << 56; + + v3 ^= b; + if (c == 2) { + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < c; i++) + SIPROUND; + } + v0 ^= b; + + v2 ^= 0xff; + if (d == 4) { + SIPROUND; + SIPROUND; + SIPROUND; + SIPROUND; + } else { + for (i = 0; i < d; i++) + SIPROUND; + } + v[4] = v0 ^ v1 ^ v2 ^ v3; + return 0; +} + +void hashable_siphash_init(u64 k0, u64 k1, u64 *v) +{ + v[0] = 0x736f6d6570736575ull ^ k0; + v[1] = 0x646f72616e646f6dull ^ k1; + v[2] = 0x6c7967656e657261ull ^ k0; + v[3] = 0x7465646279746573ull ^ k1; + v[4] = 0; +} + +int hashable_siphash24_chunk(int buffered, u64 v[5], const u8 *str, + size_t len, size_t totallen) +{ + return _siphash_chunk(2, 4, buffered, v, str, len, totallen); +} + +/* + * Used for ByteArray#. + */ +int hashable_siphash24_chunk_offset(int buffered, u64 v[5], const u8 *str, + size_t off, size_t len, size_t totallen) +{ + return _siphash_chunk(2, 4, buffered, v, str + off, len, totallen); +} diff --git a/cbits/siphash.h b/cbits/siphash.h new file mode 100644 --- /dev/null +++ b/cbits/siphash.h @@ -0,0 +1,22 @@ +#ifndef _hashable_siphash_h +#define _hashable_siphash_h + +#include + +typedef uint64_t u64; +typedef uint32_t u32; +typedef uint16_t u16; +typedef uint8_t u8; + +#define SIPHASH_ROUNDS 2 +#define SIPHASH_FINALROUNDS 4 + +u64 hashable_siphash(int, int, u64, u64, const u8 *, size_t); +u64 hashable_siphash24(u64, u64, const u8 *, size_t); + +#if defined(__i386) +u64 hashable_siphash24_sse2(u64, u64, const u8 *, size_t); +u64 hashable_siphash24_sse41(u64, u64, const u8 *, size_t); +#endif + +#endif /* _hashable_siphash_h */ diff --git a/hashable.cabal b/hashable.cabal --- a/hashable.cabal +++ b/hashable.cabal @@ -1,5 +1,5 @@ Name: hashable -Version: 1.1.2.5 +Version: 1.2.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 @@ -20,15 +20,22 @@ -- 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: - CHANGES, README.md, tests/Properties.hs, benchmarks/Benchmarks.hs - benchmarks/Makefile + CHANGES, README.md, tests/Properties.hs, benchmarks/Benchmarks.hs, + cbits/siphash.h Flag integer-gmp Description: Are we using integer-gmp to provide fast Integer instances? Default: True +Flag fixed-salt + Description: Do we use a single fixed salt every time the program runs? + Default: False + Library Exposed-modules: Data.Hashable + Other-modules: Data.Hashable.Class + Data.Hashable.RandomSource + Data.Hashable.SipHash Build-depends: base >= 4.0 && < 5.0, bytestring >= 0.9 if impl(ghc) @@ -37,16 +44,33 @@ if impl(ghc) && flag(integer-gmp) Build-depends: integer-gmp >= 0.2 - C-sources: cbits/hashByteString.c + if impl(ghc >= 7.2.1) + CPP-Options: -DGENERICS + Other-modules: Data.Hashable.Generic + + C-sources: cbits/getRandomBytes.c + cbits/inthash.c + cbits/siphash.c + if arch(i386) + C-sources: cbits/siphash-sse2.c + cbits/siphash-sse41.c + CC-options: -msse2 -msse4.1 + Ghc-options: -Wall if impl(ghc >= 6.8) Ghc-options: -fwarn-tabs + if flag(fixed-salt) + Cpp-options: -DFIXED_SALT + if os(windows) + extra-libraries: advapi32 Test-suite tests Type: exitcode-stdio-1.0 Hs-source-dirs: tests Main-is: Properties.hs Build-depends: base >= 4.0 && < 5.0, + bytestring, + ghc-prim, hashable, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, @@ -55,6 +79,57 @@ text >= 0.11.0.5 Ghc-options: -Wall -fno-warn-orphans + if impl(ghc >= 7.2.1) + CPP-Options: -DGENERICS + +benchmark benchmarks + -- We cannot depend on the hashable library directly as that creates + -- a dependency cycle. + hs-source-dirs: . benchmarks + + main-is: Benchmarks.hs + other-modules: + Data.Hashable + Data.Hashable.Class + Data.Hashable.RandomSource + Data.Hashable.SipHash + type: exitcode-stdio-1.0 + + build-depends: + base, + bytestring, + criterion, + ghc-prim, + siphash, + text + + if impl(ghc) + Build-depends: ghc-prim, + text >= 0.11.0.5 + if impl(ghc) && flag(integer-gmp) + Build-depends: integer-gmp >= 0.2 + + c-sources: + cbits/getRandomBytes.c + cbits/inthash.c + cbits/siphash.c + benchmarks/cbits/fnv.c + benchmarks/cbits/inthash.c + + if arch(i386) || arch(x86_64) + cpp-options: -DHAVE_SSE + cc-options: -msse2 -msse4.1 + c-sources: + cbits/siphash-sse2.c + cbits/siphash-sse41.c + + Ghc-options: -Wall -O2 + if impl(ghc >= 6.8) + Ghc-options: -fwarn-tabs + if flag(fixed-salt) + Cpp-options: -DFIXED_SALT + if os(windows) + extra-libraries: advapi32 source-repository head type: git diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash, Rank2Types, - UnboxedTuples #-} +{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash, + Rank2Types, UnboxedTuples #-} +#ifdef GENERICS +{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} +#endif -- | Tests for the 'Data.Hashable' module. We test functions by -- comparing the C and Haskell implementations. module Main (main) where -import Data.Hashable (Hashable(hash), hashByteArray, hashPtr) +import Data.Hashable (Hashable, hash, hashByteArray, hashPtr) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T -import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy as TL +import Data.List (nub) +import Control.Monad (ap, liftM) import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Array (withArray) import GHC.Base (ByteArray#, Int(..), newByteArray#, unsafeCoerce#, @@ -18,6 +25,9 @@ import Test.QuickCheck hiding ((.&.)) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) +#ifdef GENERICS +import GHC.Generics +#endif ------------------------------------------------------------------------ -- * Properties @@ -25,9 +35,17 @@ instance Arbitrary T.Text where arbitrary = T.pack `fmap` arbitrary -instance Arbitrary L.Text where - arbitrary = L.pack `fmap` arbitrary +instance Arbitrary TL.Text where + arbitrary = TL.pack `fmap` arbitrary +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + +instance Arbitrary BL.ByteString where + arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double))) + ((BL.fromChunks . map (B.pack . nonEmpty)) `fmap` arbitrary) + where nonEmpty (NonEmpty a) = a + -- | Validate the implementation by comparing the C and Haskell -- versions. pHash :: [Word8] -> Bool @@ -40,13 +58,15 @@ pText a b = if (a == b) then (hash a == hash b) else True -- | Content equality implies hash equality. -pTextLazy :: L.Text -> L.Text -> Bool +pTextLazy :: TL.Text -> TL.Text -> Bool pTextLazy a b = if (a == b) then (hash a == hash b) else True -- | A small positive integer. newtype ChunkSize = ChunkSize { unCS :: Int } - deriving (Eq, Ord, Num, Integral, Real, Enum, Show) + deriving (Eq, Ord, Num, Integral, Real, Enum) +instance Show ChunkSize where show = show . unCS + instance Arbitrary ChunkSize where arbitrary = (ChunkSize . (`mod` maxChunkSize)) `fmap` (arbitrary `suchThat` ((/=0) . (`mod` maxChunkSize))) @@ -54,22 +74,53 @@ -- | 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 +pTextRechunk :: T.Text -> NonEmptyList ChunkSize -> Bool +pTextRechunk t cs = TL.fromStrict t == rechunkText t cs --- | Content equality implies hash equality. -pLazyRechunked :: T.Text -> NonEmptyList ChunkSize -> Bool -pLazyRechunked t cs = hash (L.fromStrict t) == hash (rechunk t cs) +-- | Lazy strings must hash to the same value no matter how they are +-- chunked. +pTextLazyRechunked :: T.Text + -> NonEmptyList ChunkSize -> NonEmptyList ChunkSize -> Bool +pTextLazyRechunked t cs0 cs1 = + hash (rechunkText t cs0) == hash (rechunkText t cs1) -- | 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 +rechunkText :: T.Text -> NonEmptyList ChunkSize -> TL.Text +rechunkText t0 (NonEmpty cs0) = TL.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 go _ [] = error "Properties.rechunk - The 'impossible' happened!" +-- | Content equality implies hash equality. +pBS :: B.ByteString -> B.ByteString -> Bool +pBS a b = if (a == b) then (hash a == hash b) else True + +-- | Content equality implies hash equality. +pBSLazy :: BL.ByteString -> BL.ByteString -> Bool +pBSLazy a b = if (a == b) then (hash a == hash b) else True + +-- | Break up a string into chunks of different sizes. +rechunkBS :: B.ByteString -> NonEmptyList ChunkSize -> BL.ByteString +rechunkBS t0 (NonEmpty cs0) = BL.fromChunks . go t0 . cycle $ cs0 + where + go t _ | B.null t = [] + go t (c:cs) = a : go b cs + where (a,b) = B.splitAt (unCS c) t + go _ [] = error "Properties.rechunkBS - The 'impossible' happened!" + +-- | Ensure that the rechunk function causes a rechunked string to +-- still match its original form. +pBSRechunk :: B.ByteString -> NonEmptyList ChunkSize -> Bool +pBSRechunk t cs = fromStrict t == rechunkBS t cs + +-- | Lazy bytestrings must hash to the same value no matter how they +-- are chunked. +pBSLazyRechunked :: B.ByteString + -> NonEmptyList ChunkSize -> NonEmptyList ChunkSize -> Bool +pBSLazyRechunked t cs1 cs2 = hash (rechunkBS t cs1) == hash (rechunkBS t cs2) + -- This wrapper is required by 'runST'. data ByteArray = BA { unBA :: ByteArray# } @@ -86,6 +137,62 @@ case writeWord8Array# marr# i# x s# of s2# -> go s2# (i + 1) marr# xs +-- Generics + +#ifdef GENERICS + +data Product2 a b = Product2 a b + deriving (Generic) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Product2 a b) where + arbitrary = Product2 `liftM` arbitrary `ap` arbitrary + +instance (Hashable a, Hashable b) => Hashable (Product2 a b) + +data Product3 a b c = Product3 a b c + deriving (Generic) + +instance (Arbitrary a, Arbitrary b, Arbitrary c) => + Arbitrary (Product3 a b c) where + arbitrary = Product3 `liftM` arbitrary `ap` arbitrary `ap` arbitrary + +instance (Hashable a, Hashable b, Hashable c) => Hashable (Product3 a b c) + +-- Hashes of all product types of the same shapes should be the same. + +pProduct2 :: Int -> String -> Bool +pProduct2 x y = hash (x, y) == hash (Product2 x y) + +pProduct3 :: Double -> Maybe Bool -> (Int, String) -> Bool +pProduct3 x y z = hash (x, y, z) == hash (Product3 x y z) + +data Sum2 a b = S2a a | S2b b + deriving (Eq, Ord, Show, Generic) + +instance (Hashable a, Hashable b) => Hashable (Sum2 a b) + +data Sum3 a b c = S3a a | S3b b | S3c c + deriving (Eq, Ord, Show, Generic) + +instance (Hashable a, Hashable b, Hashable c) => Hashable (Sum3 a b c) + +-- Hashes of the same parameter, but with different sum constructors, +-- should differ. (They might legitimately collide, but that's +-- vanishingly unlikely.) + +pSum2_differ :: Int -> Bool +pSum2_differ x = nub hs == hs + where hs = [ hash (S2a x :: Sum2 Int Int) + , hash (S2b x :: Sum2 Int Int) ] + +pSum3_differ :: Int -> Bool +pSum3_differ x = nub hs == hs + where hs = [ hash (S3a x :: Sum3 Int Int Int) + , hash (S3b x :: Sum3 Int Int Int) + , hash (S3c x :: Sum3 Int Int Int) ] + +#endif + ------------------------------------------------------------------------ -- Test harness @@ -98,7 +205,33 @@ , testGroup "text" [ testProperty "text/strict" pText , testProperty "text/lazy" pTextLazy - , testProperty "rechunk" pRechunk - , testProperty "text/rechunked" pLazyRechunked + , testProperty "text/rechunk" pTextRechunk + , testProperty "text/rechunked" pTextLazyRechunked ] + , testGroup "bytestring" + [ testProperty "bytestring/strict" pBS + , testProperty "bytestring/lazy" pBSLazy + , testProperty "bytestring/rechunk" pBSRechunk + , testProperty "bytestring/rechunked" pBSLazyRechunked + ] +#ifdef GENERICS + , testGroup "generics" + [ + testProperty "product2" pProduct2 + , testProperty "product3" pProduct3 + , testProperty "sum2_differ" pSum2_differ + , testProperty "sum3_differ" pSum3_differ + ] +#endif ] + +------------------------------------------------------------------------ +-- Utilities + +fromStrict :: B.ByteString -> BL.ByteString +#if MIN_VERSION_bytestring(0,10,0) +fromStrict = BL.fromStrict +#else +fromStrict b = BL.fromChunks [b] +#endif +