gistfile1.hs

{-# LANGUAGE BangPatterns #-}
import           Data.Digest.Adler32 (adler32)
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import           Criterion.Main
import           System.IO
import           Data.Word
import           Data.Bits

-- using instead of generic Strict Pair (c.f. High-Performance Haskell) lets
-- us complete in about 70% the time
data IntWord = IW {-# UNPACK #-} !Int
                  {-# UNPACK #-} !Word32

modAdler32 :: Word32
modAdler32 = 65521

updateHash :: Word32 -> Word8 -> Word32 -> Word8 -> Word32
updateHash winlen !old8 !hash word8 =
  let old           = {-# SCC "convertOld" #-} fromIntegral old8
      word          = {-# SCC "convertWord" #-} fromIntegral word8
      limit         = {-# SCC "getLimit" #-} modAdler32
      low           = {-# SCC "getLow" #-} hash .&. 0xffff
      high          = {-# SCC "getHigh" #-} (hash `shiftR` 16) .&. 0xffff

      nlow''        = {-# SCC "addLow" #-} low + word
      nlow'         = {-# SCC "truncLow" #-} if nlow'' > limit
                                               then nlow'' - limit
                                               else nlow''
      nlow          = {-# SCC "remOldLow" #-} if nlow' > old
                                                then nlow' - old
                                                else limit + nlow' - old

      nhigh''       = {-# SCC "addHigh" #-} high + nlow'
      nhigh'        = {-# SCC "truncHigh" #-} if nhigh'' > limit
                                                then nhigh'' - limit
                                                else nhigh''

      -- winlen < 256, so tosub is never more than 255 * 256 and is thus less
      -- than the modAdler32 limit
      tosub         = {-# SCC "calcSub" #-} (1 + winlen) * old 

      nhigh         = {-# SCC "subSub" #-} if nhigh' > tosub
                                             then nhigh' - tosub
                                             else limit + nhigh' - tosub

      success       = {-# SCC "genHash" #-} (nhigh `shiftL` 16) .|. nlow
  in
    if winlen < 256
      then success
      else error "Window length must be less than 256"

updateHash' :: ByteString -> Word32 -> Int -> Word32 -> Word8 -> Word32
updateHash' bs winlen oldpos =
  updateHash winlen old
  where
    old = {-# SCC "BS.index" #-} (BS.index bs oldpos)

runWindow :: Word32 -> ByteString -> Word32
runWindow winlen bs =
  let (inits, rest) = BS.splitAt (fromIntegral winlen) bs

      updatefn :: IntWord -> Word8 -> IntWord
      updatefn = \(IW oldp hash) word ->
                    IW (oldp + 1) (updateHash' bs winlen oldp hash word)

      IW _ w = BS.foldl updatefn (IW 0 (adler32 inits)) rest
  in w

main = do
  bytes <- withFile "/dev/urandom" ReadMode ((flip BS.hGet) 16777216)
  defaultMain [ bgroup "adler32" [ bench "works?" $ nf (runWindow 128) bytes ]]

  --return $! runWindow 128 bytes