diff --git a/Data/Digest/Murmur32.hs b/Data/Digest/Murmur32.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/Murmur32.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleInstances, BangPatterns #-} +{-| +Module : Data.Digest.Murmur32 +Copyright : (c) Thomas Schilling 2010 +License : BSD-style + +Maintainer : nominolo@gmail.com +Stability : experimental +Portability : portable + +Type class and primitives for constructing 32 bit hashes using the +MurmurHash2 algorithm. See for +details on MurmurHash2. +-} +module Data.Digest.Murmur32 + ( Hash32, asWord32, + Hashable32(..), + hash32AddWord32, hash32AddInt, hash32, hash32WithSeed + ) +where + +import Data.Word +import Numeric ( showHex ) +import Data.Bits +import Data.Char ( ord ) +import Data.Foldable +import Data.List ( unfoldr ) + +-- | A 32 bit hash. +newtype Hash32 = Hash32 Word32 + deriving (Eq, Ord, Bounded) + +instance Show Hash32 where + showsPrec _ (Hash32 w) = showString "Hash32 0x" . showHex w + +-- | Extract 32 bit word from hash. +asWord32 :: Hash32 -> Word32 +asWord32 (Hash32 w) = w + +-- | Instance for +class Hashable32 a where + hash32Add :: a -> Hash32 -> Hash32 + +murmur_m :: Word32 +murmur_m = 0x5bd1e995 + +murmur_r :: Int +murmur_r = 24 + +hash32AddWord32 :: Word32 -> Hash32 -> Hash32 +hash32AddWord32 k (Hash32 h) = + let k1 = k * murmur_m + k2 = k1 `xor` (k1 `shiftR` murmur_r) + k3 = k2 * murmur_m + h1 = h * murmur_m + h2 = h1 `xor` k3 + in Hash32 h2 + +hash32AddInt :: Int -> Hash32 -> Hash32 +hash32AddInt !k0 + | bitSize (undefined :: Int) <= 32 -- Int is 32 bits + = hash32AddWord32 (fromIntegral k0) + | otherwise -- Int is 64 bits + = hash32AddWord32 (fromIntegral k0) `combine` + hash32AddWord32 (fromIntegral (k0 `shiftR` 32)) + +hash32AddFoldable :: (Hashable32 a, Foldable c) => c a -> Hash32 -> Hash32 +hash32AddFoldable c !h0 = foldl' f h0 c + where f h a = hash32Add a h + +-- | Create a hash using a custom seed. +-- +-- The seed should be non-zero, but other than that can be an +-- arbitrary number. Different seeds will give different hashes, and +-- thus (most likely) different hash collisions. +hash32WithSeed :: Hashable32 a => Word32 -> a -> Hash32 +hash32WithSeed seed a = hash32End (hash32Add a (Hash32 seed)) + +-- | Create a hash using the default seed. +hash32 :: Hashable32 a => a -> Hash32 +hash32 = hash32WithSeed defaultSeed + +-- | Combine two hash generators. E.g., +-- +-- @ +-- hashFoo (Foo a) = hash32AddInt 1 `combine` hash32Add a +-- @ +combine :: (Hash32 -> Hash32) -> (Hash32 -> Hash32) -> (Hash32 -> Hash32) +combine x y = y . x + +hash32End :: Hash32 -> Hash32 +hash32End (Hash32 h) = + let h1 = h `xor` (h `shiftR` 13) + h2 = h1 * murmur_m + h3 = h2 `xor` (h2 `shiftR` 15) + in Hash32 h3 + +defaultSeed :: Word32 +defaultSeed = 0xdeadbeef -- not 0, otherwise hash32 [0] == hash32 [] + +{- + +On a CPU with two multipliers and two ALUs, Murmur2 can process one +word in every two cycles + set up (2 cycles) and finish (3 cycles). + +Here's the data flow graph: + +@ + h k1 k2 k3 ... + | | | | + | * m | | + | |\ | | + | | >> r | + | | / | | + | xor * | + | | |\ | + * m * m | >> r + \ / |/ | + xor xor * m + \ / |\ + * m * m | >> r + \ / |/ + xor xor + \ / + * m * m + \ / + xor + \ + ... +@ +-} + +-- ------------------------------------------------------------------- +-- Instances + +instance Hashable32 Char where + hash32Add c = hash32AddInt (ord c) + +instance Hashable32 Int where + hash32Add = hash32AddInt + +instance Hashable32 Word32 where + hash32Add = hash32AddWord32 + +instance Hashable32 a => Hashable32 [a] where + hash32Add = hash32AddFoldable + +instance Hashable32 Integer where + -- Within Int range, make sure they hash to exactly the same value + hash32Add i0 + | i0 >= fromIntegral (minBound :: Int) && + i0 <= fromIntegral (maxBound :: Int) + = hash32AddInt (fromIntegral i0) + | otherwise + -- Prefix by sign, then hash the raw data words, starting with LSB + = hash32Add (signum i0 > 0) `combine` + hash32AddFoldable (unfoldr f (abs i0) :: [Word32]) + where + f i | i == 0 = Nothing + f i = + let (i', a) = quotRem i maxWord in + Just (fromIntegral a, i') + maxWord = fromIntegral (maxBound :: Word32) + 1 :: Integer + +instance Hashable32 Bool where + hash32Add False = hash32AddWord32 1 + hash32Add True = hash32AddWord32 2 + +instance Hashable32 a => Hashable32 (Maybe a) where + hash32Add Nothing = hash32AddWord32 3 + hash32Add (Just a) = hash32AddWord32 4 `combine` hash32Add a + +instance (Hashable32 a, Hashable32 b) => Hashable32 (Either a b) where + hash32Add (Left a) = hash32AddWord32 5 `combine` hash32Add a + hash32Add (Right b) = hash32AddWord32 6 `combine` hash32Add b + +instance Hashable32 () where + hash32Add () = hash32AddWord32 7 + +instance (Hashable32 a, Hashable32 b) => Hashable32 (a, b) where + hash32Add (a, b) = hash32Add a `combine` hash32Add b + +instance (Hashable32 a, Hashable32 b, Hashable32 c) + => Hashable32 (a, b, c) where + hash32Add (a, b, c) = + hash32Add a `combine` hash32Add b `combine` hash32Add c + +instance (Hashable32 a, Hashable32 b, Hashable32 c, Hashable32 d) + => Hashable32 (a, b, c, d) where + hash32Add (a, b, c, d) = + hash32Add a `combine` hash32Add b `combine` + hash32Add c `combine` hash32Add d + diff --git a/Data/Digest/Murmur64.hs b/Data/Digest/Murmur64.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/Murmur64.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE FlexibleInstances, BangPatterns #-} +{-| +Module : Data.Digest.Murmur64 +Copyright : (c) Thomas Schilling 2010 +License : BSD-style + +Maintainer : nominolo@gmail.com +Stability : experimental +Portability : portable + +Type class and primitives for constructing 64 bit hashes using the +MurmurHash2 algorithm. See for +details on MurmurHash2. +-} +module Data.Digest.Murmur64 + ( Hash64, asWord64, + Hashable64(..), + hash64AddWord64, hash64AddInt, hash64, hash64WithSeed, combine, + ) +where + +import Data.Word +import Numeric ( showHex ) +import Data.Bits +import Data.Char ( ord ) +import Data.Foldable +import Data.List ( unfoldr ) + +-- | A 64 bit hash. +newtype Hash64 = Hash64 Word64 + deriving (Eq, Ord, Bounded) + +instance Show Hash64 where + showsPrec _ (Hash64 w) = showString "Hash64 0x" . showHex w + +-- | Extract 64 bit word from hash. +asWord64 :: Hash64 -> Word64 +asWord64 (Hash64 w) = w + +class Hashable64 a where + hash64Add :: a -> Hash64 -> Hash64 + +murmur_m :: Word64 +murmur_m = 0xc6a4a7935bd1e995 + +murmur_r :: Int +murmur_r = 47 + +-- | Add a 64 bit word to the hash. +hash64AddWord64 :: Word64 -> Hash64 -> Hash64 +hash64AddWord64 k (Hash64 h) = + let k1 = k * murmur_m + k2 = k1 `xor` (k1 `shiftR` murmur_r) + k3 = k2 * murmur_m + h1 = h * murmur_m + h2 = h1 `xor` k3 + in Hash64 h2 + +hash64AddInt :: Int -> Hash64 -> Hash64 +hash64AddInt !k0 = hash64AddWord64 (fromIntegral k0) + +hash64AddFoldable :: (Hashable64 a, Foldable c) => c a -> Hash64 -> Hash64 +hash64AddFoldable c !h0 = foldl' f h0 c + where f h a = hash64Add a h + +-- | Create a hash using a custom seed. +--h +-- The seed should be non-zero, but other than that can be an +-- arbitrary number. Different seeds will give different hashes, and +-- thus (most likely) different hash collisions. +hash64WithSeed :: Hashable64 a => Word64 -> a -> Hash64 +hash64WithSeed seed a = hash64End (hash64Add a (Hash64 seed)) + +-- | Create a hash using the default seed. +hash64 :: Hashable64 a => a -> Hash64 +hash64 = hash64WithSeed defaultSeed + +-- | Combine two hash generators. E.g., +-- +-- @ +-- hashFoo (Foo a) = hash64AddInt 1 `combine` hash64Add a +-- @ +combine :: (Hash64 -> Hash64) -> (Hash64 -> Hash64) -> (Hash64 -> Hash64) +combine x y = y . x + +hash64End :: Hash64 -> Hash64 +hash64End (Hash64 h) = + let h1 = h `xor` (h `shiftR` murmur_r) + h2 = h1 * murmur_m + h3 = h2 `xor` (h2 `shiftR` murmur_r) + in Hash64 h3 + +defaultSeed :: Word64 +defaultSeed = 0xdeadbeef -- not 0, otherwise hash64 [0] == hash64 [] + +{- + +On a CPU with two multipliers and two ALUs, Murmur2 can process one +word in every two cycles + set up (2 cycles) and finish (3 cycles). + +Here's the data flow graph: + +@ + h k1 k2 k3 ... + | | | | + | * m | | + | |\ | | + | | >> r | + | | / | | + | xor * | + | | |\ | + * m * m | >> r + \ / |/ | + xor xor * m + \ / |\ + * m * m | >> r + \ / |/ + xor xor + \ / + * m * m + \ / + xor + \ + ... +@ +-} + +-- ------------------------------------------------------------------- +-- Instances + +instance Hashable64 Char where + hash64Add c = hash64AddInt (ord c) + +instance Hashable64 Int where + hash64Add = hash64AddInt + +instance Hashable64 Word64 where + hash64Add = hash64AddWord64 + +instance Hashable64 a => Hashable64 [a] where + hash64Add = hash64AddFoldable + +instance Hashable64 Integer where + -- Within Int range, make sure they hash to exactly the same value + hash64Add i0 + | i0 >= fromIntegral (minBound :: Int) && + i0 <= fromIntegral (maxBound :: Int) + = hash64AddInt (fromIntegral i0) + | otherwise + -- Prefix by sign, then hash the raw data words, starting with LSB + = hash64Add (signum i0 > 0) `combine` + hash64AddFoldable (unfoldr f (abs i0) :: [Word64]) + where + f i | i == 0 = Nothing + f i = + let (i', a) = quotRem i maxWord in + Just (fromIntegral a, i') + maxWord = fromIntegral (maxBound :: Word64) + 1 :: Integer + +instance Hashable64 Bool where + hash64Add False = hash64AddWord64 1 + hash64Add True = hash64AddWord64 2 + +instance Hashable64 a => Hashable64 (Maybe a) where + hash64Add Nothing = hash64AddWord64 3 + hash64Add (Just a) = hash64AddWord64 4 `combine` hash64Add a + +instance (Hashable64 a, Hashable64 b) => Hashable64 (Either a b) where + hash64Add (Left a) = hash64AddWord64 5 `combine` hash64Add a + hash64Add (Right b) = hash64AddWord64 6 `combine` hash64Add b + +instance Hashable64 () where + hash64Add () = hash64AddWord64 7 + +instance (Hashable64 a, Hashable64 b) => Hashable64 (a, b) where + hash64Add (a, b) = hash64Add a `combine` hash64Add b + +instance (Hashable64 a, Hashable64 b, Hashable64 c) + => Hashable64 (a, b, c) where + hash64Add (a, b, c) = + hash64Add a `combine` hash64Add b `combine` hash64Add c + +instance (Hashable64 a, Hashable64 b, Hashable64 c, Hashable64 d) + => Hashable64 (a, b, c, d) where + hash64Add (a, b, c, d) = + hash64Add a `combine` hash64Add b `combine` + hash64Add c `combine` hash64Add d + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2010, Thomas Schilling +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 name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE 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 UNIVERSITY +COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/murmur-hash.cabal b/murmur-hash.cabal new file mode 100644 --- /dev/null +++ b/murmur-hash.cabal @@ -0,0 +1,28 @@ +Name: murmur-hash +Version: 0.1 +License: BSD3 +License-File: LICENSE +Author: Thomas Schilling +Maintainer: Thomas Schilling +Homepage: http://github.com/nominolo/murmur-hash +Synopsis: MurmurHash2 implementation for +Description: + Implements MurmurHash2, a good, fast, general-purpose, + non-cryptographic hashing function. See + for details. + . + This implementation is pure Haskell, so it might be a bit slower + than a C FFI binding. + +Category: Data, Digest +Stability: provisional +Build-Type: Simple +Cabal-Version: >= 1.6 + +Library + Build-Depends: + base >= 3.0 && < 4.3 + + exposed-modules: + Data.Digest.Murmur32 + Data.Digest.Murmur64