snappy-hs 0.1.1.0 → 0.1.2.0
raw patch · 7 files changed
+382/−129 lines, 7 filesdep +criteriondep +deepseqdep +snappydep ~snappy-hsPVP ok
version bump matches the API change (PVP)
Dependencies added: criterion, deepseq, snappy
Dependency ranges changed: snappy-hs
API changes (from Hackage documentation)
Files
- CHANGELOG.md +11/−0
- README.md +21/−2
- benchmark/Bench.hs +61/−44
- benchmark/Main.hs +43/−0
- snappy-hs.cabal +14/−11
- src/Snappy.hs +177/−64
- test/Main.hs +55/−8
CHANGELOG.md view
@@ -1,6 +1,17 @@ # Revision history for snappy-hs +## 0.1.2.0 -- 2026-06-19++* Major throughput work bringing decompression to roughly C parity and+ compression to ~2–3x of C (was ~2–6x, and ~130x on incompressible data).+* Encoder now follows C Snappy's `CompressFragment`: an exponential skip+ heuristic over incompressible data, match chaining, word-at-a-time match+ extension via trailing-zero count, and an input-sized hash table+ (32-bit slots, capped at 2^14) instead of a fixed 256 KB table.+* Decoder uses wide (8-byte) literal and overlapping-copy writes backed by+ output over-allocation slack.+ ## 0.1.0.5 -- 2026-02-23 * Use `Ptr` directly to make implementation faster.
README.md view
@@ -6,8 +6,26 @@ ## Performance -In informal benchmarks, this implementation is roughly **2–3× slower** than native Snappy.+Measured against the native C library (the `snappy` bindings) on the Google Snappy+test corpus, GHC 9.12 / aarch64, library built with `-O2`: +| dataset (size) | decompress vs C | compress vs C |+| --------------------- | --------------- | ------------- |+| html (100 KB) | 1.8x | 2.3x |+| alice29.txt (149 KB) | 1.5x | 3.1x |+| geo.protodata (116 KB)| 1.8x | 2.4x |+| urls.10K (686 KB) | 2.1x | 2.6x |+| fireworks.jpeg (120 KB, incompressible) | 1.0x | 1.8x |++**Decompression runs at roughly C parity** (~1-2x) and compression is ~2-3x of C.+The gap that remains is GHC's native code generator versus a C compiler, not the+algorithm — the encoder mirrors C Snappy's `CompressFragment` (skip heuristic,+word-at-a-time match extension, input-sized hash table). Output is validated to be+byte-compatible with the C library in both directions.++Reproduce with `cabal bench` (criterion, needs the C `snappy` library installed)+or `cabal run snappy-bench` (pure, no C dependency).+ ## When to use * You want **cross-platform Snappy encode/decode** with a **pure Haskell** dependency stack@@ -15,4 +33,5 @@ ## When not to use -* You need **maximum throughput** (use the native library or an FFI-based binding instead)+* You need **maximum throughput** (use the native library or an FFI-based binding instead).+ You would get a lot of mileage from the library too however.
benchmark/Bench.hs view
@@ -1,61 +1,78 @@ {-# LANGUAGE BangPatterns #-} module Main where +import Control.DeepSeq (force) import Control.Exception (evaluate)+import Control.Monad (forM) import Data.IORef import qualified Data.ByteString as BS import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word8) import Snappy+import Text.Printf (printf) -main :: IO ()-main = do- src <- BS.readFile "./data/Isaac.Newton-Opticks.txt"- let !payloadMB = fromIntegral (BS.length src) / (1024 * 1024) :: Double- iters = 200 :: Int+-- | Representative slice of the Google Snappy test corpus plus the original+-- sample. Keep this list in sync with @benchmark/Main.hs@.+corpus :: [FilePath]+corpus =+ [ "./data/Isaac.Newton-Opticks.txt"+ , "./data/html"+ , "./data/alice29.txt"+ , "./data/geo.protodata"+ , "./data/urls.10K"+ , "./data/fireworks.jpeg"+ ] - putStrLn $ "Input: " ++ show (BS.length src) ++ " bytes, " ++ show iters ++ " iterations"+-- | Iterate each file enough times to process at least this many bytes, so a+-- small file still gets a stable timing signal and a large file does not block.+bytesPerFile :: Int+bytesPerFile = 32 * 1024 * 1024 - -- Pre-generate varied inputs (16 KB + 1 byte each, tiny overhead)- let inputs = [ BS.snoc src (fromIntegral i :: Word8) | i <- [1..iters] ]+-- | Distinct inputs per file. A small pool defeats let-floating/CSE of the+-- loop-invariant call while keeping memory bounded for large files.+poolSize :: Int+poolSize = 64 - -- Compress benchmark- cRef <- newIORef undefined- t0c <- getPOSIXTime- mapM_ (\tweaked -> do- let !c = compress tweaked- _ <- evaluate (BS.length c)- writeIORef cRef c) inputs- t1c <- getPOSIXTime- compressed <- readIORef cRef- let totalCompMs = realToFrac (t1c - t0c) * 1000 :: Double- compSecs = realToFrac (t1c - t0c) / fromIntegral iters :: Double- putStrLn $ "compress: " ++ show (BS.length compressed) ++ " bytes -> "- ++ showMBps payloadMB compSecs ++ " MB/s"- ++ " (total " ++ showMs totalCompMs ++ "ms)"+main :: IO ()+main = do+ putStrLn "file size compress decompress"+ putStrLn "--------------------------------------------------------------------"+ rows <- forM corpus $ \path -> do+ src <- BS.readFile path+ let !n = BS.length src+ !iters = max poolSize (bytesPerFile `div` max 1 n)+ !mb = fromIntegral (n * iters) / (1024 * 1024) :: Double+ -- Vary the trailing byte so each pool entry is a distinct value.+ pool = [ BS.snoc src (fromIntegral k :: Word8) | k <- [0 .. poolSize - 1] ]+ !poolV <- evaluate (force pool)+ !compV <- evaluate (force (map compress poolV))+ let inputs = take iters (cycle poolV)+ compreds = take iters (cycle compV) - -- Pre-compress all inputs so decompress benchmark is decompress-only- let compInputs = map (compress . BS.snoc src . (fromIntegral :: Int -> Word8)) [1..iters]+ cRef <- newIORef (0 :: Int)+ t0c <- getPOSIXTime+ mapM_ (\b -> writeIORef cRef =<< evaluate (BS.length (compress b))) inputs+ t1c <- getPOSIXTime - -- Decompress benchmark (decompress only, no compress overhead)- dRef <- newIORef undefined- t0d <- getPOSIXTime- mapM_ (\c ->- case decompress c of- Left e -> putStrLn ("error: " ++ show e)- Right !d -> do- _ <- evaluate (BS.length d)- writeIORef dRef d) compInputs- t1d <- getPOSIXTime- decompResult <- readIORef dRef- let totalDecompMs = realToFrac (t1d - t0d) * 1000 :: Double- decompSecs = realToFrac (t1d - t0d) / fromIntegral iters :: Double- putStrLn $ "decomp: " ++ show (BS.length decompResult) ++ " bytes -> "- ++ showMBps payloadMB decompSecs ++ " MB/s"- ++ " (total " ++ showMs totalDecompMs ++ "ms)"+ dRef <- newIORef (0 :: Int)+ t0d <- getPOSIXTime+ mapM_ (\c -> case decompress c of+ Left e -> error ("decode error in " ++ path ++ ": " ++ show e)+ Right !d -> writeIORef dRef =<< evaluate (BS.length d)) compreds+ t1d <- getPOSIXTime -showMBps :: Double -> Double -> String-showMBps mb secs = show (round (mb / secs) :: Int)+ let compSecs = realToFrac (t1c - t0c) :: Double+ decompSecs = realToFrac (t1d - t0d) :: Double+ printf "%-26s %8d %8.1f MB/s %8.1f MB/s\n"+ (baseName path) n (mb / compSecs) (mb / decompSecs)+ pure (mb, compSecs, decompSecs) -showMs :: Double -> String-showMs x = show (round x :: Int)+ let totMB = sum [m | (m, _, _) <- rows]+ totComp = sum [c | (_, c, _) <- rows]+ totDec = sum [d | (_, _, d) <- rows]+ putStrLn "--------------------------------------------------------------------"+ printf "AGGREGATE %8.1f MB/s %8.1f MB/s\n"+ (totMB / totComp) (totMB / totDec)++baseName :: FilePath -> FilePath+baseName = reverse . takeWhile (/= '/') . reverse
+ benchmark/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Codec.Compression.Snappy as Native+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Criterion.Main+import qualified Data.ByteString as BS+import Data.Either (fromRight)+import qualified Snappy as Hs++-- | Keep in sync with @benchmark/Bench.hs@.+corpus :: [(String, FilePath)]+corpus =+ [ ("newton", "./data/Isaac.Newton-Opticks.txt")+ , ("html", "./data/html")+ , ("alice29", "./data/alice29.txt")+ , ("protodata", "./data/geo.protodata")+ , ("urls", "./data/urls.10K")+ , ("jpeg", "./data/fireworks.jpeg")+ ]++main :: IO ()+main = do+ cases <- mapM loadCase corpus+ defaultMain+ [ bgroup name+ [ bgroup "compress"+ [ bench "hs" $ whnf (BS.length . Hs.compress) src+ , bench "native" $ whnf (BS.length . Native.compress) src+ ]+ , bgroup "decompress"+ [ bench "hs" $ whnf (BS.length . fromRight BS.empty . Hs.decompress) hsC+ , bench "native" $ whnf (BS.length . Native.decompress) natC+ ]+ ]+ | (name, src, hsC, natC) <- cases+ ]+ where+ loadCase (name, path) = do+ src <- BS.readFile path+ hsC <- evaluate (force (Hs.compress src))+ natC <- evaluate (force (Native.compress src))+ pure (name, src, hsC, natC)
snappy-hs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: snappy-hs-version: 0.1.1.0+version: 0.1.2.0 synopsis: Snappy compression library. description: A pure Haskell implementation of the Snappy compression spec. license: MIT@@ -28,6 +28,7 @@ , bytestring >= 0.11 && < 0.14 hs-source-dirs: src default-language: Haskell2010+ ghc-options: -O2 -fexpose-all-unfoldings -fspecialise-aggressively -funbox-strict-fields executable snappy-hs import: warnings@@ -60,18 +61,20 @@ build-depends: base >=4.11 && <5, bytestring >= 0.11 && < 0.14,+ deepseq >= 1.4 && < 1.6, time >= 1.14 && < 1.15, snappy-hs >= 0.1 && < 1 default-language: Haskell2010 ghc-options: -rtsopts --- benchmark snappy-benchmark--- type: exitcode-stdio-1.0--- main-is: Main.hs--- hs-source-dirs: benchmark--- build-depends: base >= 4.11 && < 5,--- criterion >= 1 && <= 1.6.4.0,--- bytestring >= 0.11 && < 0.14,--- snappy ^>= 0.2,--- snappy-hs--- default-language: Haskell2010+benchmark snappy-benchmark+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: benchmark+ build-depends: base >= 4.11 && < 5,+ criterion >= 1 && <= 1.6.4.0,+ bytestring >= 0.11 && < 0.14,+ deepseq >= 1.4 && < 1.6,+ snappy ^>= 0.2,+ snappy-hs+ default-language: Haskell2010
src/Snappy.hs view
@@ -11,37 +11,39 @@ ) where import Control.Exception (Exception)-import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))+import Data.Bits (countTrailingZeros, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.)) import Data.ByteString.Internal (ByteString (..)) import Data.Word (Word64) import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) import Foreign.Marshal.Utils (copyBytes, fillBytes) import Foreign.Ptr (Ptr)-import Foreign.Storable (sizeOf) import GHC.Exts ( Addr# , Int (..) , MutableByteArray# , Ptr (..) , RealWorld- , (+#) , eqWord8#+ , indexWord32OffAddr#+ , indexWord64OffAddr# , indexWord8OffAddr#+ , int2Word# , isTrue# , newByteArray#- , or# , plusAddr#- , readIntArray#+ , readWord32Array#+ , readWord64OffAddr# , readWord8OffAddr# , setByteArray#- , uncheckedShiftL#- , word8ToWord#+ , word2Int#+ , word32ToWord# , wordToWord32#- , writeIntArray#+ , writeWord32Array#+ , writeWord64OffAddr# , writeWord8OffAddr# ) import GHC.IO (IO (..))-import GHC.Word (Word32 (W32#), Word8 (W8#))+import GHC.Word (Word32 (W32#), Word64 (W64#), Word8 (W8#)) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -54,7 +56,7 @@ case vr of Left e -> pure (Left e) Right (outLen, hdrLen) -> do- outFp <- mallocForeignPtrBytes (max 1 outLen)+ outFp <- mallocForeignPtrBytes (max 1 (outLen + decompSlack)) withForeignPtr outFp $ \(Ptr outAddr#) -> do r <- decodeLoop srcAddr# hdrLen srcLen outAddr# 0 outLen case r of@@ -72,10 +74,12 @@ if srcLen < 4 then writeLiteral srcAddr# 0 srcLen outAddr# hdrLen else do- let !tableSize = 1 `unsafeShiftL` 15- !tableBytes = tableSize * sizeOfInt+ let !log2Size = tableLog2 srcLen+ !tableSize = 1 `unsafeShiftL` log2Size+ !tableBytes = tableSize * sizeOfSlot+ !shift = 32 - log2Size tbl <- newZeroedByteArray tableBytes- compressLoop srcAddr# srcLen tbl outAddr# hdrLen 0 0+ compressLoop srcAddr# srcLen tbl shift outAddr# hdrLen 0 0 pure (BS outFp written) @@ -130,7 +134,15 @@ if srcOff1 + litLen > srcEnd || outOff + litLen > outLen then pure (Left UnexpectedEOF) else do- copyBytes (atOff outAddr# outOff) (atOff srcAddr# srcOff1) litLen+ -- Wide copy for short literals: two 8-byte word+ -- writes overwrite up to 16 bytes, safe because the+ -- output buffer carries decompSlack and the source+ -- read is guarded to stay within srcEnd.+ if litLen <= 16 && srcOff1 + 16 <= srcEnd+ then do+ writeW64 outAddr# outOff =<< readW64M srcAddr# srcOff1+ writeW64 outAddr# (outOff + 8) =<< readW64M srcAddr# (srcOff1 + 8)+ else copyBytes (atOff outAddr# outOff) (atOff srcAddr# srcOff1) litLen go (srcOff1 + litLen) (outOff + litLen) outLen else do let !nb = hdr - 59@@ -184,49 +196,85 @@ go (srcOff1 + 4) (outOff + cpLen) outLen _ -> pure (Left InvalidTag) +-- | Hot compression loop, mirroring Snappy's @CompressFragment@. The outer+-- 'search' ramps the skip increment while probing the hash table; once a match+-- is found it hands off to the inner 'emit' loop, which keeps emitting copies+-- for back-to-back matches without restarting the skip ramp. compressLoop- :: Addr# -> Int -> HashTable+ :: Addr# -> Int -> HashTable -> Int -> Addr# -> Int -> Int -> Int -> IO Int-compressLoop !src !srcLen !tbl !dst !dstOff0 = go dstOff0+compressLoop !src !srcLen !tbl !shift !dst !dstOff0 !i0 !litStart0 =+ search dstOff0 (i0 + 1) litStart0 32 where- go :: Int -> Int -> Int -> IO Int- go !dstOff !i !litStart- | i + 3 >= srcLen = do- let !remLen = srcLen - litStart- if remLen > 0- then writeLiteral src litStart remLen dst dstOff- else pure dstOff+ -- @nextEmit@ is the first byte not yet emitted as a literal. @ip@ is the+ -- next candidate position to probe.+ search :: Int -> Int -> Int -> Int -> IO Int+ search !dstOff !ip !nextEmit !skip+ | ip + 4 > srcLen = finish dstOff nextEmit | otherwise = do- let !w = readU32LE src i- !h = hash32 w- prev0 <- readTbl tbl h- writeTbl tbl h (i + 1)- let !prev = prev0 - 1- if prev < 0- then go dstOff (i + 1) litStart+ let !w = readU32LE src ip+ !h = hash32 shift w+ cand0 <- readTbl tbl h+ writeTbl tbl h (ip + 1)+ let !cand = cand0 - 1+ !nextIp = ip + (skip `unsafeShiftR` 5)+ if cand < 0 || readU32LE src cand /= w+ then search dstOff nextIp nextEmit (skip + 1) else do- let !pw = readU32LE src prev- if pw /= w- then go dstOff (i + 1) litStart- else do- dstOff' <-- if i > litStart- then writeLiteral src litStart (i - litStart) dst dstOff- else pure dstOff- let !extra = extendMatch src (i + 4) (prev + 4) srcLen- !matchLen = 4 + extra- !offset = i - prev- dstOff'' <- writeCopies offset matchLen dst dstOff'- let !i' = i + matchLen- go dstOff'' i' i'+ dstOff' <-+ if ip > nextEmit+ then writeLiteralFast src nextEmit (ip - nextEmit) srcLen dst dstOff+ else pure dstOff+ emit dstOff' ip cand + -- Match found at @ip@ against @cand@: emit the copy, then probe the+ -- position right after the match to chain consecutive matches.+ emit :: Int -> Int -> Int -> IO Int+ emit !dstOff !ip !cand = do+ let !extra = extendMatch src (ip + 4) (cand + 4) srcLen+ !matchLen = 4 + extra+ !offset = ip - cand+ !ipEnd = ip + matchLen+ dstOff' <- writeCopies offset matchLen dst dstOff+ if ipEnd + 4 > srcLen+ then finish dstOff' ipEnd+ else do+ -- Insert hash for the position just before the match end so it+ -- is available to later probes, then check the match-end word.+ let !wPrev = readU32LE src (ipEnd - 1)+ writeTbl tbl (hash32 shift wPrev) ipEnd+ let !w = readU32LE src ipEnd+ !h = hash32 shift w+ cand0 <- readTbl tbl h+ writeTbl tbl h (ipEnd + 1)+ let !cand' = cand0 - 1+ if cand' >= 0 && readU32LE src cand' == w+ then emit dstOff' ipEnd cand'+ else search dstOff' (ipEnd + 1) ipEnd 32++ finish :: Int -> Int -> IO Int+ finish !dstOff !nextEmit =+ let !remLen = srcLen - nextEmit+ in if remLen > 0+ then writeLiteral src nextEmit remLen dst dstOff+ else pure dstOff+ -- | Extend a match as far as possible; pure since source is immutable. extendMatch :: Addr# -> Int -> Int -> Int -> Int extendMatch addr# a0 b0 limit = go 0 where go :: Int -> Int go !n+ -- 8-byte fast path: compare native-endian words, then locate the first+ -- differing byte via trailing-zero count (little-endian byte order).+ | a0 + n + 8 <= limit && b0 + n + 8 <= limit =+ let !wa = readW64 addr# (a0 + n)+ !wb = readW64 addr# (b0 + n)+ !x = wa `xor` wb+ in if x == 0+ then go (n + 8)+ else n + (countTrailingZeros x `unsafeShiftR` 3) | a0 + n >= limit || b0 + n >= limit = n | otherwise = let !(I# an#) = a0 + n@@ -238,7 +286,11 @@ else n {-# INLINE extendMatch #-} +{-# INLINE readW64 #-}+readW64 :: Addr# -> Int -> Word64+readW64 addr# (I# i#) = W64# (indexWord64OffAddr# (plusAddr# addr# i#) 0#) + {-# INLINE readLEn #-} readLEn :: Addr# -> Int -> Int -> IO Int readLEn !addr# !off !n@@ -263,25 +315,49 @@ | otherwise = go (acc .|. (fromIntegral (ixByte addr# (off + k)) `unsafeShiftL` (k * 8))) (k + 1) --- | Read a 32-bit little-endian word; pure since source is immutable.+-- | Read a 32-bit little-endian word as a single native load; pure since the+-- source is immutable. Relies on little-endian byte order, matching the 64-bit+-- word loads used elsewhere (e.g. 'extendMatch'). {-# INLINE readU32LE #-} readU32LE :: Addr# -> Int -> Word32 readU32LE addr# (I# i#) =- let b0 = word8ToWord# (indexWord8OffAddr# addr# i#)- b1 = word8ToWord# (indexWord8OffAddr# addr# (i# +# 1#))- b2 = word8ToWord# (indexWord8OffAddr# addr# (i# +# 2#))- b3 = word8ToWord# (indexWord8OffAddr# addr# (i# +# 3#))- w = b0 `or#` (b1 `uncheckedShiftL#` 8#)- `or#` (b2 `uncheckedShiftL#` 16#)- `or#` (b3 `uncheckedShiftL#` 24#)- in W32# (wordToWord32# w)+ W32# (indexWord32OffAddr# (plusAddr# addr# i#) 0#) {-# INLINE hash32 #-}-hash32 :: Word32 -> Int-hash32 !w =+hash32 :: Int -> Word32 -> Int+hash32 !shift !w = let !kMul = 0x1e35a7bd :: Word32- in fromIntegral ((w * kMul) `unsafeShiftR` (32 - 15))+ in fromIntegral ((w * kMul) `unsafeShiftR` shift) +-- | log2 of the hash-table size: smallest power of two >= srcLen, with the+-- exponent clamped to [8, 14] (matching C snappy's kMaxHashTableBits). Sizing+-- the table to the input avoids zeroing a large table for small inputs, and the+-- 14-bit cap keeps it cache-resident.+{-# INLINE tableLog2 #-}+tableLog2 :: Int -> Int+tableLog2 !srcLen = go 8+ where+ go !k+ | k >= 14 = 14+ | (1 `unsafeShiftL` k) >= srcLen = k+ | otherwise = go (k + 1)++-- | Hot-loop literal emitter. For short literals it writes the 1-byte tag plus+-- two blind 8-byte word copies (up to 16 bytes). The source over-read is guarded+-- against @srcLen@; the destination over-write lands inside the compressor's+-- 64-byte output slack, so it never escapes the allocation. Longer or+-- end-of-source literals fall back to 'writeLiteral'.+writeLiteralFast :: Addr# -> Int -> Int -> Int -> Addr# -> Int -> IO Int+writeLiteralFast !src !off !len !srcLen !dst !dstOff+ | len <= 16 && off + 16 <= srcLen = do+ let !tag = fromIntegral ((len - 1) `unsafeShiftL` 2) :: Word8+ writeW8 dst dstOff tag+ writeW64 dst (dstOff + 1) =<< readW64M src off+ writeW64 dst (dstOff + 9) =<< readW64M src (off + 8)+ pure (dstOff + 1 + len)+ | otherwise = writeLiteral src off len dst dstOff+{-# INLINE writeLiteralFast #-}+ writeLiteral :: Addr# -> Int -> Int -> Addr# -> Int -> IO Int writeLiteral _ _ 0 _ !dstOff = pure dstOff writeLiteral !src !off !len !dst !dstOff@@ -367,14 +443,29 @@ {-# INLINE copyOverlap #-} copyOverlap :: Addr# -> Int -> Int -> Int -> IO () copyOverlap !base !outOff !offset !len+ -- Non-overlapping short copy: two blind 8-byte word writes cover up to 16+ -- bytes. The reads stay within the buffer (srcStart >= 0) and the over-write+ -- past `len` lands inside decompSlack, so this never escapes the allocation.+ | offset >= len && len <= 16 = do+ writeW64 base outOff =<< readW64M base srcStart+ writeW64 base (outOff + 8) =<< readW64M base (srcStart + 8) | offset >= len = copyBytes (atOff base outOff) (atOff base srcStart) len | offset == 1 = do b <- readW8 base srcStart fillBytes (atOff base outOff) b len+ -- Overlapping copy with offset >= 8: each 8-byte read at srcStart+i ends at+ -- outOff-offset+i+7 < outOff+i (the current write cursor), so it only ever+ -- reads already-written bytes. The trailing over-write lands in decompSlack.+ | offset >= 8 = goWide 0 | otherwise = go 0 where !srcStart = outOff - offset+ goWide !i+ | i >= len = pure ()+ | otherwise = do+ writeW64 base (outOff + i) =<< readW64M base (srcStart + i)+ goWide (i + 8) go !i | i >= len = pure () | otherwise = do@@ -382,9 +473,10 @@ writeW8 base (outOff + i) b go (i + 1) -sizeOfInt :: Int-sizeOfInt = sizeOf (0 :: Int)-{-# INLINE sizeOfInt #-}+-- | Bytes per hash-table slot (32-bit positions).+sizeOfSlot :: Int+sizeOfSlot = 4+{-# INLINE sizeOfSlot #-} -- | Lifted wrapper around an unlifted 'MutableByteArray#'. data HashTable = HashTable (MutableByteArray# RealWorld)@@ -409,17 +501,18 @@ s2 -> (# s2, HashTable arr #) {-# INLINE newZeroedByteArray #-} --- | Read the Int at slot index @i@ (each slot is one machine Int).+-- | Read the slot at index @i@. Slots are 32-bit: positions fit in a Word32+-- for every supported input size, and the smaller table improves cache locality. readTbl :: HashTable -> Int -> IO Int readTbl (HashTable arr) (I# i#) = IO $ \s ->- case readIntArray# arr i# s of- (# s', v# #) -> (# s', I# v# #)+ case readWord32Array# arr i# s of+ (# s', v# #) -> (# s', I# (word2Int# (word32ToWord# v#)) #) {-# INLINE readTbl #-} --- | Write an Int to slot index @i@.+-- | Write a position to slot index @i@ (truncated to 32 bits). writeTbl :: HashTable -> Int -> Int -> IO () writeTbl (HashTable arr) (I# i#) (I# v#) = IO $ \s ->- case writeIntArray# arr i# v# s of+ case writeWord32Array# arr i# (wordToWord32# (int2Word# v#)) s of s' -> (# s', () #) {-# INLINE writeTbl #-} @@ -427,6 +520,26 @@ ixByte :: Addr# -> Int -> Word8 ixByte addr# (I# i#) = W8# (indexWord8OffAddr# addr# i#) {-# INLINE ixByte #-}++-- | Slack bytes over-allocated past the logical output length so wide+-- (8-byte) writes in the literal fast path never run off the buffer.+decompSlack :: Int+decompSlack = 32+{-# INLINE decompSlack #-}++-- | Mutable read: one native-endian 8-byte word from an address.+readW64M :: Addr# -> Int -> IO Word64+readW64M addr# (I# i#) = IO $ \s ->+ case readWord64OffAddr# (plusAddr# addr# i#) 0# s of+ (# s', w# #) -> (# s', W64# w# #)+{-# INLINE readW64M #-}++-- | Write one native-endian 8-byte word to an address.+writeW64 :: Addr# -> Int -> Word64 -> IO ()+writeW64 addr# (I# i#) (W64# w#) = IO $ \s ->+ case writeWord64OffAddr# (plusAddr# addr# i#) 0# w# s of+ s' -> (# s', () #)+{-# INLINE writeW64 #-} -- | Mutable read: one byte from a (possibly mutable) address. readW8 :: Addr# -> Int -> IO Word8
test/Main.hs view
@@ -1,23 +1,70 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Monad (forM_, unless) import qualified Data.ByteString as BS+import Data.IORef+import Data.Word (Word8, Word64) import Snappy+import System.Exit (exitFailure) main :: IO () main = do+ fails <- newIORef (0 :: Int)+ let roundTrip label bs = case decompress (compress bs) of+ Left e -> bad fails (label ++ ": decode error: " ++ show e)+ Right d+ | d == bs -> putStrLn ("OK: " ++ label)+ | otherwise -> bad fails (label ++ ": round-trip mismatch")+ rejects label bs = case decompress bs of+ Left _ -> putStrLn ("OK: " ++ label)+ Right _ -> bad fails (label ++ ": expected decode error, got success")++ -- Original smoke cases. roundTrip "short repetitive" (BS.replicate 100 65) roundTrip "single byte" "x" roundTrip "short string" "Hello, world!" roundTrip "longer repetitive" (BS.replicate 1000 65) roundTrip "varied" "Hello, Snappy! Hello, Snappy! ABCDEFGHIJKLMNOP 1234567890" roundTrip "already compressed-like" (BS.pack [0..255])- putStrLn "All tests passed." -roundTrip :: String -> BS.ByteString -> IO ()-roundTrip label bs =- case decompress (compress bs) of- Left e -> fail $ label ++ ": decode error: " ++ show e- Right d -> if d == bs- then putStrLn $ "OK: " ++ label- else fail $ label ++ ": round-trip mismatch"+ -- Sizes around the literal/copy/word-copy boundaries exercised by the fast+ -- paths (60-byte literal tag, 16-byte wide copy, 2KB copy-offset classes).+ forM_ [0,1,2,3,4,5,15,16,17,59,60,61,63,64,65,255,256,257,2047,2048,2049+ ,65535,65536,65537,200000] $ \n -> do+ roundTrip ("run " ++ show n) (BS.replicate n 88)+ roundTrip ("periodic " ++ show n) (BS.take n (cycleBS "abcdefgh/" n))+ roundTrip ("incompressible " ++ show n) (lcg n)++ -- A long, highly self-similar input drives overlapping copies of every class.+ roundTrip "mixed large" (BS.concat (replicate 4000 "the quick brown fox 0123456789 "))++ -- Malformed streams must error, never crash.+ rejects "empty" BS.empty+ rejects "truncated varint" (BS.pack [0x80])+ rejects "copy offset past output" (BS.pack [0x08, 0xfc, 0x00])+ rejects "literal length exceeds input" (BS.pack [0x04, 0xf0])+ rejects "truncated 4-byte literal" (BS.pack [0xfe, 0x00, 0x00])++ n <- readIORef fails+ if n == 0+ then putStrLn "All tests passed."+ else putStrLn (show n ++ " tests failed.") >> exitFailure++bad :: IORef Int -> String -> IO ()+bad ref msg = modifyIORef' ref (+ 1) >> putStrLn ("FAIL: " ++ msg)++-- Repeat @pat@ until at least @n@ bytes are available.+cycleBS :: BS.ByteString -> Int -> BS.ByteString+cycleBS pat n+ | BS.null pat = BS.empty+ | otherwise = BS.concat (replicate (n `div` BS.length pat + 1) pat)++-- Deterministic pseudo-random bytes (LCG); no external deps.+lcg :: Int -> BS.ByteString+lcg n = fst (BS.unfoldrN n step 0x2545F4914F6CDD1D)+ where+ step :: Word64 -> Maybe (Word8, Word64)+ step s =+ let s' = s * 6364136223846793005 + 1442695040888963407+ in Just (fromIntegral (s' `div` 0x100000000), s')