Permalink
Browse files

Initial cut at a SipHash implementation

I have verified that this gives the same results as the reference
implementation, which can be found here (hard to find via Google):
https://www.131002.net/siphash/siphash24.c

Compared to the current FNV hash, this first attempt achieves so-so
performance, with slowdown ranging from 4x on small inputs to 1.4x
for large.

bytes  FNV   SipHash
  5     15        63 ns
  8     17        70
 11     19        74
 40     49       124

1MB    1.2       1.7 ms
  • Loading branch information...
1 parent 240626f commit 579f06679447e86467ff43fa40d5438815db5b0a @bos committed Sep 30, 2012
Showing with 154 additions and 0 deletions.
  1. +143 −0 Data/Hashable/SipHash.hs
  2. +10 −0 benchmarks/Benchmarks.hs
  3. +1 −0 hashable.cabal
View
143 Data/Hashable/SipHash.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving #-}
+
+module Data.Hashable.SipHash
+ (
+ LE64
+ , fromWord64
+ , fullBlock
+ , lastBlock
+ , finalize
+ , hashByteString
+ ) where
+
+#include "MachDeps.h"
+
+import Data.Bits
+import Data.Word
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Data.ByteString.Internal
+import Foreign.Storable
+import Numeric
+
+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
+
+fromWord64 :: Word64 -> LE64
+#ifndef WORDS_BIGENDIAN
+fromWord64 = LE64
+#else
+#error big endian support TBD
+#endif
+
+initState :: (Word64 -> Word64 -> Word64 -> Word64 -> r)
+ -> Word64 -> Word64
+ -> r
+initState k k0 k1 = k v0 v1 v2 v3
+ where !v0 = (k0 `xor` 0x736f6d6570736575)
+ !v1 = (k1 `xor` 0x646f72616e646f6d)
+ !v2 = (k0 `xor` 0x6c7967656e657261)
+ !v3 = (k1 `xor` 0x7465646279746573)
+
+sipRound :: (Word64 -> Word64 -> Word64 -> Word64 -> r)
+ -> Word64 -> Word64 -> Word64 -> Word64 -> r
+sipRound k !v0 !v1 !v2 !v3 = k 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
+ -> (Word64 -> Word64 -> Word64 -> Word64 -> r)
+ -> Word64 -> Word64 -> Word64 -> Word64 -> r
+fullBlock c m k v0 v1 v2 v3 = runRounds c k' v0 v1 v2 (v3 `xor` fromLE64 m)
+ where k' w0 = k $! (w0 `xor` fromLE64 m)
+{-# INLINE fullBlock #-}
+
+runRounds :: Int
+ -> (Word64 -> Word64 -> Word64 -> Word64 -> r)
+ -> Word64 -> Word64 -> Word64 -> Word64 -> r
+runRounds !c k = go 0
+ where go i !v0 !v1 !v2 !v3
+ | i < c = sipRound (go (i+1)) v0 v1 v2 v3
+ | otherwise = k v0 v1 v2 v3
+{-# INLINE runRounds #-}
+
+lastBlock :: Int -> Int -> LE64
+ -> (Word64 -> Word64 -> Word64 -> Word64 -> r)
+ -> Word64 -> Word64 -> Word64 -> Word64 -> r
+lastBlock !c !len !m k !v0 !v1 !v2 !v3 =
+#ifndef WORDS_BIGENDIAN
+ fullBlock c (LE64 m') k v0 v1 v2 v3
+#else
+#error big endian support TBD
+#endif
+ where m' = fromLE64 m .|. ((fromIntegral len .&. 0xff) `shiftL` 56)
+{-# INLINE lastBlock #-}
+
+finalize :: Int
+ -> (Word64 -> r)
+ -> Word64 -> Word64 -> Word64 -> Word64 -> r
+finalize d k v0 v1 v2 v3 = runRounds d k' v0 v1 (v2 `xor` 0xff) v3
+ where k' w0 w1 w2 w3 = k $! w0 `xor` w1 `xor` w2 `xor` w3
+{-# 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 !v0 !v1 !v2 !v3
+ | ptr == endBlocks = readLast ptr 0 0
+ | otherwise = do
+ m <- peekLE64 ptr
+ fullBlock c m (go (ptr `plusPtr` 8)) v0 v1 v2 v3
+ where
+ readLast p !s !m
+ | p == end = lastBlock c len (LE64 m)
+ (finalize d return)
+ v0 v1 v2 v3
+ | otherwise = do
+ b <- fromIntegral `fmap` peekByte p
+ readLast (p `plusPtr` 1) (s+8) (m .|. (b `unsafeShiftL` s))
+ where end = ptr0 `plusPtr` len
+ 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
View
10 benchmarks/Benchmarks.hs
@@ -5,6 +5,7 @@ module Main (main) where
import Control.Monad.ST
import Criterion.Main
import Data.Hashable
+import Data.Hashable.SipHash
import Foreign.ForeignPtr
import GHC.Exts
import GHC.ST (ST(..))
@@ -35,6 +36,8 @@ main = do
!bs40 = B.pack [0..39]
!bs1Mb = B.pack . map fromIntegral $ [0..999999::Int]
+ let sipHash = hashByteString 2 4 0x4a7330fae70f52e8 0x919ea5953a9a1ec9
+
withForeignPtr fp5 $ \ p5 ->
withForeignPtr fp8 $ \ p8 ->
withForeignPtr fp11 $ \ p11 ->
@@ -64,6 +67,13 @@ main = do
, bench "2^20" $ whnf hash bs1Mb
]
]
+ , bgroup "sipHash"
+ [ bench "5" $ whnf sipHash bs5
+ , bench "8" $ whnf sipHash bs8
+ , bench "11" $ whnf sipHash bs11
+ , bench "40" $ whnf sipHash bs40
+ , bench "2^20" $ whnf sipHash bs1Mb
+ ]
]
data ByteArray = BA { unBA :: !ByteArray# }
View
1 hashable.cabal
@@ -29,6 +29,7 @@ Flag integer-gmp
Library
Exposed-modules: Data.Hashable
+ Data.Hashable.SipHash
Build-depends: base >= 4.0 && < 5.0,
bytestring >= 0.9
if impl(ghc)

0 comments on commit 579f066

Please sign in to comment.