d7658fd · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Receive buffering performance optimization, no memcpy and less malloc

d7658fdMartin Bailey12 years ago

warp/Network/Wai/Handler/Warp/Buffer.hs+48−2

compare with master

unifiedsplit

@@ -1,10 +1,56 @@

1module Network.Wai.Handler.Warp.Buffer where

3+import Control.Monad (when)

3import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))

4import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))

4import Data.Word (Word8)

5import Data.Word (Word8)

6+import Data.IORef (IORef, newIORef, readIORef, writeIORef)

7+import Data.ByteString (ByteString, empty, length)

8+import Data.ByteString.Internal (ByteString(PS), create)

9+import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)

5−import Foreign.ForeignPtr (newForeignPtr_)

10+import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr)

6import Foreign.Marshal.Alloc (mallocBytes, free)

11import Foreign.Marshal.Alloc (mallocBytes, free)

7−import Foreign.Ptr (Ptr, plusPtr)

12+import Foreign.Ptr (Ptr, castPtr, plusPtr)

13+

14+largeBufferSize :: Int

15+largeBufferSize = 16384

16+minBufferSize :: Int

17+minBufferSize = 2048

18+

19+type BufferPool = IORef ByteString

20+

21+newBufferPool :: IO BufferPool

22+newBufferPool = newIORef Data.ByteString.empty

23+

24+allocBuffer :: Int -> IO ByteString

25+allocBuffer size = create size initializer

26+ where initializer = \_ -> return ()

