1{-# LANGUAGE BangPatterns, OverloadedStrings #-} 2-- | 3-- Module : LazyByteString 4-- Copyright : (c) 2010 Simon Meier 5-- License : BSD3-style (see LICENSE) 6-- 7-- Maintainer : Leon P Smith <leon@melding-monads.com> 8-- Stability : experimental 9-- Portability : tested on GHC only 10-- 11-- Benchmarking of alternative implementations of functions in 12-- Data.ByteString.Lazy that construct lazy bytestrings and cannot be 13-- implemented with slicing only. 14module LazyByteString where -- (main) where 15 16import Data.Char 17import Data.Word 18import Data.Monoid 19import Data.List 20 21import Control.Monad 22import Control.Arrow (second) 23import Criterion.Main 24 25import Foreign 26import qualified Data.ByteString as S 27import qualified Data.ByteString.Unsafe as S 28import qualified Data.ByteString.Internal as S 29import qualified Data.ByteString.Lazy as L 30import qualified Data.ByteString.Lazy.Internal as L 31 32import Data.ByteString.Base64 33 34import Blaze.ByteString.Builder.Internal 35import Blaze.ByteString.Builder.Word 36import Blaze.ByteString.Builder.ByteString 37 38------------------------------------------------------------------------------ 39-- Benchmarks 40------------------------------------------------------------------------------ 41 42main :: IO () 43main = do 44 let (chunkInfos, benchmarks) = unzip 45 {- 46 [ lazyVsBlaze 47 ( "partitionLazy" 48 , (uncurry mappend) . L.partition ((0 <) . sin . fromIntegral) 49 , (uncurry mappend) . partitionLazy ((0 <) . sin . fromIntegral) 50 , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) 51 , n) 52 -} 53 {- 54 [ lazyVsBlaze 55 ( "base64mime" 56 , L.fromChunks . return . joinWith "\r\n" 76 . encode 57 , toLazyByteString . encodeBase64MIME 58 , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) 59 , n) 60 -} 61 {- 62 [ lazyVsBlaze 63 ( "joinWith" 64 , L.fromChunks . return . joinWith "\r\n" 76 65 , toLazyByteString . intersperseBlocks 76 "\r\n" 66 , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) 67 , n) 68 -} 69 [ lazyVsBlaze 70 ( "base64" 71 , L.fromChunks . return . encode 72 , toLazyByteString . encodeBase64 73 , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) 74 , n) 75 {- 76 , lazyVsBlaze 77 ( "copy" 78 , L.copy 79 , copyBlaze 80 , (\i -> L.drop 13 $ L.take (fromIntegral i) $ L.fromChunks $ repeat $ S.pack [0..]) 81 , n) 82 , lazyVsBlaze 83 ( "filter ((==0) . (`mod` 3))" 84 , L.filter ((==0) . (`mod` 3)) 85 , filterBlaze ((==0) . (`mod` 3)) 86 , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) 87 , n) 88 , lazyVsBlaze 89 ( "map (+1)" 90 , L.map (+1) 91 , mapBlaze (+1) 92 , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) 93 , n) 94 , lazyVsBlaze 95 ( "concatMap (replicate 10)" 96 , L.concatMap (L.replicate 10) 97 , toLazyByteString . concatMapBuilder (fromReplicateWord8 10) 98 , (\i -> L.pack $ take i $ cycle [0..]) 99 , n `div` 10 ) 100 , lazyVsBlaze 101 ( "unfoldr countToZero" 102 , L.unfoldr countToZero 103 , unfoldrBlaze countToZero 104 , id 105 , n ) 106 -} 107 ] 108 sequence_ (intersperse (putStrLn "") chunkInfos) 109 putStrLn "" 110 defaultMain benchmarks 111 where 112 n :: Int 113 n = 100000 114 115lazyVsBlaze :: (String, a -> L.ByteString, a -> L.ByteString, Int -> a, Int) 116 -> (IO (), Benchmark) 117lazyVsBlaze (cmpName, lazy, blaze, prep, n) = 118 ( do putStrLn $ cmpName ++ ": " ++ checkResults 119 showChunksize implLazy lazy 120 showChunksize implBlaze blaze 121 , bgroup cmpName 122 [ mkBench implBlaze blaze 123 , mkBench implLazy lazy 124 ] 125 ) 126 where 127 implLazy = "bytestring" 128 implBlaze = "blaze-builder" 129 x = prep n 130 131 nInfo = "for n = " ++ show n 132 checkResults 133 | lazy x == blaze x = "implementations agree " ++ nInfo 134 | otherwise = unlines [ "ERROR: IMPLEMENTATIONS DISAGREE " ++ nInfo 135 , implLazy ++ ": " ++ show (lazy x) 136 , implBlaze ++ ": " ++ show (blaze x) 137 ] 138 139 showChunksize implName impl = do 140 let bs = impl x 141 cs = map S.length $ L.toChunks bs 142 putStrLn $ " " ++ implName ++ ": " 143 putStrLn $ " chunks sizes: " ++ show cs 144 putStrLn $ " avg. chunk size: " ++ 145 show ((fromIntegral (sum cs) :: Double) / fromIntegral (length cs)) 146 147 mkBench implName impl = bench implName $ whnf (L.length . impl) x 148 149 150------------------------------------------------------------------------------ 151-- Alternative implementations 152------------------------------------------------------------------------------ 153 154-- Unfolding 155------------ 156 157{- 158-- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. 159-- 'unfoldr' builds a ByteString from a seed value. The function takes 160-- the element and returns 'Nothing' if it is done producing the 161-- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a 162-- prepending to the ByteString and @b@ is used as the next element in a 163-- recursive call. 164unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString 165unfoldr f s0 = unfoldChunk 32 s0 166 where unfoldChunk n s = 167 case S.unfoldrN n f s of 168 (c, Nothing) 169 | S.null c -> Empty 170 | otherwise -> Chunk c Empty 171 (c, Just s') -> Chunk c (unfoldChunk (n*2) s') 172-} 173 174countToZero :: Int -> Maybe (Word8, Int) 175countToZero 0 = Nothing 176countToZero i = Just (fromIntegral i, i - 1) 177 178unfoldrBlaze :: (a -> Maybe (Word8, a)) -> a -> L.ByteString 179unfoldrBlaze f x = toLazyByteString $ fromWriteUnfoldr writeWord8 f x 180 181fromWriteUnfoldr :: (b -> Write) -> (a -> Maybe (b, a)) -> a -> Builder 182fromWriteUnfoldr write = 183 makeBuilder 184 where 185 makeBuilder f x0 = fromBuildStepCont $ step x0 186 where 187 step x1 !k = fill x1 188 where 189 fill x !(BufRange pf0 pe0) = go (f x) pf0 190 where 191 go !Nothing !pf = do 192 let !br' = BufRange pf pe0 193 k br' 194 go !(Just (y, x')) !pf 195 | pf `plusPtr` bound <= pe0 = do 196 !pf' <- runWrite (write y) pf 197 go (f x') pf' 198 | otherwise = return $ bufferFull bound pf $ 199 \(BufRange pfNew peNew) -> do 200 !pfNew' <- runWrite (write y) pfNew 201 fill x' (BufRange pfNew' peNew) 202 where 203 bound = getBound $ write y 204{-# INLINE fromWriteUnfoldr #-} 205 206-- Filtering and mapping 207------------------------ 208 209test :: Int -> (L.ByteString, L.ByteString) 210test i = 211 ((L.filter ((==0) . (`mod` 3)) $ x) , 212 (filterBlaze ((==0) . (`mod` 3)) $ x)) 213 where 214 x = L.pack $ take i $ cycle [0..] 215 216filterBlaze :: (Word8 -> Bool) -> L.ByteString -> L.ByteString 217filterBlaze f = toLazyByteString . filterLazyByteString f 218{-# INLINE filterBlaze #-} 219 220mapBlaze :: (Word8 -> Word8) -> L.ByteString -> L.ByteString 221mapBlaze f = toLazyByteString . mapLazyByteString f 222{-# INLINE mapBlaze #-} 223 224filterByteString :: (Word8 -> Bool) -> S.ByteString -> Builder 225filterByteString p = mapFilterMapByteString id p id 226{-# INLINE filterByteString #-} 227 228filterLazyByteString :: (Word8 -> Bool) -> L.ByteString -> Builder 229filterLazyByteString p = mapFilterMapLazyByteString id p id 230{-# INLINE filterLazyByteString #-} 231 232mapByteString :: (Word8 -> Word8) -> S.ByteString -> Builder 233mapByteString f = mapFilterMapByteString f (const True) id 234{-# INLINE mapByteString #-} 235 236mapLazyByteString :: (Word8 -> Word8) -> L.ByteString -> Builder 237mapLazyByteString f = mapFilterMapLazyByteString f (const True) id 238{-# INLINE mapLazyByteString #-} 239 240mapFilterMapByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) 241 -> S.ByteString -> Builder 242mapFilterMapByteString f p g = 243 \bs -> fromBuildStepCont $ step bs 244 where 245 step (S.PS ifp ioff isize) !k = 246 goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) 247 where 248 !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) 249 goBS !ip0 !br@(BufRange op0 ope) 250 | ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed 251 k br 252 | op0 < ope = goPartial (ip0 `plusPtr` min outRemaining inpRemaining) 253 | otherwise = return $ bufferFull 1 op0 (goBS ip0) 254 where 255 outRemaining = ope `minusPtr` op0 256 inpRemaining = ipe `minusPtr` ip0 257 goPartial !ipeTmp = go ip0 op0 258 where 259 go !ip !op 260 | ip < ipeTmp = do 261 w <- peek ip 262 let w' = g w 263 if p w' 264 then poke op (f w') >> go (ip `plusPtr` 1) (op `plusPtr` 1) 265 else go (ip `plusPtr` 1) op 266 | otherwise = 267 goBS ip (BufRange op ope) 268{-# INLINE mapFilterMapByteString #-} 269 270mapFilterMapLazyByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) 271 -> L.ByteString -> Builder 272mapFilterMapLazyByteString f p g = 273 L.foldrChunks (\c b -> mapFilterMapByteString f p g c `mappend` b) mempty 274{-# INLINE mapFilterMapLazyByteString #-} 275 276 277-- Concatenation and replication 278-------------------------------- 279 280{- 281-- | Map a function over a 'ByteString' and concatenate the results 282concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString 283concatMap _ Empty = Empty 284concatMap f (Chunk c0 cs0) = to c0 cs0 285 where 286 go :: ByteString -> P.ByteString -> ByteString -> ByteString 287 go Empty c' cs' = to c' cs' 288 go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') 289 290 to :: P.ByteString -> ByteString -> ByteString 291 to c cs | S.null c = case cs of 292 Empty -> Empty 293 (Chunk c' cs') -> to c' cs' 294 | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs 295-} 296 297fromWriteReplicated :: (a -> Write) -> Int -> a -> Builder 298fromWriteReplicated write = 299 makeBuilder 300 where 301 makeBuilder !n0 x = fromBuildStepCont $ step 302 where 303 bound = getBound $ write x 304 step !k = fill n0 305 where 306 fill !n1 !(BufRange pf0 pe0) = go n1 pf0 307 where 308 go 0 !pf = do 309 let !br' = BufRange pf pe0 310 k br' 311 go n !pf 312 | pf `plusPtr` bound <= pe0 = do 313 pf' <- runWrite (write x) pf 314 go (n-1) pf' 315 | otherwise = return $ bufferFull bound pf $ 316 \(BufRange pfNew peNew) -> do 317 pfNew' <- runWrite (write x) pfNew 318 fill (n-1) (BufRange pfNew' peNew) 319{-# INLINE fromWriteReplicated #-} 320 321-- FIXME: Output repeated bytestrings for large replications. 322fromReplicateWord8 :: Int -> Word8 -> Builder 323fromReplicateWord8 !n0 x = 324 fromBuildStepCont $ step 325 where 326 step !k = fill n0 327 where 328 fill !n !br@(BufRange pf pe) 329 | n <= 0 = k br 330 | pf' <= pe = do 331 _ <- S.memset pf x (fromIntegral n) -- FIXME: This conversion looses information for 64 bit systems. 332 let !br' = BufRange pf' pe 333 k br' 334 | otherwise = do 335 let !l = pe `minusPtr` pf 336 _ <- S.memset pf x (fromIntegral l) -- FIXME: This conversion looses information for 64 bit systems. 337 return $ bufferFull 1 pe $ fill (n - l) 338 where 339 pf' = pf `plusPtr` n 340{-# INLINE fromReplicateWord8 #-} 341 342 343{-# RULES "fromWriteReplicated/writeWord8" 344 fromWriteReplicated writeWord8 = fromReplicateWord8 345 #-} 346 347 348concatMapBuilder :: (Word8 -> Builder) -> L.ByteString -> Builder 349concatMapBuilder f = L.foldr (\w b -> f w `mappend` b) mempty 350{-# INLINE concatMapBuilder #-} 351 352concatMapBlaze :: (Word8 -> L.ByteString) -> L.ByteString -> L.ByteString 353concatMapBlaze f = toLazyByteString . concatMapBuilder (fromLazyByteString . f) 354 355 356-- Interspersing 357---------------- 358 359-- 360-- not sure if it Builder version is needed, as chunks get only bigger. We 361-- would need it however, if we used a Builder to ensure latency guarantees; i.e., 362-- if we use a builder to ensure a bound on the maximal size of chunks. 363-- 364 365{- 366-- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and 367-- \`intersperses\' that byte between the elements of the 'ByteString'. 368-- It is analogous to the intersperse function on Lists. 369intersperse :: Word8 -> ByteString -> ByteString 370intersperse _ Empty = Empty 371intersperse w (Chunk c cs) = Chunk (S.intersperse w c) 372 (foldrChunks (Chunk . intersperse') Empty cs) 373 where intersperse' :: P.ByteString -> P.ByteString 374 intersperse' (S.PS fp o l) = 375 S.unsafeCreate (2*l) $ \p' -> withForeignPtr fp $ \p -> do 376 poke p' w 377 S.c_intersperse (p' `plusPtr` 1) (p `plusPtr` o) (fromIntegral l) w 378-} 379{- 380intersperseBlaze :: Word8 -- ^ Byte to intersperse. 381 -> L.ByteString -- ^ Lazy 'L.ByteString' to be "spread". 382 -> Builder -- ^ Resulting 'Builder'. 383intersperseBlaze w lbs0 = 384 Builder $ step lbs0 385 where 386 step lbs1 k = goChunk lbs1 387 where 388 goChunk L.Empty pf0 pe0 = k pf0 pe0 389 goChunk (L.Chunk (S.PS fpi oi li) lbs') pf0 pe0 = do 390 go 391 touch 392 where 393 go 394 where 395 !pf' = pf `plusPtr` 396 397 398 goChunk !L.Empty !pf = k pf pe0 399 goChunk !lbs@(L.Chunk bs' lbs') !pf 400 | pf' <= pe0 = do 401 withForeignPtr fpbuf $ \pbuf -> 402 copyBytes pf (pbuf `plusPtr` offset) size 403 go lbs' pf' 404 405 | otherwise = return $ BufferFull size pf (step lbs k) 406 where 407 !pf' = pf `plusPtr` 408 !(fpbuf, offset, size) = S.toForeignPtr bs' 409{-# INLINE intersperseBlaze #-} 410 411-} 412 413 414-- Packing 415---------- 416 417packBlaze :: [Word8] -> L.ByteString 418packBlaze = toLazyByteString . fromWriteList writeWord8 419 420 421-- Reverse 422---------- 423 424 425-- Transpose 426------------ 427 428 429-- scanl, scanl1, scanr, scanr1 430------------------------------- 431 432 433-- mapAccumL, mapAccumR 434----------------------- 435 436 437-- partition 438------------ 439 440-- unzip 441-------- 442 443 444-- copy 445------- 446 447copyBlaze :: L.ByteString -> L.ByteString 448copyBlaze = toLazyByteString . copyLazyByteString 449 450 451-- ?? packCString, packCStringLen 452--------------------------------- 453 454-- joinWith 455-------------------------------------------- 456 457intersperseBlocks :: Int -> S.ByteString -> S.ByteString -> Builder 458intersperseBlocks blockSize sep (S.PS ifp ioff isize) = 459 fromPut $ do 460 lastBS <- go (ip0 `plusPtr` ioff) 461 unless (S.null lastBS) (putBuilder $ fromByteString lastBS) 462 where 463 ip0 = unsafeForeignPtrToPtr ifp 464 ipe = ip0 `plusPtr` (ioff + isize) 465 go !ip 466 | ip `plusPtr` blockSize >= ipe = 467 return $ S.PS ifp (ip `minusPtr` ip0) (ipe `minusPtr` ip) 468 | otherwise = do 469 putBuilder $ fromByteString (S.PS ifp (ip `minusPtr` ip0) blockSize) 470 `mappend` fromByteString sep 471 go (ip `plusPtr` blockSize) 472 473intersperseLazyBlocks :: Int -> Builder -> L.ByteString -> Builder 474intersperseLazyBlocks blockSize sep bs = 475 go (splitLazyAt blockSize bs) 476 where 477 go (pre, suf) 478 | L.null suf = fromLazyByteString pre 479 | otherwise = fromLazyByteString pre `mappend` sep `mappend` 480 go (splitLazyAt blockSize suf) 481 482encodeBase64MIME :: S.ByteString -> Builder 483encodeBase64MIME = 484 intersperseLazyBlocks 76 (fromByteString "\r\n") . toLazyByteString . encodeBase64 485 486 487-- test blockwise mapping on base64 encoding 488-------------------------------------------- 489 490-- | Encode a bytestring using Base64 encoding according to the specification 491-- in RFC 4648, <http://www.apps.ietf.org/rfc/rfc4648.html>. 492-- 493-- Note that you need to insert additional linebreaks every 76 bytes using the 494-- function @joinWith "\r\n" 76@ in order to achieve the MIME Base64 495-- Content-Transfer-Encoding <specified in http://tools.ietf.org/html/rfc2045>. 496-- 497-- TODO implement encoding of lazy bytestrings, implement joinWith 498-- functionality, and convencience function for MIME base-64 encoding. 499encodeBase64 :: S.ByteString -> Builder 500encodeBase64 = encodeLazyBase64 . L.fromChunks . return 501 502encodeLazyBase64 :: L.ByteString -> Builder 503encodeLazyBase64 = 504 mkBuilder 505 where 506 mkBuilder bs = fromPut $ do 507 remainder <- putWriteLazyBlocks 3 writeBase64 bs 508 putBuilder $ complete remainder 509 510 {-# INLINE writeBase64 #-} 511 writeBase64 ip = 512 exactWrite 4 $ \op -> do 513 b0 <- peekByte 0 514 b1 <- peekByte 1 515 b2 <- peekByte 2 516 let w = (b0 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b2 517 poke (castPtr $ op ) =<< enc (w `shiftR` 12) 518 poke (castPtr $ op `plusPtr` 2) =<< enc (w .&. 0xfff) 519 where 520 peekByte :: Int -> IO Word32 521 peekByte off = fmap fromIntegral (peekByteOff ip off :: IO Word8) 522 523 enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral 524 525 {-# INLINE complete #-} 526 complete bs 527 | S.null bs = mempty 528 | otherwise = fromWrite $ 529 exactWrite 4 $ \op -> do 530 let poke6Base64 off sh = pokeByteOff op off 531 (alphabet `S.unsafeIndex` fromIntegral (w `shiftR` sh .&. 63)) 532 pad off = pokeByteOff op off (fromIntegral $ ord '=' :: Word8) 533 poke6Base64 0 18 534 poke6Base64 1 12 535 if S.length bs == 1 then pad 2 536 else poke6Base64 2 8 537 pad 3 538 where 539 getByte :: Int -> Int -> Word32 540 getByte i sh = fromIntegral (bs `S.unsafeIndex` i) `shiftL` sh 541 w = getByte 0 16 .|. (if S.length bs == 1 then 0 else getByte 1 8) 542 543 -- Lookup table trick from Data.ByteString.Base64 by Bryan O'Sullivan 544 {-# NOINLINE alphabet #-} 545 alphabet :: S.ByteString 546 alphabet = S.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47] 547 548 -- FIXME: Check that the implementation of the lookup table aslo works on 549 -- big-endian systems. 550 {-# NOINLINE encodeTable #-} 551 encodeTable :: ForeignPtr Word16 552 encodeTable = unsafePerformIO $ do 553 fp <- mallocForeignPtrArray 4096 554 let ix = fromIntegral . S.index alphabet 555 withForeignPtr fp $ \p -> 556 sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j) 557 | j <- [0..63], k <- [0..63] ] 558 return fp 559 560 561-- | Process a bytestring block-wise using a 'Write' action to produce the 562-- output per block. 563-- 564-- TODO: Compare speed with 'mapFilterMapByteString'. 565{-# INLINE putWriteBlocks #-} 566putWriteBlocks :: Int -- ^ Block size. 567 -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the 568 -- beginning of the block. 569 -> S.ByteString -- ^ 'S.ByteString' to consume blockwise. 570 -> Put S.ByteString -- ^ 'Put' returning the remaining 571 -- bytes, which are guaranteed to be 572 -- fewer than the block size. 573putWriteBlocks blockSize write = 574 \bs -> putBuildStepCont $ step bs 575 where 576 step (S.PS ifp ioff isize) !k = 577 goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) 578 where 579 !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) 580 goBS !ip0 !br@(BufRange op0 ope) 581 | ip0 `plusPtr` blockSize > ipe = do 582 touchForeignPtr ifp -- input buffer consumed 583 let !bs' = S.PS ifp (ip0 `minusPtr` unsafeForeignPtrToPtr ifp) 584 (ipe `minusPtr` ip0) 585 k bs' br 586 587 | op0 `plusPtr` writeBound < ope = 588 goPartial (ip0 `plusPtr` (blockSize * min outRemaining inpRemaining)) 589 590 | otherwise = return $ bufferFull writeBound op0 (goBS ip0) 591 where 592 writeBound = getBound' "putWriteBlocks" write 593 outRemaining = (ope `minusPtr` op0) `div` writeBound 594 inpRemaining = (ipe `minusPtr` ip0) `div` blockSize 595 596 goPartial !ipeTmp = go ip0 op0 597 where 598 go !ip !op 599 | ip < ipeTmp = do 600 op' <- runWrite (write ip) op 601 go (ip `plusPtr` blockSize) op' 602 | otherwise = 603 goBS ip (BufRange op ope) 604 605 606{-# INLINE putWriteLazyBlocks #-} 607putWriteLazyBlocks :: Int -- ^ Block size. 608 -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the 609 -- beginning of the block. 610 -> L.ByteString -- ^ 'L.ByteString' to consume blockwise. 611 -> Put S.ByteString -- ^ 'Put' returning the remaining 612 -- bytes, which are guaranteed to be 613 -- fewer than the block size. 614putWriteLazyBlocks blockSize write = 615 go 616 where 617 go L.Empty = return S.empty 618 go (L.Chunk bs lbs) = do 619 bsRem <- putWriteBlocks blockSize write bs 620 case S.length bsRem of 621 lRem 622 | lRem <= 0 -> go lbs 623 | otherwise -> do 624 let (lbsPre, lbsSuf) = 625 L.splitAt (fromIntegral $ blockSize - lRem) lbs 626 case S.concat $ bsRem : L.toChunks lbsPre of 627 block@(S.PS bfp boff bsize) 628 | bsize < blockSize -> return block 629 | otherwise -> do 630 putBuilder $ fromWrite $ 631 write (unsafeForeignPtrToPtr bfp `plusPtr` boff) 632 putLiftIO $ touchForeignPtr bfp 633 go lbsSuf 634 635 636------------------------------------------------------------------------------ 637-- Testing code 638------------------------------------------------------------------------------ 639 640 641chunks3 :: [Word8] -> [Word32] 642chunks3 (b0 : b1 : b2 : bs) = 643 ((fromIntegral b0 `shiftL` 16) .|. 644 (fromIntegral b1 `shiftL` 8) .|. 645 (fromIntegral b2 ) 646 ) : chunks3 bs 647chunks3 _ = [] 648 649cmpWriteToLib :: [Word8] -> (L.ByteString, L.ByteString) 650cmpWriteToLib bs = 651 -- ( toLazyByteString $ fromWriteList write24bitsBase64 $ chunks3 bs 652 ( toLazyByteString $ encodeBase64 $ S.pack bs 653 , (`L.Chunk` L.empty) $ encode $ S.pack bs ) 654 655test3 :: Bool 656test3 = uncurry (==) $ cmpWriteToLib $ [0..] 657 658test2 :: L.ByteString 659test2 = toLazyByteString $ encodeBase64 $ S.pack [0..] 660 661{- OLD code 662 663{-# INLINE poke8 #-} 664poke8 :: Word8 -> Ptr Word8 -> IO () 665poke8 = flip poke 666 667-- | @writeBase64 w@ writes the lower @24@ bits as four times 6 bit in 668-- little-endian order encoded using the standard alphabeth of Base 64 encoding 669-- as defined in <http://www.apps.ietf.org/rfc/rfc4648.html>. 670-- 671{-# INLINE write6bitsBase64 #-} 672write6bitsBase64 :: Word32 -> Write 673write6bitsBase64 = exactWrite 1 . poke6bitsBase64 674 675{-# INLINE poke6bitsBase64 #-} 676poke6bitsBase64 :: Word32 -> Ptr Word8 -> IO () 677poke6bitsBase64 w = poke8 (alphabet `S.unsafeIndex` fromIntegral (w .&. 63)) 678 {- 679 | i < 26 = withOffsets 0 'A' 680 | i < 52 = withOffsets 26 'a' 681 | i < 62 = withOffsets 52 '0' 682 | i == 62 = poke8 $ fromIntegral $ ord '+' 683 | otherwise = poke8 $ fromIntegral $ ord '/' 684 where 685 i :: Int 686 i = fromIntegral (w .&. 63) 687 688 {-# INLINE withOffsets #-} 689 withOffsets neg pos = poke8 $ fromIntegral (i + ord pos - neg) 690 -} 691 692{-# INLINE writePaddedBitsBase64 #-} 693writePaddedBitsBase64 :: Bool -- ^ Only 8 bits have to be output. 694 -> Word32 -- ^ Input whose lower 8 or 16 bits need to be output. 695 -> Write 696writePaddedBitsBase64 only8 w = 697 write6bitsBase64 (w `shiftr_w32` 18) `mappend` 698 write6bitsBase64 (w `shiftr_w32` 12) `mappend` 699 writeIf (const only8) (const $ C8.writeChar '=') 700 (write6bitsBase64 . (`shiftr_w32` 6)) 701 w `mappend` 702 C8.writeChar '=' 703 704{-# INLINE write24bitsBase64 #-} 705write24bitsBase64 :: Word32 -> Write 706write24bitsBase64 w = write6bitsBase64 (w `shiftr_w32` 18) `mappend` 707 write6bitsBase64 (w `shiftr_w32` 12) `mappend` 708 write6bitsBase64 (w `shiftr_w32` 6) `mappend` 709 write6bitsBase64 (w ) 710 711-- ASSUMES bits 25 - 31 are zero. 712{-# INLINE write24bitsBase64' #-} 713write24bitsBase64' :: Word32 -> Write 714write24bitsBase64' w = 715 exactWrite 4 $ \p -> do 716 poke (castPtr p ) =<< enc (w `shiftR` 12) 717 poke (castPtr $ p `plusPtr` 2) =<< enc (w .&. 0xfff) 718 where 719 {-# INLINE enc #-} 720 enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral 721 722-} 723 724------------------------------------------------------------------------------- 725-- A faster split for lazy bytestrings 726------------------------------------------------------------------------------- 727 728-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. 729splitLazyAt :: Int -> L.ByteString -> (L.ByteString, L.ByteString) 730splitLazyAt n cs0 731 | n <= 0 = (L.Empty, cs0) 732 | otherwise = split cs0 733 where 734 split L.Empty = (L.Empty, L.Empty) 735 split (L.Chunk c cs) 736 | n < len = case S.splitAt n c of 737 (pre, suf) -> (L.Chunk pre L.Empty, L.Chunk suf cs) 738 | otherwise = case splitLazyAt (n - len) cs of 739 (pre, suf) -> (L.Chunk c pre , suf ) 740 where 741 len = S.length c 742 743 744------------------------------------------------------------------------------- 745-- A faster partition for strict and lazy bytestrings 746------------------------------------------------------------------------------- 747 748{-# INLINE partitionStrict #-} 749partitionStrict :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) 750partitionStrict f (S.PS ifp ioff ilen) = 751 second S.reverse $ S.inlinePerformIO $ do 752 ofp <- S.mallocByteString ilen 753 withForeignPtr ifp $ wrapper ofp 754 where 755 wrapper !ofp !ip0 = 756 go (ip0 `plusPtr` ioff) op0 (op0 `plusPtr` ilen) 757 where 758 op0 = unsafeForeignPtrToPtr ofp 759 760 go !ip !opl !oph 761 | oph == opl = return (S.PS ofp 0 olen, S.PS ofp olen (ilen - olen)) 762 | otherwise = do 763 x <- peek ip 764 if f x 765 then do poke opl x 766 go (ip `plusPtr` 1) (opl `plusPtr` 1) oph 767 else do let oph' = oph `plusPtr` (-1) 768 poke oph' x 769 go (ip `plusPtr` 1) opl oph' 770 771 where 772 olen = opl `minusPtr` op0 773 774{-# INLINE partitionLazy #-} 775partitionLazy :: (Word8 -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString) 776partitionLazy f = 777 L.foldrChunks partitionOne (L.empty, L.empty) 778 where 779 partitionOne bs (ls, rs) = 780 (L.Chunk l ls, L.Chunk r rs) 781 where 782 (l, r) = partitionStrict f bs 783