From a34bc4269a11165ec9c05a0f5e55ba2800764b0f Mon Sep 17 00:00:00 2001 From: Sam T Date: Thu, 26 Sep 2013 23:22:15 +0400 Subject: Move pack5 & unpack5 to separate module --- base32-bytestring.cabal | 1 + src/Data/ByteString/Base32.hs | 210 +----------------------------- src/Data/ByteString/Base32/Internal.hs | 230 +++++++++++++++++++++++++++++++++ 3 files changed, 232 insertions(+), 209 deletions(-) create mode 100644 src/Data/ByteString/Base32/Internal.hs diff --git a/base32-bytestring.cabal b/base32-bytestring.cabal index ccba67e..98e50e4 100644 --- a/base32-bytestring.cabal +++ b/base32-bytestring.cabal @@ -30,6 +30,7 @@ library default-extensions: hs-source-dirs: src exposed-modules: Data.ByteString.Base32 + other-modules: Data.ByteString.Base32.Internal build-depends: base == 4.6.* , bytestring == 0.10.* , cpu diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs index ca377e2..704aac6 100644 --- a/src/Data/ByteString/Base32.hs +++ b/src/Data/ByteString/Base32.hs @@ -19,127 +19,9 @@ module Data.ByteString.Base32 , decodeLenient ) where -import Data.Bits.Extras import Data.ByteString as BS import Data.ByteString.Internal as BS -import Data.Word -import Foreign hiding (unsafePerformIO) -import System.IO.Unsafe (unsafePerformIO) -import System.Endian - - -{----------------------------------------------------------------------- --- Utils ------------------------------------------------------------------------} - -type Word5 = Word8 - --- System.Endian.toBE32 is slower because toBE32 implemented using --- cbits shuffle functions while toBE32' implemented used gcc --- intrinsics --- -toBE64' :: Word64 -> Word64 -toBE64' = if getSystemEndianness == BigEndian then id else byteSwap -{-# INLINE toBE64' #-} - -toBE32' :: Word32 -> Word32 -toBE32' = if getSystemEndianness == BigEndian then id else byteSwap -{-# INLINE toBE32' #-} - -fromBE32' :: Word32 -> Word32 -fromBE32' = toBE32' -{-# INLINE fromBE32' #-} - --- n = 2 ^ d -padCeilN :: Int -> Int -> Int -padCeilN !n !x - | remd == 0 = x - | otherwise = (x - remd) + n - where mask = n - 1 - remd = x .&. mask - -{----------------------------------------------------------------------- --- Encoding ------------------------------------------------------------------------} - -unpack5Ptr :: Ptr Word8 -> ByteString -> ByteString -unpack5Ptr !tbl bs @ (PS fptr off sz) = - unsafePerformIO $ do - let unpackedSize = dstSize $ BS.length bs - BS.create unpackedSize $ \ dst -> do - withForeignPtr fptr $ \ ptr -> do - dst_end <- bigStep dst (advancePtr ptr off) sz - _ <- fillPadding dst_end (unpackedSize - (dst_end `minusPtr` dst)) - return () - where - dstSize x = padCeilN 8 (d + if m == 0 then 0 else 1) - where (d, m) = (x * 8) `quotRem` 5 - - fillPadding dst s = memset dst (c2w '=') (fromIntegral s) - - bigStep !dst !src !s - | s >= 5 = do - unpack5_40 dst src - bigStep (dst `advancePtr` 8) (src `advancePtr` 5) (s - 5) - | otherwise = smallStep dst src s 0 0 - - unpack5_40 !dst !src = do - w32he <- peek (castPtr src) :: IO Word32 - let w32 = toBE32' w32he - fill8_32 0 (w32 `unsafeShiftR` 27) - fill8_32 1 (w32 `unsafeShiftR` 22) - fill8_32 2 (w32 `unsafeShiftR` 17) - fill8_32 3 (w32 `unsafeShiftR` 12) - fill8_32 4 (w32 `unsafeShiftR` 7) - fill8_32 5 (w32 `unsafeShiftR` 2) - - w8 <- peekElemOff src 4 - fill8_32 6 ( (w32 `unsafeShiftL` 3) - .|. fromIntegral (w8 `unsafeShiftR` 5)) - fill8_32 7 (fromIntegral w8) - where - fill8_32 :: Int -> Word32 -> IO () - fill8_32 !i !w32 = do - w8 <- peekByteOff tbl (fromIntegral w32 .&. 0x1f) - poke (dst `advancePtr` i) w8 - - smallStep !dst !src !s !unused !un_cnt - | un_cnt >= 5 = do - let ix = unused `unsafeShiftR` 3 - peekByteOff tbl (fromIntegral ix) >>= poke dst - smallStep (advancePtr dst 1) - src s - (unused `unsafeShiftL` 5) - (un_cnt - 5) - - | s == 0 = do - if un_cnt == 0 - then return dst - else do - let ix = unused `unsafeShiftR` 3 - peekByteOff tbl (fromIntegral ix) >>= poke dst - return (dst `advancePtr` 1) - - | otherwise = do - w8 <- peek src - let usd_cnt = 5 - un_cnt - let bits = w8 .&. complement (bit (8 - usd_cnt) - 1) - let ix = (unused .|. bits `shiftR` un_cnt) `unsafeShiftR` 3 - peekByteOff tbl (fromIntegral ix) >>= poke dst - smallStep (advancePtr dst 1) - (advancePtr src 1) (pred s) - (w8 `shiftL` usd_cnt) (8 - usd_cnt) - -type EncTable = ByteString - -unpack5 :: EncTable -> ByteString -> ByteString -unpack5 (PS fptr off len) bs - | len /= 32 - = error $ "base32: unpack5: invalid lookup table size " ++ show len - | otherwise = - unsafePerformIO $ do - withForeignPtr fptr $ \ptr -> do - return $ unpack5Ptr (ptr `advancePtr` off) bs +import Data.ByteString.Base32.Internal encW5 :: Word5 -> Word8 encW5 !x @@ -154,92 +36,6 @@ encTable = BS.pack $ fmap encW5 [0..31] encode :: ByteString -> ByteString encode = unpack5 encTable -{----------------------------------------------------------------------- --- Decoding ------------------------------------------------------------------------} - -invIx :: Word5 -invIx = 255 - -pack5Ptr :: Ptr Word5 -> ByteString -> ByteString -pack5Ptr !tbl bs @ (PS fptr off sz) = - unsafePerformIO $ do - let packedSize = dstSize $ BS.length bs - BS.createAndTrim packedSize $ \ dst -> do - withForeignPtr fptr $ \ ptr -> do - dst_end <- bigStep dst (advancePtr ptr off) sz - return (dst_end `minusPtr` dst) - where - lookupTable :: Word8 -> Word5 - lookupTable ix - | x == invIx = error $ "base32: decode: invalid character" ++ show ix - | otherwise = x - where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) - {-# INLINE lookupTable #-} - - dstSize x = d + if m == 0 then 0 else 1 - where (d, m) = (x * 5) `quotRem` 8 - - bigStep !dst !src !s - | s > 8 = do - pack5_40 dst src - bigStep (dst `advancePtr` 5) (src `advancePtr` 8) (s - 8) - | otherwise = smallStep dst src s (0 :: Word64) 0 - - pack5_40 !dst !src = do - w64he <- peek (castPtr src) :: IO Word64 - let w64 = toBE64' w64he - let w40 = putAsW5 (w64 `unsafeShiftR` 00) $ - putAsW5 (w64 `unsafeShiftR` 08) $ - putAsW5 (w64 `unsafeShiftR` 16) $ - putAsW5 (w64 `unsafeShiftR` 24) $ - putAsW5 (w64 `unsafeShiftR` 32) $ - putAsW5 (w64 `unsafeShiftR` 40) $ - putAsW5 (w64 `unsafeShiftR` 48) $ - putAsW5 (w64 `unsafeShiftR` 56) 0 - pokeW40 w40 - where - putAsW5 :: Word64 -> Word64 -> Word64 - {-# INLINE putAsW5 #-} - putAsW5 !w8 !acc = (acc `unsafeShiftL` 5) - .|. fromIntegral (lookupTable (fromIntegral w8)) - - pokeW40 :: Word64 -> IO () - {-# INLINE pokeW40 #-} - pokeW40 !w40 = do - poke dst (fromIntegral (w40 `unsafeShiftR` 32) :: Word8) - poke (castPtr (dst `advancePtr` 1)) - (fromBE32' (fromIntegral w40 :: Word32)) - - smallStep !dst !src !s !unused !un_cnt - | un_cnt >= 8 = do - poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8)) - smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8) - - | s == 0 = return dst - | otherwise = do - w8 <- peek src - if w2c w8 == '=' - then if (bit un_cnt - 1) .&. unused == 0 - then smallStep dst src 0 0 0 - else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8 - else smallStep dst - (src `advancePtr` 1) (pred s) - ((unused `unsafeShiftL` 5) - .|. fromIntegral (lookupTable (fromIntegral w8))) - (un_cnt + 5) - -type DecTable = ByteString - -pack5 :: DecTable -> ByteString -> ByteString -pack5 (PS fptr off len) bs - | len /= 256 - = error $ "base32: pack5: invalid lookup table size " ++ show len - | otherwise = - unsafePerformIO $ do - withForeignPtr fptr $ \ptr -> - return $ pack5Ptr (ptr `advancePtr` off) bs - decW5 :: Word8 -> Word5 decW5 !x | x < 50 {- c2w '2' -} = invIx @@ -258,10 +54,6 @@ decTable = BS.pack $ fmap decW5 [minBound .. maxBound] decode :: ByteString -> ByteString decode = pack5 decTable -{----------------------------------------------------------------------- --- Lenient Decoding ------------------------------------------------------------------------} - decCharLenient :: Char -> Word5 decCharLenient x | x < '2' = err diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs new file mode 100644 index 0000000..c34e80c --- /dev/null +++ b/src/Data/ByteString/Base32/Internal.hs @@ -0,0 +1,230 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- (Word5 <-> Word8) and (Word8 -> Word5) bytestring packers using +-- lookup table. +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteString.Base32.Internal + ( Word5 + , Word8 + + , EncTable + , unpack5 + + , DecTable + , pack5 + , invIx + ) where + +import Data.Bits.Extras +import Data.ByteString as BS +import Data.ByteString.Internal as BS +import Data.Word +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) +import System.Endian + + +{----------------------------------------------------------------------- +-- Utils +-----------------------------------------------------------------------} + +type Word5 = Word8 + +-- System.Endian.toBE32 is slower because toBE32 implemented using +-- cbits shuffle functions while toBE32' implemented used gcc +-- intrinsics +-- +toBE64' :: Word64 -> Word64 +toBE64' = if getSystemEndianness == BigEndian then id else byteSwap +{-# INLINE toBE64' #-} + +toBE32' :: Word32 -> Word32 +toBE32' = if getSystemEndianness == BigEndian then id else byteSwap +{-# INLINE toBE32' #-} + +fromBE32' :: Word32 -> Word32 +fromBE32' = toBE32' +{-# INLINE fromBE32' #-} + +-- n = 2 ^ d +padCeilN :: Int -> Int -> Int +padCeilN !n !x + | remd == 0 = x + | otherwise = (x - remd) + n + where mask = n - 1 + remd = x .&. mask + +{----------------------------------------------------------------------- +-- Encoding +-----------------------------------------------------------------------} + +unpack5Ptr :: Ptr Word8 -> ByteString -> ByteString +unpack5Ptr !tbl bs @ (PS fptr off sz) = + unsafePerformIO $ do + let unpackedSize = dstSize $ BS.length bs + BS.create unpackedSize $ \ dst -> do + withForeignPtr fptr $ \ ptr -> do + dst_end <- bigStep dst (advancePtr ptr off) sz + _ <- fillPadding dst_end (unpackedSize - (dst_end `minusPtr` dst)) + return () + where + dstSize x = padCeilN 8 (d + if m == 0 then 0 else 1) + where (d, m) = (x * 8) `quotRem` 5 + + fillPadding dst s = memset dst (c2w '=') (fromIntegral s) + + bigStep !dst !src !s + | s >= 5 = do + unpack5_40 dst src + bigStep (dst `advancePtr` 8) (src `advancePtr` 5) (s - 5) + | otherwise = smallStep dst src s 0 0 + + unpack5_40 !dst !src = do + w32he <- peek (castPtr src) :: IO Word32 + let w32 = toBE32' w32he + fill8_32 0 (w32 `unsafeShiftR` 27) + fill8_32 1 (w32 `unsafeShiftR` 22) + fill8_32 2 (w32 `unsafeShiftR` 17) + fill8_32 3 (w32 `unsafeShiftR` 12) + fill8_32 4 (w32 `unsafeShiftR` 7) + fill8_32 5 (w32 `unsafeShiftR` 2) + + w8 <- peekElemOff src 4 + fill8_32 6 ( (w32 `unsafeShiftL` 3) + .|. fromIntegral (w8 `unsafeShiftR` 5)) + fill8_32 7 (fromIntegral w8) + where + fill8_32 :: Int -> Word32 -> IO () + fill8_32 !i !w32 = do + w8 <- peekByteOff tbl (fromIntegral w32 .&. 0x1f) + poke (dst `advancePtr` i) w8 + + smallStep !dst !src !s !unused !un_cnt + | un_cnt >= 5 = do + let ix = unused `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + smallStep (advancePtr dst 1) + src s + (unused `unsafeShiftL` 5) + (un_cnt - 5) + + | s == 0 = do + if un_cnt == 0 + then return dst + else do + let ix = unused `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + return (dst `advancePtr` 1) + + | otherwise = do + w8 <- peek src + let usd_cnt = 5 - un_cnt + let bits = w8 .&. complement (bit (8 - usd_cnt) - 1) + let ix = (unused .|. bits `shiftR` un_cnt) `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + smallStep (advancePtr dst 1) + (advancePtr src 1) (pred s) + (w8 `shiftL` usd_cnt) (8 - usd_cnt) + +type EncTable = ByteString + +unpack5 :: EncTable -> ByteString -> ByteString +unpack5 (PS fptr off len) bs + | len /= 32 + = error $ "base32: unpack5: invalid lookup table size " ++ show len + | otherwise = + unsafePerformIO $ do + withForeignPtr fptr $ \ptr -> do + return $ unpack5Ptr (ptr `advancePtr` off) bs + +{----------------------------------------------------------------------- +-- Decoding +-----------------------------------------------------------------------} + +invIx :: Word5 +invIx = 255 + +pack5Ptr :: Ptr Word5 -> ByteString -> ByteString +pack5Ptr !tbl bs @ (PS fptr off sz) = + unsafePerformIO $ do + let packedSize = dstSize $ BS.length bs + BS.createAndTrim packedSize $ \ dst -> do + withForeignPtr fptr $ \ ptr -> do + dst_end <- bigStep dst (advancePtr ptr off) sz + return (dst_end `minusPtr` dst) + where + lookupTable :: Word8 -> Word5 + lookupTable ix + | x == invIx = error $ "base32: decode: invalid character" ++ show ix + | otherwise = x + where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) + {-# INLINE lookupTable #-} + + dstSize x = d + if m == 0 then 0 else 1 + where (d, m) = (x * 5) `quotRem` 8 + + bigStep !dst !src !s + | s > 8 = do + pack5_40 dst src + bigStep (dst `advancePtr` 5) (src `advancePtr` 8) (s - 8) + | otherwise = smallStep dst src s (0 :: Word64) 0 + + pack5_40 !dst !src = do + w64he <- peek (castPtr src) :: IO Word64 + let w64 = toBE64' w64he + let w40 = putAsW5 (w64 `unsafeShiftR` 00) $ + putAsW5 (w64 `unsafeShiftR` 08) $ + putAsW5 (w64 `unsafeShiftR` 16) $ + putAsW5 (w64 `unsafeShiftR` 24) $ + putAsW5 (w64 `unsafeShiftR` 32) $ + putAsW5 (w64 `unsafeShiftR` 40) $ + putAsW5 (w64 `unsafeShiftR` 48) $ + putAsW5 (w64 `unsafeShiftR` 56) 0 + pokeW40 w40 + where + putAsW5 :: Word64 -> Word64 -> Word64 + {-# INLINE putAsW5 #-} + putAsW5 !w8 !acc = (acc `unsafeShiftL` 5) + .|. fromIntegral (lookupTable (fromIntegral w8)) + + pokeW40 :: Word64 -> IO () + {-# INLINE pokeW40 #-} + pokeW40 !w40 = do + poke dst (fromIntegral (w40 `unsafeShiftR` 32) :: Word8) + poke (castPtr (dst `advancePtr` 1)) + (fromBE32' (fromIntegral w40 :: Word32)) + + smallStep !dst !src !s !unused !un_cnt + | un_cnt >= 8 = do + poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8)) + smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8) + + | s == 0 = return dst + | otherwise = do + w8 <- peek src + if w2c w8 == '=' + then if (bit un_cnt - 1) .&. unused == 0 + then smallStep dst src 0 0 0 + else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8 + else smallStep dst + (src `advancePtr` 1) (pred s) + ((unused `unsafeShiftL` 5) + .|. fromIntegral (lookupTable (fromIntegral w8))) + (un_cnt + 5) + +type DecTable = ByteString + +pack5 :: DecTable -> ByteString -> ByteString +pack5 (PS fptr off len) bs + | len /= 256 + = error $ "base32: pack5: invalid lookup table size " ++ show len + | otherwise = + unsafePerformIO $ do + withForeignPtr fptr $ \ptr -> + return $ pack5Ptr (ptr `advancePtr` off) bs -- cgit v1.2.3