gistfile1.txt

   5,366,256,252 bytes allocated in the heap
       3,725,456 bytes copied during GC
       2,664,388 bytes maximum residency (3 sample(s))
          86,768 bytes maximum slop
               5 MB total memory in use (0 MB lost due to fragmentation)

  Generation 0:  8444 collections,     0 parallel,  1.44s,  1.44s elapsed
  Generation 1:     3 collections,     0 parallel,  0.00s,  0.00s elapsed

  INIT  time    0.00s  (  0.00s elapsed)
  MUT   time    8.99s  (  9.12s elapsed)
  GC    time    1.44s  (  1.45s elapsed)
  EXIT  time    0.35s  (  0.35s elapsed)
  Total time   10.78s  ( 10.92s elapsed)

  %GC time      13.4%  (13.3% elapsed)

  Alloc rate    574,510,391 bytes per MUT second

  Productivity  86.6% of total user, 85.6% of total elapsed

judyhash.hs

{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Main where

import Codec.Digest.SHA
import Control.Monad
import Data.Bits
import Data.ByteString as BS(ByteString, pack, unpack)
import Data.Judy as J
import Data.Maybe
import Data.Word
import Data.Vector.Storable as V(Vector, last)
import Data.Vector.Storable.ByteString
import Foreign.StablePtr
import GHC.Ptr
import GHC.Base
import GHC.Word

newtype JSlice = JSlice (JudyL Int)

getslice :: JSlice -> JudyL Int
getslice (JSlice v) = v

instance J.JE JSlice where
    toWord s = do
        p <- newStablePtr s
        case castStablePtrToPtr p of
             Ptr a# -> return $! W# (int2Word# (addr2Int# a#))

    fromWord w =
        case fromIntegral w of
             I# i# -> case int2Addr# i# of
                     a# -> deRefStablePtr (castPtrToStablePtr (Ptr a#))
    {-# INLINE toWord   #-}
    {-# INLINE fromWord #-}

type JAll = JudyL JSlice

mkWord :: ByteString -> Word64
mkWord str = V.last vec .&. 0xFFFFFFFFFFF --0x3FFFFFFFFFFFF
    where
    vec :: Vector Word64
    vec = byteStringToVector str

mkByteString :: Int -> ByteString
mkByteString i = pack (mksplit i)
    where
    mksplit :: Int -> [Word8]
    mksplit 0 = []
    mksplit n = fromIntegral r : mksplit q
        where
        (q, r) = quotRem n 256

mkht :: IO JAll
mkht = new

hilo :: Word64 -> (Word, Word)
hilo w = (hi, lo)
    where
    hi = fromIntegral (shiftR w 32)
    lo = fromIntegral (w .&. 0xffffffff)

jcheck :: Word64 -> JAll -> IO Bool
jcheck hv ht = do
    slice <- J.lookup keyh ht
    if isJust slice
        then J.member keyl (getslice $ fromJust slice)
        else return False
    where
    (keyh, keyl) = hilo hv

jget :: Word64 -> JAll -> IO Int
jget hv ht = do
    slice <- J.lookup keyh ht
    v <- J.lookup keyl (getslice $ fromJust slice)
    return (fromJust v)
    where
    (keyh, keyl) = hilo hv

jinsert :: Word64 -> Int-> JAll -> IO ()
jinsert hv src ht = do
    sl <- slice
    insert keyl src $ getslice sl
    where
    (keyh, keyl) = hilo hv
    slice = do
        s <- J.lookup keyh ht
        case s of
            Just v -> return v
            _ -> do
                v <- liftM JSlice new
                J.insert keyh v ht
                return v

main::IO()
main = do
    ht <- mkht
    forM_ [1..] $ \i -> do
        let str = mkByteString i
        let hv = mkWord (hash SHA256 str)
        found <- jcheck hv ht  
        when found $ do
           iold <- jget hv ht
           error (show (unpack $ mkByteString i) ++ " " ++ show (unpack $ mkByteString iold))
        jinsert hv i ht