Murmur3 x64 128 hash

murmurHash3_x64_128.hs

{-# LANGUAGE MagicHash #-}

import GHC.Exts
import Foreign
import GHC.Word
import Control.Arrow ((>>>))

rotl64 :: Word64 -> Int -> Word64
rotl64 (W64# x#) (I# i#) = W64# ((x# `uncheckedShiftL64#` i#) `or64#` (x# `uncheckedShiftRL64#` (64# -# i#)))

fmix64 :: Word64 -> Word64
fmix64 = (\k -> k `xor` (k `unsafeShiftR` 33))
     >>> (\k -> k * 0xff51afd7ed558ccd)
     >>> (\k -> k `xor` (k `unsafeShiftR` 33))
     >>> (\k -> k * 0xc4ceb9fe1a85ec53)
     >>> (\k -> k `xor` (k `unsafeShiftR` 33))

{-# NOINLINE murmurHash3_x64_128 #-}
murmurHash3_x64_128 :: Ptr a -> Int -> Word64 -> IO Word64
murmurHash3_x64_128 !key !len !seed = body seed seed 0 where
  data' :: Ptr Word8
  data' = castPtr key
  nblocks = len `quot` 16

  c1, c2 :: Word64
  c1 = 0x87c37b91114253d5
  c2 = 0x4cf5ad432745937f

  blocks :: Ptr Word64
  blocks = castPtr data'

  body :: Word64 -> Word64 -> Int -> IO Word64
  body !h1 !h2 !i
    | i < nblocks = do
      k1 <- peekElemOff blocks (i * 2 + 0)
      k2 <- peekElemOff blocks (i * 2 + 1)
      let !k1' = (rotl64 (k1 * c1) 31) * c2
      let !h1' = ((rotl64 (h1 `xor` k1') 27) + h2) * 5 + 0x52dce729
      let !k2' = (rotl64 (k2 * c2) 33) * c1
      let !h2' = ((rotl64 (h2 `xor` k2') 31) + h2) * 5 + 0x38495ab5
      body h1' h2' (i + 1)
    | otherwise = tail h1 h2

  tailPtr :: Ptr Word8
  tailPtr = plusPtr data' (nblocks*16)

  tail :: Word64 -> Word64 -> IO Word64
  tail !h1 !h2 = case len .&. 15 of
    15 -> table_15 0 0
    14 -> table_14 0 0
    13 -> table_13 0 0
    12 -> table_12 0 0
    11 -> table_11 0 0
    10 -> table_10 0 0
    9  -> table_9  0 0
    8  -> table_8  0 0
    7  -> table_7  0 0
    6  -> table_6  0 0
    5  -> table_5  0 0
    4  -> table_4  0 0
    3  -> table_3  0 0
    2  -> table_2  0 0
    1  -> table_1  0 0
    _  -> table_0  0 0
    where
      table_15 !k1 !k2 = do
        x <- peekElemOff tailPtr 14
        table_14 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 48))
      table_14 !k1 !k2 = do
        x <- peekElemOff tailPtr 13
        table_13 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 40))
      table_13 !k1 !k2 = do
        x <- peekElemOff tailPtr 12
        table_12 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 32))
      table_12 !k1 !k2 = do
        x <- peekElemOff tailPtr 11
        table_11 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 24))
      table_11 !k1 !k2 = do
        x <- peekElemOff tailPtr 10
        table_10 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 16))
      table_10 !k1 !k2 = do
        x <- peekElemOff tailPtr 9
        table_9 k1 (k2 `xor` (fromIntegral x `unsafeShiftL` 8))
      table_9 !k1 !k2 = do
        x <- peekElemOff tailPtr 8
        table_8 k1 (rotl64 ((k2 `xor` fromIntegral x) * c2) 33 * c1)

      table_8 !k1 !k2 = do
        x <- peekElemOff tailPtr 7
        table_7 (k1 `xor` (fromIntegral x `unsafeShiftL` 56)) k2
      table_7 !k1 !k2 = do
        x <- peekElemOff tailPtr 6
        table_6 (k1 `xor` (fromIntegral x `unsafeShiftL` 48)) k2
      table_6 !k1 !k2 = do
        x <- peekElemOff tailPtr 5
        table_5 (k1 `xor` (fromIntegral x `unsafeShiftL` 40)) k2
      table_5 !k1 !k2 = do
        x <- peekElemOff tailPtr 4
        table_4 (k1 `xor` (fromIntegral x `unsafeShiftL` 32)) k2
      table_4 !k1 !k2 = do
        x <- peekElemOff tailPtr 3
        table_3 (k1 `xor` (fromIntegral x `unsafeShiftL` 24)) k2
      table_3 !k1 !k2 = do
        x <- peekElemOff tailPtr 2
        table_2 (k1 `xor` (fromIntegral x `unsafeShiftL` 16)) k2
      table_2 !k1 !k2 = do
        x <- peekElemOff tailPtr 1
        table_1 (k1 `xor` (fromIntegral x `unsafeShiftL` 8)) k2
      table_1 !k1 !k2 = do
        x <- peekElemOff tailPtr 0
        table_0 (rotl64 ((k1 `xor` fromIntegral x) * c1) 31 * c2) k2

      table_0 !k1 !k2 = do
        finalization (h1 `xor` k1) (h2 `xor` k2)

  finalization :: Word64 -> Word64 -> IO Word64
  finalization !h1 !h2 = pure (h1'2 + h2'2) where
    h1'0 = h1 `xor` fromIntegral len
    h2'0 = h2 `xor` fromIntegral len
    h1'1 = h1'0 + h2'0
    h2'1 = h1'1 + h2'0
    h1'2 = fmix64 h1'1
    h2'2 = fmix64 h2'1