27+{-# INLINE allocBuffer #-}

28+

29+usefulBuffer :: ByteString -> Bool

30+usefulBuffer buffer = Data.ByteString.length buffer >= minBufferSize

31+{-# INLINE usefulBuffer #-}

32+

33+getBuffer :: BufferPool -> IO ByteString

34+getBuffer pool = do

35+ buffer <- readIORef pool

36+ if usefulBuffer buffer then return buffer else allocBuffer largeBufferSize

37+{-# INLINE getBuffer #-}

38+

39+putBuffer :: BufferPool -> ByteString -> IO ()

40+putBuffer pool buffer = when (usefulBuffer buffer) $ writeIORef pool buffer

41+{-# INLINE putBuffer #-}

42+

43+withForeignBuffer :: ByteString -> ((Ptr Word8, Int) -> IO Int) -> IO Int

44+withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)

45+{-# INLINE withForeignBuffer #-}

46+

47+withBufferPool :: BufferPool -> ((Ptr Word8, Int) -> IO Int) -> IO ByteString

48+withBufferPool pool f = do

49+ buffer <- getBuffer pool

50+ consumed <- withForeignBuffer buffer f

51+ putBuffer pool $! unsafeDrop consumed buffer

52+ return $! unsafeTake consumed buffer

53+{-# INLINE withBufferPool #-}

9type Buffer = Ptr Word8

55type Buffer = Ptr Word8

10type BufSize = Int

56type BufSize = Int

warp/Network/Wai/Handler/Warp/Recv.hs+12−30

@@ -8,18 +8,15 @@ module Network.Wai.Handler.Warp.Recv (

8#if __GLASGOW_HASKELL__ < 709

9import Control.Applicative ((<$>))

10#endif

11−import Control.Monad (void)

12−import qualified Data.ByteString as BS (empty)

11+import Data.ByteString (ByteString)

13−import Data.ByteString.Internal (ByteString(..), mallocByteString)

14import Data.Word (Word8)

12import Data.Word (Word8)

15import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

13import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

16import Foreign.C.Types

14import Foreign.C.Types

17−import Foreign.ForeignPtr (withForeignPtr)

18import Foreign.Ptr (Ptr, castPtr)

15import Foreign.Ptr (Ptr, castPtr)

19import GHC.Conc (threadWaitRead)

16import GHC.Conc (threadWaitRead)

20import Network.Socket (Socket, fdSocket)

17import Network.Socket (Socket, fdSocket)

21−import System.Posix.Types (Fd(..))

22import Network.Wai.Handler.Warp.Buffer

18import Network.Wai.Handler.Warp.Buffer

19+import System.Posix.Types (Fd(..))

24#ifdef mingw32_HOST_OS

21#ifdef mingw32_HOST_OS

25import GHC.IO.FD (FD(..), readRawBufferPtr)

22import GHC.IO.FD (FD(..), readRawBufferPtr)

@@ -28,37 +25,25 @@ import Network.Wai.Handler.Warp.Windows

29----------------------------------------------------------------

26----------------------------------------------------------------

31−receive :: Socket -> Buffer -> Int -> IO ByteString

28+receive :: Socket -> BufferPool -> IO ByteString

32−receive sock buf size = do

29+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

33− bytes <- fromIntegral <$> receiveloop sock' buf' size'

34− if bytes == 0 then

35− return BS.empty

36− else do

37− fptr <- mallocByteString bytes

38− void $ withForeignPtr fptr $ \ptr ->

39− c_memcpy ptr buf (fromIntegral bytes)

40− return $! PS fptr 0 bytes

41− where

42− sock' = fdSocket sock

30+ let sock' = fdSocket sock

43− buf' = castPtr buf

31+ size' = fromIntegral size

44− size' = fromIntegral size

32+ received <- fromIntegral <$> receiveloop sock' ptr size'

33+ return received

46−#ifdef mingw32_HOST_OS

47receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

35receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

48−#else

49−receiveloop :: CInt -> Ptr CChar -> CSize -> IO CInt

50−#endif

51−receiveloop sock buf size = do

36+receiveloop sock ptr size = do

52#ifdef mingw32_HOST_OS

37#ifdef mingw32_HOST_OS

53− bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) buf 0 size

38+ bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) ptr 0 size

54#else

39#else

55− bytes <- c_recv sock buf size 0

40+ bytes <- c_recv sock (castPtr ptr) size 0

56#endif

41#endif

57 if bytes == -1 then do

42 if bytes == -1 then do

58 errno <- getErrno

43 errno <- getErrno

59 if errno == eAGAIN then do

44 if errno == eAGAIN then do

60 threadWaitRead (Fd sock)

45 threadWaitRead (Fd sock)

61− receiveloop sock buf size

46+ receiveloop sock ptr size

62 else

47 else

63 throwErrno "receiveloop"

48 throwErrno "receiveloop"

64 else

49 else

@@ -67,6 +52,3 @@ receiveloop sock buf size = do

67-- fixme: the type of the return value

52-- fixme: the type of the return value

68foreign import ccall unsafe "recv"

53foreign import ccall unsafe "recv"

69 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

54 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

70−

71−foreign import ccall unsafe "string.h memcpy"

72− c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)

warp/Network/Wai/Handler/Warp/Run.hs+5−3

@@ -48,14 +48,16 @@ import Network.Socket (fdSocket)

48-- | Default action value for 'Connection'.

49socketConnection :: Socket -> IO Connection

50socketConnection s = do

51+ bufferPool <- newBufferPool

51− readBuf <- allocateBuffer bufferSize

52+ readBuf <- allocateBuffer 0 -- kept for backward compatibility

52 writeBuf <- allocateBuffer bufferSize

53 writeBuf <- allocateBuffer bufferSize

53 return Connection {

54 return Connection {

54 connSendMany = Sock.sendMany s

55 connSendMany = Sock.sendMany s

55 , connSendAll = Sock.sendAll s

56 , connSendAll = Sock.sendAll s

56 , connSendFile = defaultSendFile s

57 , connSendFile = defaultSendFile s

57− , connClose = sClose s >> freeBuffer readBuf >> freeBuffer writeBuf

58+ , connClose = sClose s >> freeBuffer writeBuf

58− , connRecv = receive s readBuf bufferSize

59+ , connRecv = receive s bufferPool

60+ , connBufferPool = bufferPool

59 , connReadBuffer = readBuf

61 , connReadBuffer = readBuf

60 , connWriteBuffer = writeBuf

62 , connWriteBuffer = writeBuf

61 , connBufferSize = bufferSize

63 , connBufferSize = bufferSize

warp/Network/Wai/Handler/Warp/Types.hs+3−1

@@ -12,7 +12,7 @@ import Data.Typeable (Typeable)

12import Data.Word (Word16)

13import Network.HTTP.Types.Header

14import Network.Socket (Socket)

15−import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)

15+import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize,BufferPool)

16import qualified Network.Wai.Handler.Warp.Date as D

17import qualified Network.Wai.Handler.Warp.FdCache as F

18import qualified Network.Wai.Handler.Warp.Timeout as T

@@ -79,7 +79,9 @@ data Connection = Connection

79 , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ filepath, offset, length, hook action, HTTP headers

80 , connClose :: IO ()

81 , connRecv :: IO ByteString

82+ , connBufferPool :: BufferPool

82 , connReadBuffer :: Buffer

83 , connReadBuffer :: Buffer

84+ -- ^ NOTE: This is kept just for backwards compatibility, and is no longer used at all.

83 , connWriteBuffer :: Buffer

85 , connWriteBuffer :: Buffer

84 , connBufferSize :: BufSize

86 , connBufferSize :: BufSize

85 , connSendFileOverride :: ConnSendFileOverride

87 , connSendFileOverride :: ConnSendFileOverride