diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -71,7 +71,7 @@ -- on the 'extract' function where we use decompression in the pipeline: -- -- > import qualified Data.ByteString.Lazy as BL - -- > import qualified Codec.Compression.Zlib as GZip + -- > import qualified Codec.Compression.GZip as GZip -- > -- > Tar.unpack dir . Tar.read . GZip.decompress =<< BL.readFile tar -- diff --git a/Codec/Archive/Tar/Index/IntTrie.hs b/Codec/Archive/Tar/Index/IntTrie.hs --- a/Codec/Archive/Tar/Index/IntTrie.hs +++ b/Codec/Archive/Tar/Index/IntTrie.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards #-} {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} module Codec.Archive.Tar.Index.IntTrie ( @@ -55,7 +57,10 @@ import Data.List hiding (lookup, insert) import Data.Function (on) +import GHC.IO +import Codec.Archive.Tar.Index.Utils + -- | A compact mapping from sequences of nats to nats. -- -- NOTE: The tries in this module have values /only/ at the leaves (which @@ -338,19 +343,11 @@ , let lenArr = readWord32BE bs 0 lenTotal = 4 + 4 * fromIntegral lenArr , BS.length bs >= 4 + 4 * fromIntegral lenArr - , let !arr = A.array (0, lenArr-1) - [ (i, readWord32BE bs off) - | (i, off) <- zip [0..lenArr-1] [4,8 .. lenTotal - 4] ] - !bs' = BS.drop lenTotal bs - = Just (IntTrie arr, bs') + , let !bs_without_len = BS.unsafeDrop 4 bs + !bs_remaining = BS.unsafeDrop lenTotal bs + !arr = unsafePerformIO $ beToLe lenArr bs_without_len + = Just (IntTrie arr, bs_remaining) | otherwise = Nothing -readWord32BE :: BS.ByteString -> Int -> Word32 -readWord32BE bs i = - assert (i >= 0 && i+3 <= BS.length bs - 1) $ - fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24 - + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16 - + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8 - + fromIntegral (BS.unsafeIndex bs (i + 3)) diff --git a/Codec/Archive/Tar/Index/Internal.hs b/Codec/Archive/Tar/Index/Internal.hs --- a/Codec/Archive/Tar/Index/Internal.hs +++ b/Codec/Archive/Tar/Index/Internal.hs @@ -63,6 +63,7 @@ import qualified Codec.Archive.Tar.Index.StringTable as StringTable import Codec.Archive.Tar.Index.StringTable (StringTable, StringTableBuilder) import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie +import Codec.Archive.Tar.Index.Utils (readWord32BE) import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder) import Codec.Archive.Tar.PackAscii @@ -496,27 +497,19 @@ | let ver = readWord32BE bs 0 , ver == 1 - = do let !finalOffset = readWord32BE bs 4 - (stringTable, bs') <- StringTable.deserialiseV1 (BS.drop 8 bs) + = do let !finalOffset = readWord32BE bs 1 + (stringTable, bs') <- StringTable.deserialiseV1 (BS.unsafeDrop 8 bs) (intTrie, bs'') <- IntTrie.deserialise bs' return (TarIndex stringTable intTrie finalOffset, bs'') | let ver = readWord32BE bs 0 , ver == 2 - = do let !finalOffset = readWord32BE bs 4 - (stringTable, bs') <- StringTable.deserialiseV2 (BS.drop 8 bs) + = do let !finalOffset = readWord32BE bs 1 + (stringTable, bs') <- StringTable.deserialiseV2 (BS.unsafeDrop 8 bs) (intTrie, bs'') <- IntTrie.deserialise bs' return (TarIndex stringTable intTrie finalOffset, bs'') | otherwise = Nothing - -readWord32BE :: BS.ByteString -> Int -> Word32 -readWord32BE bs i = - assert (i >= 0 && i+3 <= BS.length bs - 1) $ - fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24 - + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16 - + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8 - + fromIntegral (BS.unsafeIndex bs (i + 3)) toStrict :: LBS.ByteString -> BS.ByteString toStrict = LBS.toStrict diff --git a/Codec/Archive/Tar/Index/StringTable.hs b/Codec/Archive/Tar/Index/StringTable.hs --- a/Codec/Archive/Tar/Index/StringTable.hs +++ b/Codec/Archive/Tar/Index/StringTable.hs @@ -37,6 +37,7 @@ import Control.Exception (assert) import qualified Data.Array.Unboxed as A +import qualified Data.Array.Base as A import Data.Array.Unboxed ((!)) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) @@ -45,7 +46,11 @@ import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Builder as BS import Data.ByteString.Builder.Extra as BS (byteStringCopy) +import GHC.IO (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) +import Codec.Archive.Tar.Index.Utils + -- | An efficient mapping from strings to a dense set of integers. -- data StringTable id = StringTable @@ -169,10 +174,10 @@ deserialiseV1 bs | BS.length bs >= 8 , let lenStrs = fromIntegral (readWord32BE bs 0) - lenArr = fromIntegral (readWord32BE bs 4) + lenArr = fromIntegral (readWord32BE bs 1) lenTotal= 8 + lenStrs + 4 * lenArr , BS.length bs >= lenTotal - , let strs = BS.take lenStrs (BS.drop 8 bs) + , let strs = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs) arr = A.array (0, fromIntegral lenArr - 1) [ (i, readWord32BE bs off) | (i, off) <- zip [0 .. fromIntegral lenArr - 1] @@ -194,41 +199,32 @@ deserialiseV2 bs | BS.length bs >= 8 , let lenStrs = fromIntegral (readWord32BE bs 0) - lenArr = fromIntegral (readWord32BE bs 4) + lenArr = fromIntegral (readWord32BE bs 1) lenTotal= 8 -- the two length prefixes + lenStrs + 4 * lenArr +(4 * (lenArr - 1)) * 2 -- offsets array is 1 longer , BS.length bs >= lenTotal - , let strs = BS.take lenStrs (BS.drop 8 bs) - offs = A.listArray (0, fromIntegral lenArr - 1) - [ readWord32BE bs off - | off <- offsets offsOff ] - -- the second two arrays are 1 shorter - ids = A.listArray (0, fromIntegral lenArr - 2) - [ readInt32BE bs off - | off <- offsets idsOff ] - ixs = A.listArray (0, fromIntegral lenArr - 2) - [ readInt32BE bs off - | off <- offsets ixsOff ] - offsOff = 8 + lenStrs - idsOff = offsOff + 4 * lenArr - ixsOff = idsOff + 4 * (lenArr-1) - offsets from = [from,from+4 .. from + 4 * (lenArr - 1)] + , let strs = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs) + offs_bs = BS.unsafeDrop (8 + lenStrs) bs + ids_bs = BS.unsafeDrop (lenArr * 4) offs_bs + ixs_bs = BS.unsafeDrop ((lenArr - 1) * 4) ids_bs + + castArray :: A.UArray i Word32 -> A.UArray i Int32 + castArray (A.UArray a b c d) = (A.UArray a b c d) + + -- Bangs are crucial for this to work in spite of unsafePerformIO! + (offs, ids, ixs) = unsafePerformIO $ do + !r1 <- beToLe (fromIntegral lenArr) offs_bs + !r2 <- castArray <$> beToLe (fromIntegral lenArr - 1) ids_bs + !r3 <- castArray <$> beToLe (fromIntegral lenArr - 1) ixs_bs + return (r1, r2, r3) + + !stringTable = StringTable strs offs ids ixs - !bs' = BS.drop lenTotal bs - = Just (stringTable, bs') + !bs_left = BS.drop lenTotal bs + = Just (stringTable, bs_left) | otherwise = Nothing -readInt32BE :: BS.ByteString -> Int -> Int32 -readInt32BE bs i = fromIntegral (readWord32BE bs i) - -readWord32BE :: BS.ByteString -> Int -> Word32 -readWord32BE bs i = - assert (i >= 0 && i+3 <= BS.length bs - 1) $ - fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24 - + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16 - + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8 - + fromIntegral (BS.unsafeIndex bs (i + 3)) diff --git a/Codec/Archive/Tar/Index/Utils.hs b/Codec/Archive/Tar/Index/Utils.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Tar/Index/Utils.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-} +module Codec.Archive.Tar.Index.Utils where + +import Data.ByteString as BS +import Control.Exception (assert) + +import Data.ByteString.Internal (ByteString(..), unsafeWithForeignPtr, accursedUnutterablePerformIO) +import GHC.Int (Int(..), Int32) +import GHC.Word (Word32(..), byteSwap32) +import Foreign.Storable (peek) +import GHC.Ptr (castPtr, plusPtr, Ptr) +import GHC.Exts +import GHC.IO (IO(..), unsafePerformIO) +import Data.Array.Base +import Data.Array.IO.Internals (unsafeFreezeIOUArray) +import Control.DeepSeq (NFData(..)) +import GHC.Storable +import GHC.ByteOrder + +#include + +-- | Construct a `UArray Word32 Word32` from a ByteString of 32bit big endian +-- words. +-- +-- Note: If using `unsafePerformIO`, be sure to force the result of running the +-- IO action right away... (e.g. see calls to beToLe in StringTable) +beToLe :: (Integral i, Num i) => i + -- ^ The total array length (the number of 32bit words in the array) + -> BS.ByteString + -- ^ The bytestring from which the UArray is constructed. + -- The content must start in the first byte! (i.e. the meta-data words + -- that shouldn't be part of the array, must have been dropped already) + -> IO (UArray i Word32) +beToLe lenArr (BS fptr _) = do + unsafeWithForeignPtr fptr $ \ptr -> do + let ptr' = castPtr ptr :: Ptr Word32 + !(I# lenBytes#) = fromIntegral (lenArr * 4) + + -- In spirit, the following does this, but we can't use `newGenArray` + -- because it only has been introduced in later versions of array: + -- @@ + -- unsafeFreezeIOUArray =<< + -- newGenArray (0, lenArr - 1) (\offset -> do + -- byteSwap32 <$> peek (ptr' `plusPtr` (fromIntegral offset * 4))) + -- @@ + IO $ \rw0 -> + case newByteArray# lenBytes# rw0 of + (# rw1, mba# #) -> + + let loop :: Int -> State# RealWorld -> State# RealWorld + loop !offset st + | offset < fromIntegral lenArr + = let IO getV = readWord32OffPtrBE ptr' offset + !(I# o#) = offset + in case getV st of + (# st', W32# v# #) -> + loop (offset + 1) (writeWord32Array# mba# o# v# st') + | otherwise = st + + in case unsafeFreezeByteArray# mba# (loop 0 rw1) of + (# rw2, ba# #) -> (# rw2, UArray 0 (lenArr - 1) (fromIntegral lenArr) ba# #) + +{-# SPECIALISE beToLe :: Word32 -> BS.ByteString -> IO (UArray Word32 Word32) #-} +{-# SPECIALISE beToLe :: Int32 -> BS.ByteString -> IO (UArray Int32 Word32) #-} + +readInt32BE :: BS.ByteString -> Int -> Int32 +readInt32BE bs i = fromIntegral (readWord32BE bs i) +{-# INLINE readInt32BE #-} + +readWord32OffPtrBE :: Ptr Word32 -> Int -> IO Word32 +readWord32OffPtrBE ptr i = do +#if defined(WORDS_BIGENDIAN) + readWord32OffPtr ptr i +#else + byteSwap32 <$> readWord32OffPtr ptr i +#endif + +readWord32BE :: BS.ByteString -> Int -> Word32 +readWord32BE (BS fptr len) i = + assert (i >= 0 && i+3 <= len - 1) $ + accursedUnutterablePerformIO $ + unsafeWithForeignPtr fptr $ \ptr -> do + readWord32OffPtrBE (castPtr ptr) i +{-# INLINE readWord32BE #-} diff --git a/Codec/Archive/Tar/Write.hs b/Codec/Archive/Tar/Write.hs --- a/Codec/Archive/Tar/Write.hs +++ b/Codec/Archive/Tar/Write.hs @@ -64,10 +64,11 @@ LBS.fromStrict $ BS.take 148 block <> putOct 7 checksum - <> BS.Char8.cons ' ' (BS.drop 156 block) + <> BS.cons 0x20 (BS.drop 156 block) where block = putHeaderNoChkSum entry - checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block + checksum :: Int + checksum = BS.foldl' (\x y -> x + fromIntegral y) 0 block putHeaderNoChkSum :: Entry -> BS.ByteString putHeaderNoChkSum Entry { @@ -86,33 +87,33 @@ , putOct 8 $ groupId ownership , numField 12 contentSize , putOct 12 modTime - , BS.Char8.replicate 8 ' ' -- dummy checksum + , BS.replicate 8 0x20 -- dummy checksum , putChar8 typeCode , putPosixString 100 linkTarget ] <> case format of V7Format -> - BS.Char8.replicate 255 '\NUL' - UstarFormat -> BS.Char8.concat + BS.replicate 255 0x00 + UstarFormat -> BS.concat [ putBString 8 ustarMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putOct 8 deviceMajor , putOct 8 deviceMinor , putPosixString 155 prefix - , BS.Char8.replicate 12 '\NUL' + , BS.replicate 12 0x00 ] - GnuFormat -> BS.Char8.concat + GnuFormat -> BS.concat [ putBString 8 gnuMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putGnuDev 8 deviceMajor , putGnuDev 8 deviceMinor , putPosixString 155 prefix - , BS.Char8.replicate 12 '\NUL' + , BS.replicate 12 0x00 ] where - numField :: FieldWidth -> Int64 -> BS.Char8.ByteString + numField :: FieldWidth -> Int64 -> BS.ByteString numField w n | n >= 0 && n < 1 `shiftL` (3 * (w - 1)) = putOct w n @@ -133,24 +134,24 @@ putGnuDev w n = case content of CharacterDevice _ _ -> putOct w n BlockDevice _ _ -> putOct w n - _ -> BS.Char8.replicate w '\NUL' + _ -> BS.replicate w 0x00 ustarMagic, gnuMagic :: BS.ByteString -ustarMagic = BS.Char8.pack "ustar\NUL00" -gnuMagic = BS.Char8.pack "ustar \NUL" +ustarMagic = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x00, 0x30, 0x30] -- ustar\NUL00 +gnuMagic = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x20, 0x20, 0x00] -- ustar \NUL -- * TAR format primitive output type FieldWidth = Int putBString :: FieldWidth -> BS.ByteString -> BS.ByteString -putBString n s = BS.take n s <> BS.Char8.replicate (n - BS.length s) '\NUL' +putBString n s = BS.take n s <> BS.replicate (n - BS.length s) 0x00 putPosixString :: FieldWidth -> PosixString -> BS.ByteString -putPosixString n s = posixToByteString (PS.take n s) <> BS.Char8.replicate (n - PS.length s) '\NUL' +putPosixString n s = posixToByteString (PS.take n s) <> BS.replicate (n - PS.length s) 0x00 putString :: FieldWidth -> String -> BS.ByteString -putString n s = BS.take n (packAscii s) <> BS.Char8.replicate (n - length s) '\NUL' +putString n s = BS.take n (packAscii s) <> BS.replicate (n - length s) 0x00 {-# SPECIALISE putLarge :: FieldWidth -> Int64 -> BS.ByteString #-} putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString @@ -161,9 +162,9 @@ putOct :: (Integral a, Show a) => FieldWidth -> a -> BS.ByteString putOct n x = let octStr = BS.take (n-1) $ BS.Char8.pack $ showOct x "" - in BS.Char8.replicate (n - BS.length octStr - 1) '0' + in BS.replicate (n - BS.length octStr - 1) 0x30 <> octStr - <> putChar8 '\NUL' + <> BS.singleton 0x00 putChar8 :: Char -> BS.ByteString putChar8 = BS.Char8.singleton diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -30,6 +30,9 @@ , env loadTarEntries $ \entries -> bench "unpack" (nfIO $ withSystemTempDirectory "tar-bench" $ \baseDir -> Tar.unpack baseDir entries) + + , env (fmap TarIndex.serialise loadTarIndex) $ \tarfile -> + bench "deserialise index" (nf TarIndex.deserialise tarfile) ] loadTarFile :: IO BS.ByteString diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +## 0.6.3.0 Bodigrim June 2024 + + * [Speed up `deserialize`](https://github.com/haskell/tar/pull/95). + ## 0.6.2.0 Bodigrim March 2024 * Fix issues with Unicode support in filenames. diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: tar -version: 0.6.2.0 +version: 0.6.3.0 license: BSD-3-Clause license-file: LICENSE author: Duncan Coutts @@ -29,7 +29,7 @@ test/data/symlink.tar extra-doc-files: changelog.md README.md -tested-with: GHC==9.8.1, GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, +tested-with: GHC==9.10.1, GHC==9.8.2, GHC==9.6.5, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 source-repository head @@ -56,7 +56,7 @@ directory >= 1.3.1 && < 1.4, filepath < 1.6, os-string >= 2.0 && < 2.1, - time < 1.13, + time < 1.15, transformers < 0.7, exposed-modules: @@ -75,6 +75,7 @@ Codec.Archive.Tar.Index.StringTable Codec.Archive.Tar.Index.IntTrie Codec.Archive.Tar.Index.Internal + Codec.Archive.Tar.Index.Utils other-extensions: BangPatterns