diff --git a/Data/ByteString/Base64/Internal.hs b/Data/ByteString/Base64/Internal.hs --- a/Data/ByteString/Base64/Internal.hs +++ b/Data/ByteString/Base64/Internal.hs @@ -74,16 +74,16 @@ twoMore = sp `plusPtr` 2 == sEnd equals = 0x3d :: Word8 {-# INLINE equals #-} - a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) - b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) + !a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) + !b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) !b' <- if twoMore then peekSP 1 ((.|. b) . (`shiftR` 4) . (.&. 0xf0)) else return b poke8 dp =<< aidx a poke8 (dp `plusPtr` 1) =<< aidx b' - c <- if twoMore - then aidx =<< peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) - else return equals + !c <- if twoMore + then aidx =<< peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) + else return equals poke8 (dp `plusPtr` 2) c poke8 (dp `plusPtr` 3) equals withForeignPtr dfp $ \dptr -> @@ -155,12 +155,12 @@ | dlen <= 0 = Right B.empty | otherwise = unsafePerformIO $ do dfp <- mallocByteString dlen - withForeignPtr decodeFP $ \decptr -> do + withForeignPtr decodeFP $ \ !decptr -> do let finish dbytes = return . Right $! if dbytes > 0 then PS dfp 0 dbytes else B.empty bail = return . Left - withForeignPtr sfp $ \sptr -> do + withForeignPtr sfp $ \ !sptr -> do let sEnd = sptr `plusPtr` (slen + soff) look p = do ix <- fromIntegral `fmap` peek8 p @@ -197,9 +197,6 @@ where (di,drem) = slen `divMod` 4 dlen = di * 3 -data D = D { dNext :: {-# UNPACK #-} !(Ptr Word8) - , dValue :: {-# UNPACK #-} !Word32 } - -- | Decode a base64-encoded string. This function is lenient in -- following the specification from RFC 4648, -- , and will not generate @@ -211,45 +208,49 @@ | dlen <= 0 = B.empty | otherwise = unsafePerformIO $ do dfp <- mallocByteString dlen - dbytes <- withForeignPtr decodeFP $ \decptr -> - withForeignPtr sfp $ \sptr -> do - let sEnd = sptr `plusPtr` (slen + soff) + withForeignPtr decodeFP $ \ !decptr -> + withForeignPtr sfp $ \ !sptr -> do + let finish dbytes + | dbytes > 0 = return (PS dfp 0 dbytes) + | otherwise = return B.empty + sEnd = sptr `plusPtr` (slen + soff) fill !dp !sp !n - | sp >= sEnd = return n - | otherwise = {-# SCC "decodeLenientWithTable/fill" #-} do - let look skipPad = go + | sp >= sEnd = finish n + | otherwise = {-# SCC "decodeLenientWithTable/fill" #-} + let look :: Bool -> Ptr Word8 + -> (Ptr Word8 -> Word32 -> IO ByteString) + -> IO ByteString + {-# INLINE look #-} + look skipPad p0 f = go p0 where - go p | p >= sEnd = return $! D (sEnd `plusPtr` (-1)) done - | otherwise = {-# SCC "decodeLenient/look" #-} do + go p | p >= sEnd = f (sEnd `plusPtr` (-1)) done + | otherwise = {-# SCC "decodeLenient/look" #-} do ix <- fromIntegral `fmap` peek8 p v <- peek8 (decptr `plusPtr` ix) if v == x || (v == done && skipPad) then go (p `plusPtr` 1) - else return $! D (p `plusPtr` 1) (fromIntegral v) - !a <- look True sp - !b <- look True (dNext a) - !c <- look False (dNext b) - !d <- look False (dNext c) - let w = (dValue a `shiftL` 18) .|. (dValue b `shiftL` 12) .|. - (dValue c `shiftL` 6) .|. dValue d - if dValue a == done || dValue b == done - then return n - else do - poke8 dp $ fromIntegral (w `shiftR` 16) - if dValue c == done - then return $! n + 1 - else do - poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) - if dValue d == done - then return $! n + 2 - else do - poke8 (dp `plusPtr` 2) $ fromIntegral w - fill (dp `plusPtr` 3) (dNext d) (n+3) + else f (p `plusPtr` 1) (fromIntegral v) + in look True sp $ \ !aNext !aValue -> + look True aNext $ \ !bNext !bValue -> + if aValue == done || bValue == done + then finish n + else + look False bNext $ \ !cNext !cValue -> + look False cNext $ \ !dNext !dValue -> do + let w = (aValue `shiftL` 18) .|. (bValue `shiftL` 12) .|. + (cValue `shiftL` 6) .|. dValue + poke8 dp $ fromIntegral (w `shiftR` 16) + if cValue == done + then finish (n + 1) + else do + poke8 (dp `plusPtr` 1) $ fromIntegral (w `shiftR` 8) + if dValue == done + then finish (n + 2) + else do + poke8 (dp `plusPtr` 2) $ fromIntegral w + fill (dp `plusPtr` 3) dNext (n+3) withForeignPtr dfp $ \dptr -> fill dptr (sptr `plusPtr` soff) 0 - return $! if dbytes > 0 - then PS dfp 0 dbytes - else B.empty where dlen = ((slen + 3) `div` 4) * 3 x :: Integral a => a @@ -263,23 +264,21 @@ -- This takes a list of ByteStrings, and returns a list in which each -- (apart from possibly the last) has length that is a multiple of n reChunkIn :: Int -> [ByteString] -> [ByteString] -reChunkIn _ [] = [] -reChunkIn _ [y] = [y] -reChunkIn n (y : ys) = case B.length y `divMod` n of - (_, 0) -> - y : reChunkIn n ys - (d, _) -> - case B.splitAt (d * n) y of - (prefix, suffix) -> prefix : fixup suffix ys - where fixup acc [] = [acc] - fixup acc (z : zs) = case B.splitAt (n - B.length acc) z of - (prefix, suffix) -> - let acc' = acc `B.append` prefix - in if B.length acc' == n - then let zs' = if B.null suffix - then zs - else suffix : zs - in acc' : reChunkIn n zs' - else -- suffix must be null - fixup acc' zs - +reChunkIn !n = go + where + go [] = [] + go (y : ys) = case B.length y `divMod` n of + (_, 0) -> y : go ys + (d, _) -> case B.splitAt (d * n) y of + (prefix, suffix) -> prefix : fixup suffix ys + fixup acc [] = [acc] + fixup acc (z : zs) = case B.splitAt (n - B.length acc) z of + (prefix, suffix) -> + let acc' = acc `B.append` prefix + in if B.length acc' == n + then let zs' = if B.null suffix + then zs + else suffix : zs + in acc' : go zs' + else -- suffix must be null + fixup acc' zs diff --git a/base64-bytestring.cabal b/base64-bytestring.cabal --- a/base64-bytestring.cabal +++ b/base64-bytestring.cabal @@ -1,7 +1,7 @@ name: base64-bytestring -version: 1.0.0.0 -synopsis: Fast base64 encoding and deconding for ByteStrings -description: Fast base64 encoding and deconding for ByteStrings +version: 1.0.0.1 +synopsis: Fast base64 encoding and decoding for ByteStrings +description: Fast base64 encoding and decoding for ByteStrings homepage: https://github.com/bos/base64-bytestring bug-reports: https://github.com/bos/base64-bytestring/issues license: BSD3 diff --git a/benchmarks/BM.hs b/benchmarks/BM.hs --- a/benchmarks/BM.hs +++ b/benchmarks/BM.hs @@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +import Control.DeepSeq (NFData(rnf)) import Criterion.Main -import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B +import qualified Data.ByteString.Base64.Lazy as L import qualified Data.ByteString.Base64.URL as U +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L -sized name orig = +strict name orig = bgroup name [ bgroup "normal" [ bench "decode" $ whnf B.decode enc @@ -20,10 +24,30 @@ ] where enc = U.encode orig +instance NFData L.ByteString where + rnf L.Empty = () + rnf (L.Chunk _ ps) = rnf ps + +lazy name orig = + bgroup name [ + bench "decode" $ nf L.decode enc + , bench "encode" $ nf L.encode orig + ] + where enc = L.encode orig + main :: IO () main = defaultMain [ - sized "small" input - , sized "medium" (B.concat (replicate 100 input)) - , sized "large" (B.concat (replicate 10000 input)) + bgroup "lazy" [ + lazy "small" (L.fromChunks [input]) + , lazy "medium" (L.concat . replicate 16 . L.fromChunks . (:[]) . + B.concat $ replicate 8 input) + , lazy "large" (L.concat . replicate 1280 . L.fromChunks . (:[]) . + B.concat $ replicate 8 input) + ] + , bgroup "strict" [ + strict "small" input + , strict "medium" (B.concat (replicate 128 input)) + , strict "large" (B.concat (replicate 10240 input)) + ] ] where input = "abcdABCD0123[];'"