├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── Bench.hs ├── cbits └── superbuffer.c ├── circle.yml ├── docs └── benchmarks-0.3.0.0.html ├── package.yaml ├── src └── Data │ └── ByteString │ ├── SuperBuffer.hs │ └── SuperBuffer │ └── Pure.hs ├── stack.yaml ├── stack.yaml.lock ├── superbuffer.cabal └── test └── Test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | ck-server/secret/ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexander Thiemann (c) 2016 - 2022 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Thiemann nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell SuperBuffer 2 | 3 | [![CircleCI](https://circleci.com/gh/agrafix/superbuffer.svg?style=svg)](https://circleci.com/gh/agrafix/superbuffer) 4 | [![Hackage](https://img.shields.io/hackage/v/superbuffer.svg)](http://hackage.haskell.org/package/superbuffer) 5 | 6 | The `superbuffer` packages was designed to efficiently build up bytestrings from `IO` actions producing 7 | smaller chunks. The goal was to reduce memory overhead as much as possible while still being as fast as possible. 8 | In our use case, it reduced total memory usage of the program from `350 MB` (`bytestring` builder) to `50 MB` (`superbuffer`). 9 | For speed see benchmarks below. Note that the speed heavily depends on a good choice of the initial buffer size. `superbuffer` outperforms or performs similar to the `bytestring` alternatives consistently. `superbuffer` outperforms `buffer-builder`. 10 | 11 | ## Usage 12 | 13 | ```haskell 14 | {-# LANGUAGE OverloadedStrings #-} 15 | module Example where 16 | 17 | import Data.ByteString.SuperBuffer 18 | import qualified Data.ByteString as BS 19 | 20 | myBS :: IO BS.ByteString 21 | myBS = 22 | -- note: performance of superbuffer heavily depends on a 23 | -- smart choice of the initial buffer size. Benchmark to 24 | -- find what suits your needs. 25 | withBuffer 1024 $ \buf -> 26 | do appendBuffer buf "Hello " 27 | appendBuffer buf "World!" 28 | ``` 29 | 30 | ## Benchmarks 31 | 32 | See: [Benchmarks for 0.3.0.0](https://agrafix.github.io/superbuffer/benchmarks-0.3.0.0.html) 33 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.Async 4 | import Control.Monad 5 | import Criterion 6 | import Criterion.Main 7 | import Data.ByteString.SuperBuffer 8 | import qualified Data.ByteString.SuperBuffer.Pure as P 9 | import Data.Int 10 | import qualified Data.BufferBuilder as BB 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Builder as BSB 13 | import qualified Data.ByteString.Lazy as BSL 14 | 15 | main :: IO () 16 | main = 17 | defaultMain 18 | [ bgroup "main" 19 | [ mkGroup "small" 5000 4000 20 | , mkGroup "med" 500 40000 21 | , mkGroup "large" 50 400000 22 | ] 23 | ] 24 | 25 | mkGroup :: String -> Int -> Int -> Benchmark 26 | mkGroup name steps chunkSize = 27 | bgroup name $ 28 | mkSizedGroup steps chunkSize bufName buildBuf 29 | ++ mkSizedGroup steps chunkSize bufNameT buildBufT 30 | ++ mkSizedGroup steps chunkSize bufNameP buildBufP 31 | ++ mkSizedGroup steps chunkSize bufNamePT buildBufPT 32 | ++ mkSizedGroup steps chunkSize bufBBName buildBufBB 33 | ++ 34 | [ bench "bytestring builder" $ nfIO $ BS.reverse <$> buildBufBuilder steps chunkSize 35 | , bench "bytestring fromChunks" $ nfIO $ BS.reverse <$> buildBufChunks steps chunkSize 36 | , bench "bytestring concat" $ nfIO $ BS.reverse <$> buildBufConcat steps chunkSize 37 | ] 38 | where 39 | bufBBName is = "buffer-builder (init=" ++ show is ++ " bytes, trim=yes)" 40 | bufName is = "superbuffer (init=" ++ show is ++ " bytes)" 41 | bufNameT is = "superbuffer (init=" ++ show is ++ " bytes, threadsafe, 2 concurrent writes)" 42 | bufNameP is = "superbuffer (pure haskell, init=" ++ show is ++ " bytes)" 43 | bufNamePT is = "superbuffer (pure haskell, init=" ++ show is ++ " bytes, threadsafe, 2 concurrent writes)" 44 | 45 | mkSizedGroup :: 46 | Int -> Int -> (Int64 -> String) -> (Int64 -> Int -> Int -> IO BS.ByteString) -> [Benchmark] 47 | mkSizedGroup steps chunkSize bufName builder = 48 | [ bench (bufName iBufSize128) $ nfIO $ BS.reverse <$> builder iBufSize128 steps chunkSize 49 | , bench (bufName iBufSize) $ nfIO $ BS.reverse <$> builder iBufSize steps chunkSize 50 | , bench (bufName iBufSize2) $ nfIO $ BS.reverse <$> builder iBufSize2 steps chunkSize 51 | , bench (bufName iBufSize4) $ nfIO $ BS.reverse <$> builder iBufSize4 steps chunkSize 52 | , bench (bufName iBufSizeAll) $ nfIO $ BS.reverse <$> builder iBufSizeAll steps chunkSize 53 | ] 54 | where 55 | iBufSize128 = 128 56 | iBufSize = fromIntegral chunkSize 57 | iBufSize2 = 2 * fromIntegral chunkSize 58 | iBufSize4 = 4 * fromIntegral chunkSize 59 | iBufSizeAll = fromIntegral $ steps * chunkSize 60 | 61 | mkChunk :: Int -> Int -> BS.ByteString 62 | mkChunk step chunkSize = 63 | BS.replicate chunkSize (fromIntegral $ (step `mod` 100) + 50) 64 | {-# INLINE mkChunk #-} 65 | 66 | buildBuf :: Int64 -> Int -> Int -> IO BS.ByteString 67 | buildBuf bufSize steps chunkSize = 68 | withBuffer bufSize $ \buf -> 69 | forM_ [0..steps] $ \step -> 70 | appendBuffer buf (mkChunk step chunkSize) 71 | 72 | buildBufT :: Int64 -> Int -> Int -> IO BS.ByteString 73 | buildBufT bufSize steps chunkSize = 74 | withBuffer bufSize $ \buf -> 75 | forM_ [0..(ceiling halfSteps)] $ \step -> 76 | concurrently_ 77 | (appendBufferT buf (mkChunk step chunkSize)) 78 | (appendBufferT buf (mkChunk step chunkSize)) 79 | where 80 | halfSteps :: Double 81 | halfSteps = fromIntegral steps / 2.0 82 | 83 | buildBufP :: Int64 -> Int -> Int -> IO BS.ByteString 84 | buildBufP bufSize steps chunkSize = 85 | P.withBuffer (fromIntegral bufSize) $ \buf -> 86 | forM_ [0..steps] $ \step -> 87 | P.appendBuffer buf (mkChunk step chunkSize) 88 | 89 | buildBufPT :: Int64 -> Int -> Int -> IO BS.ByteString 90 | buildBufPT bufSize steps chunkSize = 91 | P.withBuffer (fromIntegral bufSize) $ \buf -> 92 | forM_ [0..(ceiling halfSteps)] $ \step -> 93 | concurrently_ 94 | (P.appendBufferT buf (mkChunk step chunkSize)) 95 | (P.appendBufferT buf (mkChunk step chunkSize)) 96 | where 97 | halfSteps :: Double 98 | halfSteps = fromIntegral steps / 2.0 99 | 100 | buildBufBB :: Int64 -> Int -> Int -> IO BS.ByteString 101 | buildBufBB bufSize steps chunkSize = 102 | pure $ BB.runBufferBuilderWithOptions opts $ 103 | forM_ [0..steps] $ \step -> 104 | BB.appendBS (mkChunk step chunkSize) 105 | where 106 | opts = 107 | BB.Options 108 | { BB.initialCapacity = fromIntegral bufSize 109 | , BB.trimFinalBuffer = True 110 | } 111 | 112 | buildBufBuilder :: Int -> Int -> IO BS.ByteString 113 | buildBufBuilder steps chunkSize = 114 | BSL.toStrict . BSB.toLazyByteString <$> 115 | foldM (\b a -> pure $ b `mappend` BSB.byteString (mkChunk a chunkSize)) mempty [0..steps] 116 | 117 | buildBufChunks :: Int -> Int -> IO BS.ByteString 118 | buildBufChunks steps chunkSize = 119 | BSL.toStrict . BSL.fromChunks <$> ( 120 | forM [0..steps] $ \step -> 121 | pure (mkChunk step chunkSize)) 122 | 123 | 124 | buildBufConcat :: Int -> Int -> IO BS.ByteString 125 | buildBufConcat steps chunkSize = 126 | BS.concat <$> ( 127 | forM [0..steps] $ \step -> 128 | pure (mkChunk step chunkSize)) 129 | -------------------------------------------------------------------------------- /cbits/superbuffer.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | struct sbuf { 6 | char *contents; 7 | size_t currentSize; 8 | size_t maxSize; 9 | }; 10 | 11 | struct sbuf *new_sbuf(const size_t initSize) 12 | { 13 | char *contents = (char *)malloc(initSize + 1); 14 | contents[0] = '\0'; 15 | 16 | struct sbuf *buf = (struct sbuf *)malloc(sizeof(struct sbuf)); 17 | buf->contents = contents; 18 | buf->currentSize = 0; 19 | buf->maxSize = initSize; 20 | 21 | return buf; 22 | } 23 | 24 | void append_sbuf(struct sbuf *buf, const char *value, const size_t len) 25 | { 26 | if (len == 0) { 27 | return; 28 | } 29 | const size_t nextSize = buf->currentSize + len; 30 | if (nextSize > buf->maxSize) { 31 | buf->maxSize = nextSize + (nextSize >> 1); 32 | buf->contents = (char *)realloc(buf->contents, buf->maxSize); 33 | } 34 | 35 | char *targetLocation = buf->contents + buf->currentSize; 36 | memcpy(targetLocation, value, len); 37 | buf->currentSize = nextSize; 38 | } 39 | 40 | char *read_sbuf(struct sbuf *buf, size_t *len) 41 | { 42 | if (buf->currentSize < buf->maxSize) { 43 | buf->contents = (char *)realloc(buf->contents, buf->currentSize); 44 | buf->maxSize = buf->currentSize; // not strictly needed, but for consistency 45 | } 46 | *len = buf->currentSize; 47 | return buf->contents; 48 | } 49 | 50 | void destroyContents_sbuf(const struct sbuf *buf) 51 | { 52 | free(buf->contents); 53 | } 54 | 55 | void destroy_sbuf(struct sbuf *buf) 56 | { 57 | free(buf); 58 | } 59 | 60 | size_t size_sbuf(struct sbuf *buf) 61 | { 62 | return buf->currentSize; 63 | } 64 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | cache_directories: 3 | - "~/.stack" 4 | - ".stack-work" 5 | pre: 6 | - wget https://github.com/commercialhaskell/stack/releases/download/v1.2.0/stack-1.2.0-linux-x86_64.tar.gz -O /tmp/stack.tar.gz 7 | - tar -C /tmp -xvf /tmp/stack.tar.gz && chmod +x /tmp/stack-1.2.0-linux-x86_64/stack 8 | - sudo mv /tmp/stack-1.2.0-linux-x86_64/stack /usr/bin/stack 9 | override: 10 | - stack setup 11 | - stack build --test --only-dependencies 12 | 13 | test: 14 | override: 15 | - stack test --pedantic 16 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: superbuffer 2 | version: 0.3.1.2 3 | synopsis: Efficiently build a bytestring from smaller chunks 4 | description: Efficiently (both fast and memory efficient) build a bytestring from smaller chunks 5 | homepage: https://github.com/agrafix/superbuffer#readme 6 | license: BSD3 7 | author: Alexander Thiemann 8 | maintainer: mail@athiemann.net 9 | copyright: 2016 - 2022 Alexander Thiemann 10 | category: Web 11 | extra-source-files: 12 | - README.md 13 | - stack.yaml 14 | - package.yaml 15 | 16 | dependencies: 17 | - base >= 4.8 && < 5 18 | - bytestring < 0.12 19 | 20 | ghc-options: -Wall 21 | 22 | library: 23 | source-dirs: src 24 | exposed-modules: 25 | - Data.ByteString.SuperBuffer 26 | - Data.ByteString.SuperBuffer.Pure 27 | c-sources: cbits/superbuffer.c 28 | 29 | tests: 30 | spec: 31 | cpp-options: -DTest 32 | main: Test.hs 33 | source-dirs: test 34 | dependencies: 35 | - HTF < 0.16 36 | - QuickCheck < 2.15 37 | - async 38 | - superbuffer 39 | ghc-options: -funfolding-use-threshold=16 -O2 -optc-Ofast 40 | 41 | benchmarks: 42 | sbuf-bench: 43 | main: Bench.hs 44 | source-dirs: bench 45 | dependencies: 46 | - criterion < 1.3 47 | - superbuffer 48 | - buffer-builder 49 | - async 50 | ghc-options: -funfolding-use-threshold=16 -O2 -optc-Ofast 51 | -------------------------------------------------------------------------------- /src/Data/ByteString/SuperBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Data.ByteString.SuperBuffer 5 | ( SuperBuffer, withBuffer, appendBuffer, appendBufferT, size 6 | ) 7 | where 8 | 9 | import Control.Concurrent.MVar 10 | import Control.Exception 11 | import Data.Coerce 12 | import Foreign 13 | import Foreign.C 14 | import qualified Data.ByteString as BS 15 | import qualified Data.ByteString.Unsafe as BS 16 | 17 | -- | The buffer. Internally only a pointer to a C struct. Don't worry, 18 | -- this module attempts to make usage of the SuperBuffer as safe as possible in 19 | -- terms of memory leaks (even when exceptions occur). 20 | newtype SuperBuffer 21 | = SuperBuffer (SuperBufferP, MVar ()) 22 | 23 | -- | Allocate a new buffer with a given initial size. The perfect starting point 24 | -- depends on the expected total size and the average size for a single chunk 25 | -- written with 'appendBuffer'. You can always start with 1024 and optimize from 26 | -- there with benchmarks. Please note that the SuperBuffer will no longer be 27 | -- valid after this function terminates, so do NOT pass it to some other 28 | -- thread without waiting for it to finish in the action. 29 | withBuffer :: Int64 -> (SuperBuffer -> IO ()) -> IO BS.ByteString 30 | withBuffer sz action = 31 | bracket (newBuffer sz) destroyBuffer $ \buf -> 32 | do ok <- try (action buf) 33 | case ok of 34 | Left (exception :: SomeException) -> 35 | do destroyBufferContents buf 36 | throwIO exception 37 | Right () -> 38 | readBuffer buf -- if something goes to shit here, we could be in trouble... 39 | {-# INLINE withBuffer #-} 40 | 41 | newBuffer :: Int64 -> IO SuperBuffer 42 | newBuffer sz = SuperBuffer <$> ((,) <$> new_sbuf (fromIntegral sz) <*> newEmptyMVar) 43 | {-# INLINE newBuffer #-} 44 | 45 | 46 | -- | Write a bytestring to the buffer and grow the buffer if needed. Note that only 47 | -- one thread at any given time may call this function. Use 'appendBufferT' when 48 | -- accessing 'SuperBuffer' from multiple threads. 49 | appendBuffer :: SuperBuffer -> BS.ByteString -> IO () 50 | appendBuffer (SuperBuffer (ptr, _)) bs = 51 | BS.unsafeUseAsCStringLen bs $ \(cstr, len) -> 52 | append_sbuf ptr cstr (fromIntegral len) 53 | {-# INLINE appendBuffer #-} 54 | 55 | -- | Write a bytestring to the buffer and grow the buffer if needed. This function 56 | -- can be used accross different threads, but is slower than 'appendBuffer'. 57 | appendBufferT :: SuperBuffer -> BS.ByteString -> IO () 58 | appendBufferT buf@(SuperBuffer (_, lock)) bs = 59 | bracket_ (putMVar lock ()) (takeMVar lock) $ 60 | appendBuffer buf bs 61 | {-# INLINE appendBufferT #-} 62 | 63 | destroyBuffer :: SuperBuffer -> IO () 64 | destroyBuffer (SuperBuffer (ptr, _)) = destroy_sbuf ptr 65 | {-# INLINE destroyBuffer #-} 66 | 67 | destroyBufferContents :: SuperBuffer -> IO () 68 | destroyBufferContents (SuperBuffer (ptr, _)) = destroyContents_sbuf ptr 69 | {-# INLINE destroyBufferContents #-} 70 | 71 | -- | Read the final buffer contents. This must only 72 | -- be called once 73 | readBuffer :: SuperBuffer -> IO BS.ByteString 74 | readBuffer (SuperBuffer (ptr, _)) = 75 | do (cstr, sz) <- readLocal 76 | BS.unsafePackCStringFinalizer (coerce cstr) (fromIntegral sz) (free cstr) 77 | where 78 | readLocal = 79 | alloca $ \sizePtr -> 80 | do cstr <- read_sbuf ptr sizePtr 81 | sz <- peek sizePtr 82 | pure (cstr, sz) 83 | {-# INLINE readBuffer #-} 84 | 85 | -- | Get current (filled) size of the buffer 86 | size :: SuperBuffer -> IO Int 87 | size (SuperBuffer (ptr, _)) = 88 | fromIntegral <$> size_sbuf ptr 89 | {-# INLINE size #-} 90 | 91 | data SBuf 92 | type SuperBufferP = Ptr SBuf 93 | 94 | foreign import ccall unsafe "new_sbuf" new_sbuf :: CSize -> IO SuperBufferP 95 | foreign import ccall unsafe "append_sbuf" append_sbuf :: SuperBufferP -> CString -> CSize -> IO () 96 | foreign import ccall unsafe "read_sbuf" read_sbuf :: SuperBufferP -> Ptr CSize -> IO CString 97 | foreign import ccall unsafe "destroy_sbuf" destroy_sbuf :: SuperBufferP -> IO () 98 | foreign import ccall unsafe "destroyContents_sbuf" destroyContents_sbuf :: SuperBufferP -> IO () 99 | foreign import ccall unsafe "size_sbuf" size_sbuf :: SuperBufferP -> IO CSize 100 | -------------------------------------------------------------------------------- /src/Data/ByteString/SuperBuffer/Pure.hs: -------------------------------------------------------------------------------- 1 | module Data.ByteString.SuperBuffer.Pure 2 | ( SuperBuffer, withBuffer, appendBuffer, appendBufferT, size ) 3 | where 4 | 5 | import Control.Concurrent.MVar 6 | import Control.Exception 7 | import Data.Bits 8 | import Data.IORef 9 | import Data.Word 10 | import Foreign.Marshal.Alloc 11 | import Foreign.Marshal.Utils 12 | import Foreign.Ptr 13 | import qualified Data.ByteString as BS 14 | import qualified Data.ByteString.Unsafe as BS 15 | 16 | -- | The buffer data structure. 17 | data SuperBuffer 18 | = SuperBuffer 19 | { sb_buffer :: {-# UNPACK #-}!(IORef (Ptr Word8)) 20 | , sb_currentSize :: {-# UNPACK #-}!(IORef Int) 21 | , sb_maxSize :: {-# UNPACK #-}!(IORef Int) 22 | , sb_lock :: {-# UNPACK #-}!(MVar ()) 23 | } 24 | 25 | -- | Allocate a new buffer with a given initial size. The perfect starting point 26 | -- depends on the expected total size and the average size for a single chunk 27 | -- written with 'appendBuffer'. You can always start with 1024 and optimize from 28 | -- there with benchmarks. Please note that the SuperBuffer will no longer be 29 | -- valid after this function terminates, so do NOT pass it to some other 30 | -- thread without waiting for it to finish in the action. 31 | withBuffer :: Int -> (SuperBuffer -> IO ()) -> IO BS.ByteString 32 | withBuffer sz action = 33 | do ptr <- mallocBytes sz 34 | ptrRef <- newIORef ptr 35 | go ptrRef `onException` freeOnException ptrRef 36 | where 37 | freeOnException ref = 38 | do ptr <- readIORef ref 39 | free ptr 40 | go ptrRef = 41 | do sizeRef <- newIORef 0 42 | maxSizeRef <- newIORef sz 43 | lock <- newEmptyMVar 44 | let sb = SuperBuffer ptrRef sizeRef maxSizeRef lock 45 | action sb 46 | readBuffer sb 47 | {-# INLINE withBuffer #-} 48 | 49 | -- | Write a bytestring to the buffer and grow the buffer if needed. Note that only 50 | -- one thread at any given time may call this function. Use 'appendBufferT' when 51 | -- accessing 'SuperBuffer' from multiple threads. 52 | appendBuffer :: SuperBuffer -> BS.ByteString -> IO () 53 | appendBuffer sb bs 54 | | BS.null bs = pure () 55 | | otherwise = 56 | BS.unsafeUseAsCStringLen bs $ \(cstr, len) -> 57 | do currentSize <- readIORef (sb_currentSize sb) 58 | maxSize <- readIORef (sb_maxSize sb) 59 | let nextSize = currentSize + len 60 | writePtr <- 61 | if nextSize > maxSize 62 | then do let maxSize' = nextSize + unsafeShiftR nextSize 1 63 | writeIORef (sb_maxSize sb) maxSize' 64 | buff <- readIORef (sb_buffer sb) 65 | buff' <- reallocBytes buff maxSize' 66 | writeIORef (sb_buffer sb) buff' 67 | pure buff' 68 | else readIORef (sb_buffer sb) 69 | let copyTarget = writePtr `plusPtr` currentSize 70 | copyBytes copyTarget cstr len 71 | writeIORef (sb_currentSize sb) (currentSize + len) 72 | {-# INLINE appendBuffer #-} 73 | 74 | -- | Write a bytestring to the buffer and grow the buffer if needed. This function 75 | -- can be used accross different threads, but is slower than 'appendBuffer'. 76 | appendBufferT :: SuperBuffer -> BS.ByteString -> IO () 77 | appendBufferT sb bs = 78 | bracket_ (putMVar (sb_lock sb) ()) (takeMVar (sb_lock sb)) $ 79 | appendBuffer sb bs 80 | {-# INLINE appendBufferT #-} 81 | 82 | -- | Read the final buffer contents. This must only be called once 83 | readBuffer :: SuperBuffer -> IO BS.ByteString 84 | readBuffer sb = 85 | do (buff, currentSize, maxSize) <- 86 | (,,) 87 | <$> readIORef (sb_buffer sb) 88 | <*> readIORef (sb_currentSize sb) 89 | <*> readIORef (sb_maxSize sb) 90 | finalPtr <- 91 | if currentSize < maxSize 92 | then reallocBytes buff currentSize 93 | else pure buff 94 | BS.unsafePackCStringFinalizer finalPtr currentSize (free finalPtr) 95 | {-# INLINE readBuffer #-} 96 | 97 | -- | Get current (filled) size of the buffer 98 | size :: SuperBuffer -> IO Int 99 | size sb = readIORef $ sb_currentSize sb 100 | {-# INLINE size #-} 101 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - buffer-builder-0.2.4.3 7 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: buffer-builder-0.2.4.3@sha256:959e159ece20294183d3c83acdf20114d4e744d7e88ec144424a014849acbb14,5141 9 | pantry-tree: 10 | size: 1158 11 | sha256: 0e9450d448bd7022f3ad0820b719df0cf6c25d7226b97b0c828594f698ae3df4 12 | original: 13 | hackage: buffer-builder-0.2.4.3 14 | snapshots: 15 | - completed: 16 | size: 586110 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml 18 | sha256: ce4fb8d44f3c6c6032060a02e0ebb1bd29937c9a70101c1517b92a87d9515160 19 | original: 20 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml 21 | -------------------------------------------------------------------------------- /superbuffer.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: superbuffer 8 | version: 0.3.1.2 9 | synopsis: Efficiently build a bytestring from smaller chunks 10 | description: Efficiently (both fast and memory efficient) build a bytestring from smaller chunks 11 | category: Web 12 | homepage: https://github.com/agrafix/superbuffer#readme 13 | author: Alexander Thiemann 14 | maintainer: mail@athiemann.net 15 | copyright: 2016 - 2022 Alexander Thiemann 16 | license: BSD3 17 | license-file: LICENSE 18 | build-type: Simple 19 | extra-source-files: 20 | README.md 21 | stack.yaml 22 | package.yaml 23 | 24 | library 25 | exposed-modules: 26 | Data.ByteString.SuperBuffer 27 | Data.ByteString.SuperBuffer.Pure 28 | other-modules: 29 | Paths_superbuffer 30 | hs-source-dirs: 31 | src 32 | ghc-options: -Wall 33 | c-sources: 34 | cbits/superbuffer.c 35 | build-depends: 36 | base >=4.8 && <5 37 | , bytestring <0.12 38 | default-language: Haskell2010 39 | 40 | test-suite spec 41 | type: exitcode-stdio-1.0 42 | main-is: Test.hs 43 | other-modules: 44 | Paths_superbuffer 45 | hs-source-dirs: 46 | test 47 | ghc-options: -Wall -funfolding-use-threshold=16 -O2 -optc-Ofast 48 | cpp-options: -DTest 49 | build-depends: 50 | HTF <0.16 51 | , QuickCheck <2.15 52 | , async 53 | , base >=4.8 && <5 54 | , bytestring <0.12 55 | , superbuffer 56 | default-language: Haskell2010 57 | 58 | benchmark sbuf-bench 59 | type: exitcode-stdio-1.0 60 | main-is: Bench.hs 61 | other-modules: 62 | Paths_superbuffer 63 | hs-source-dirs: 64 | bench 65 | ghc-options: -Wall -funfolding-use-threshold=16 -O2 -optc-Ofast 66 | build-depends: 67 | async 68 | , base >=4.8 && <5 69 | , buffer-builder 70 | , bytestring <0.12 71 | , criterion <1.3 72 | , superbuffer 73 | default-language: Haskell2010 74 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Control.Concurrent.Async 6 | import Control.Monad 7 | import Data.ByteString.SuperBuffer 8 | import Data.Int 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.SuperBuffer.Pure as P 11 | 12 | import Test.Framework 13 | import Test.QuickCheck.Monadic 14 | 15 | main :: IO () 16 | main = htfMain htf_thisModulesTests 17 | 18 | test_size :: IO () 19 | test_size = 20 | void $ 21 | withBuffer 8 $ \buf -> 22 | do appendBuffer buf "hello" 23 | sz <- size buf 24 | assertEqual sz 5 25 | 26 | test_basic :: IO () 27 | test_basic = 28 | do bs <- fillBuf 29 | assertEqual bs expected 30 | where 31 | expected = 32 | "hello world! Welcome to S U P E R B U F F E R" 33 | fillBuf = 34 | withBuffer 8 $ \buf -> 35 | do appendBuffer buf "hello" 36 | appendBuffer buf " world" 37 | appendBuffer buf "!" 38 | appendBuffer buf " Welcome" 39 | appendBuffer buf " to" 40 | appendBuffer buf " S U P E R B U F F E R" 41 | 42 | test_nullContained :: IO () 43 | test_nullContained = 44 | do bs <- fillBuf 45 | assertEqual bs expected 46 | where 47 | expected = 48 | "hello\0world" 49 | fillBuf = 50 | withBuffer 8 $ \buf -> 51 | do appendBuffer buf "hello" 52 | appendBuffer buf "\0world" 53 | 54 | test_threaded :: IO () 55 | test_threaded = 56 | do bs <- fillBuf 57 | assertEqual bs expected 58 | where 59 | expected = 60 | "hello world! Welcome to S U P E R B U F F E R" 61 | fillBuf = 62 | withBuffer 8 $ \buf -> 63 | forConcurrently_ ["hello", " world", "!", " Welcome", " to", " S U P E R B U F F E R"] $ 64 | appendBufferT buf 65 | 66 | newtype BufferChunks 67 | = BufferChunks { unBufferChunks :: (Int64, [BS.ByteString]) } 68 | deriving (Show, Eq) 69 | 70 | instance Arbitrary BufferChunks where 71 | arbitrary = -- 5000 * 200 000 = 1 GB max 72 | do listSize <- choose (1, 5000) 73 | chunks <- 74 | replicateM listSize $ 75 | do bsSize <- choose (0, 200000) 76 | pure $ BS.replicate bsSize 84 77 | bufSize <- choose (1, 1024 * 1024 * 1024) 78 | pure $ BufferChunks (bufSize, chunks) 79 | 80 | prop_appendingWorks :: BufferChunks -> Property 81 | prop_appendingWorks (BufferChunks (bufSize, chunks)) = 82 | monadicIO $ 83 | do out <- run chunkAction 84 | assert $ out == BS.concat chunks 85 | where 86 | chunkAction = 87 | withBuffer bufSize $ \buf -> 88 | forM_ chunks $ appendBuffer buf 89 | 90 | test_sizePure :: IO () 91 | test_sizePure = 92 | void $ 93 | P.withBuffer 8 $ \buf -> 94 | do P.appendBuffer buf "hello" 95 | sz <- P.size buf 96 | assertEqual sz 5 97 | 98 | test_basicPure :: IO () 99 | test_basicPure = 100 | do bs <- fillBuf 101 | assertEqual bs expected 102 | where 103 | expected = 104 | "hello world! Welcome to S U P E R B U F F E R" 105 | fillBuf = 106 | P.withBuffer 8 $ \buf -> 107 | do P.appendBuffer buf "hello" 108 | P.appendBuffer buf " world" 109 | P.appendBuffer buf "!" 110 | P.appendBuffer buf " Welcome" 111 | P.appendBuffer buf " to" 112 | P.appendBuffer buf " S U P E R B U F F E R" 113 | 114 | test_nullContainedPure :: IO () 115 | test_nullContainedPure = 116 | do bs <- fillBuf 117 | assertEqual bs expected 118 | where 119 | expected = 120 | "hello\0world" 121 | fillBuf = 122 | P.withBuffer 8 $ \buf -> 123 | do P.appendBuffer buf "hello" 124 | P.appendBuffer buf "\0world" 125 | 126 | test_threadedPure :: IO () 127 | test_threadedPure = 128 | do bs <- fillBuf 129 | assertEqual bs expected 130 | where 131 | expected = 132 | "hello world! Welcome to S U P E R B U F F E R" 133 | fillBuf = 134 | P.withBuffer 8 $ \buf -> 135 | forConcurrently_ ["hello", " world", "!", " Welcome", " to", " S U P E R B U F F E R"] $ 136 | P.appendBufferT buf 137 | 138 | prop_appendingWorksPure :: BufferChunks -> Property 139 | prop_appendingWorksPure (BufferChunks (bufSize, chunks)) = 140 | monadicIO $ 141 | do out <- run chunkAction 142 | assert $ out == BS.concat chunks 143 | where 144 | chunkAction = 145 | P.withBuffer (fromIntegral bufSize) $ \buf -> 146 | forM_ chunks $ P.appendBuffer buf 147 | --------------------------------------------------------------------------------