diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # lz4 +## 0.1.5.0 + + * Export single-threaded block compression functions + * Avoid passing unitialized memory to the caller + ## 0.1.4.1 * Use `lZ4DecompressionContextFree` correctly diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -11,6 +11,12 @@ BSL.writeFile (dir "dump.tar") =<< (decompress <$> BSL.readFile fp') +decompressFile :: FilePath -> IO () +decompressFile fp' = forceBSL =<< + (decompress <$> BSL.readFile fp') + + where forceBSL = (`seq` mempty) . last . BSL.toChunks + compressDump :: FilePath -> FilePath -> IO () compressDump dir fp' = BSL.writeFile (dir "dump.tar.lz4") =<< @@ -22,6 +28,11 @@ defaultMain [ bgroup "decompress/dump" [ bench "lz4" $ nfIO (decompressDump dir "valgrind-3.15.0.tar.lz4") , bench "lz4" $ nfIO (decompressDump dir "llvm-9.0.0.src.tar.lz4") + ] + -- file writes on linux are slow? + , bgroup "decompress/file" + [ bench "lz4" $ nfIO (decompressFile "valgrind-3.15.0.tar.lz4") + , bench "lz4" $ nfIO (decompressFile "llvm-9.0.0.src.tar.lz4") ] , env lz4Files $ \ ~(v, l) -> bgroup "decompress" diff --git a/lz4-hs.cabal b/lz4-hs.cabal --- a/lz4-hs.cabal +++ b/lz4-hs.cabal @@ -1,7 +1,7 @@ -cabal-version: 1.18 +cabal-version: 2.2 name: lz4-hs -version: 0.1.4.1 -license: BSD3 +version: 0.1.5.0 +license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale maintainer: vamchale@gmail.com @@ -25,6 +25,7 @@ library exposed-modules: Codec.Lz4 + cc-options: -O3 c-sources: cbits/lz4.c cbits/lz4frame.c @@ -39,14 +40,11 @@ install-includes: cbits/lz4.h cbits/lz4frame.h cbits/lz4hc.h cbits/xxhash.h - ghc-options: -Wall + ghc-options: -Wall -Wall build-depends: - base >=4.8 && <5, + base >=4.7 && <5, bytestring -any - if !flag(cross) - build-tool-depends: c2hs:c2hs >=0.28.6 - if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -55,15 +53,21 @@ if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists + if impl(ghc >=8.2) + ghc-options: -Wcpp-undef + if impl(ghc >=8.10) ghc-options: -Wunused-packages + if !flag(cross) + build-tool-depends: c2hs:c2hs >=0.28.6 + test-suite lz4-test type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test default-language: Haskell2010 - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base -any, lz4-hs -any, @@ -74,7 +78,7 @@ if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + -Wredundant-constraints if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists @@ -99,8 +103,16 @@ temporary -any if impl(ghc >=8.0) - ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates + ghc-options: + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >=8.4) + ghc-options: -Wmissing-export-lists + + if impl(ghc >=8.2) + ghc-options: -Wcpp-undef + if impl(ghc >=8.10) ghc-options: -Wunused-packages @@ -121,7 +133,7 @@ if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + -Wredundant-constraints if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists diff --git a/src/Codec/Lz4.chs b/src/Codec/Lz4.chs --- a/src/Codec/Lz4.chs +++ b/src/Codec/Lz4.chs @@ -5,9 +5,12 @@ -- 'decompress' and 'compress' are fully lazy, i.e. memory efficient. module Codec.Lz4 ( -- * Functions for working with blocks compressBlock + , compressBlockSingleThreaded , decompressBlockSz + , decompressBlockSzSingleThreaded , lZ4MaxInputSize , compressBlockHC + , compressBlockHCSingleThreaded , lZ4HCClevelMax -- * Functions for working with frames , compress @@ -20,6 +23,7 @@ ) where import Codec.Lz4.Foreign +import Control.Applicative import Control.Monad (when) import Control.Monad.ST.Lazy (runST) import qualified Control.Monad.ST.Lazy as LazyST @@ -36,7 +40,7 @@ newForeignPtr, withForeignPtr) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (peek, poke) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) #include @@ -146,15 +150,37 @@ {-# NOINLINE compressBlock #-} compressBlock :: BS.ByteString -> BS.ByteString -compressBlock = unsafePerformIO . compressBlockGeneric lZ4CompressDefault +compressBlock = unsafePerformIO . compressBlockIO +-- | Like 'compressBlock' but uses 'unsafeDupablePerformIO' under the hood. +-- +-- @since 0.1.5.0 +compressBlockSingleThreaded :: BS.ByteString -> BS.ByteString +compressBlockSingleThreaded = unsafeDupablePerformIO . compressBlockIO +{-# NOINLINE compressBlockSingleThreaded #-} + +compressBlockIO :: BS.ByteString -> IO BS.ByteString +compressBlockIO = compressBlockGeneric lZ4CompressDefault + {-# NOINLINE compressBlockHC #-} -- | @since 0.1.1.0 compressBlockHC :: Int -- ^ Compression level (must be less than 'lZ4HCClevelMax') -> BS.ByteString -> BS.ByteString -compressBlockHC lvl = unsafePerformIO . compressBlockGeneric (\src dst ssz dsz -> lZ4CompressHC src dst ssz dsz (fromIntegral lvl)) +compressBlockHC lvl = unsafePerformIO . compressBlockHCIO lvl +-- | Like 'compressBlockHC' except uses 'unsafeDupablePerformIO' under the hood. +-- +-- @since 0.1.5.0 +compressBlockHCSingleThreaded :: Int -- ^ Compression level (must be less than 'lZ4HCClevelMax') + -> BS.ByteString + -> BS.ByteString +compressBlockHCSingleThreaded lvl = unsafeDupablePerformIO . compressBlockHCIO lvl +{-# NOINLINE compressBlockHCSingleThreaded #-} + +compressBlockHCIO :: Int -> BS.ByteString -> IO BS.ByteString +compressBlockHCIO lvl = compressBlockGeneric (\src dst ssz dsz -> lZ4CompressHC src dst ssz dsz (fromIntegral lvl)) + compressBlockGeneric :: (CString -> CString -> CInt -> CInt -> IO CInt) -> BS.ByteString -> IO BS.ByteString compressBlockGeneric cfun bs = BS.unsafeUseAsCStringLen bs $ \(buf, sz) -> do @@ -170,13 +196,30 @@ decompressBlockSz :: BS.ByteString -> Int -- ^ Decompressed size -> BS.ByteString -decompressBlockSz bs expectedSz = unsafePerformIO $ +decompressBlockSz bs sz = unsafePerformIO $ decompressBlockSzIO bs sz + +-- | Decompress a block. Like 'decompressBlockSz' but uses 'unsafeDupablePerformIO' under the hood. +-- +-- @since 0.1.5.0 +decompressBlockSzSingleThreaded :: BS.ByteString + -> Int -- ^ Decompressed size + -> BS.ByteString +decompressBlockSzSingleThreaded bs sz = unsafeDupablePerformIO $ decompressBlockSzIO bs sz +{-# NOINLINE decompressBlockSzSingleThreaded #-} + +-- | Decompress a block. The size of the uncompressed data must be known. +decompressBlockSzIO :: BS.ByteString + -> Int -- ^ Decompressed size + -> IO BS.ByteString +decompressBlockSzIO bs expectedSz = BS.unsafeUseAsCStringLen bs $ \(buf, sz) -> do dst <- mallocForeignPtrBytes expectedSz - withForeignPtr dst $ \d -> do + bWritten <- withForeignPtr dst $ \d -> do bWritten <- lZ4DecompressSafe buf d (fromIntegral sz) (fromIntegral expectedSz) when (bWritten < 0) $ error "Decompression error" - pure $ BS.fromForeignPtr (castForeignPtr dst) 0 expectedSz + pure bWritten + let buffer = BS.fromForeignPtr (castForeignPtr dst) 0 expectedSz + pure $ BS.take (fromIntegral bWritten) buffer cint :: Enum a => a -> CInt cint = fromIntegral . fromEnum diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,7 +17,7 @@ testRoundtripBlocks fp = testCase ("Roundtrip " ++ fp) $ do contents <- BS.readFile fp let sz = BS.length contents - actual = decompressBlockSz (compressBlock contents) sz + actual = decompressBlockSzSingleThreaded (compressBlockSingleThreaded contents) sz actual @?= contents testRoundtripFrames :: FilePath -> TestTree