git.iko.soy/typeable/wai
on master help sign in
Merge pull request #180 from yesodweb/no-resourcet-tuning

Yield hack and a new receive function.

commit6856da8c9ff437548b72f7faa7e202a655c670d3 authorMichael Snoyman <michael@snoyman.com> dateWed 9 Oct 2013, 03:39 (13 years ago) parent08fa25c915ec86
7 files changed+106−28
compare with master
unifiedsplit
wai-handler-launch/Network/Wai/Handler/Launch.hs+1−1 warp/Network/Wai/Handler/Warp/FdCache.hs−1 warp/Network/Wai/Handler/Warp/Recv.hs+69 warp/Network/Wai/Handler/Warp/Run.hs+31−22 warp/Network/Wai/Handler/Warp/Settings.hs+3−3 warp/test/RunSpec.hs+1−1 warp/warp.cabal+1
wai-handler-launch/Network/Wai/Handler/Launch.hs+1−1
@@ -140,7 +140,7 @@ runUrlPort port url app = do
140140 x <- newIORef True
141141 _ <- forkIO $ Warp.runSettings Warp.defaultSettings
142142 { Warp.settingsPort = port
143− , Warp.settingsOnException = const $ return ()
143+ , Warp.settingsOnException = (\_ _ -> return ())
144144 , Warp.settingsHost = "*4"
145145 } $ ping x app
146146 launch port url
warp/Network/Wai/Handler/Warp/FdCache.hs−1
@@ -9,7 +9,6 @@ module Network.Wai.Handler.Warp.FdCache (
99import Control.Applicative ((<$>), (<*>))
1010import Control.Concurrent
1111import Control.Exception (mask_)
12−import Control.Monad
1312import Data.Hashable
1413import Data.IORef
1514import Network.Wai.Handler.Warp.MultiMap
warp/Network/Wai/Handler/Warp/Recv.hsnew file+69
@@ -0,0 +1,69 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+
3+-- fixme: windows support
4+
5+module Network.Wai.Handler.Warp.Recv (
6+ ReceiveBuffer
7+ , receive
8+ , allocateRecvBuffer
9+ , freeRecvBuffer
10+ ) where
11+
12+import Control.Applicative ((<$>))
13+import Control.Monad (void)
14+import qualified Data.ByteString as BS (empty)
15+import Data.ByteString.Internal (ByteString(..), mallocByteString)
16+import Data.Word (Word8)
17+import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
18+import Foreign.C.Types
19+import Foreign.ForeignPtr (withForeignPtr)
20+import Foreign.Ptr (Ptr, castPtr)
21+import GHC.Conc (threadWaitRead)
22+import Network.Socket (Socket, fdSocket)
23+import System.Posix.Types (Fd(..))
24+import Foreign.Marshal.Alloc (mallocBytes, free)
25+
26+----------------------------------------------------------------
27+
28+type ReceiveBuffer = Ptr Word8
29+
30+allocateRecvBuffer :: Int -> IO ReceiveBuffer
31+allocateRecvBuffer = mallocBytes
32+
33+freeRecvBuffer :: ReceiveBuffer -> IO ()
34+freeRecvBuffer = free
35+
36+receive :: Socket -> ReceiveBuffer -> Int -> IO ByteString
37+receive sock buf size = do
38+ bytes <- fromIntegral <$> receiveloop sock' buf' size'
39+ if bytes == 0 then
40+ return BS.empty
41+ else do
42+ fptr <- mallocByteString bytes
43+ void $ withForeignPtr fptr $ \ptr ->
44+ c_memcpy ptr buf (fromIntegral bytes)
45+ return $! PS fptr 0 bytes
46+ where
47+ sock' = fdSocket sock
48+ buf' = castPtr buf
49+ size' = fromIntegral size
50+
51+receiveloop :: CInt -> Ptr CChar -> CSize -> IO CInt
52+receiveloop sock buf size = do
53+ bytes <- c_recv sock buf size 0
54+ if bytes == -1 then do
55+ errno <- getErrno
56+ if errno == eAGAIN then do
57+ threadWaitRead (Fd sock)
58+ receiveloop sock buf size
59+ else
60+ throwErrno "receiveloop"
61+ else
62+ return bytes
63+
64+-- fixme: the type of the return value
65+foreign import ccall unsafe "recv"
66+ c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
67+
68+foreign import ccall unsafe "string.h memcpy"
69+ c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
warp/Network/Wai/Handler/Warp/Run.hs+31−22
@@ -4,7 +4,8 @@
44module Network.Wai.Handler.Warp.Run where
55
66import Control.Concurrent (threadDelay, forkIOWithUnmask)
7−import Control.Exception
7+import qualified Control.Concurrent as Conc (yield)
8+import Control.Exception as E
89import Control.Monad (forever, when, unless, void)
910import Control.Monad.IO.Class (MonadIO, liftIO)
1011import Data.ByteString (ByteString)
@@ -23,11 +24,7 @@ import Network.Wai.Handler.Warp.Response
2324import Network.Wai.Handler.Warp.Settings
2425import qualified Network.Wai.Handler.Warp.Timeout as T
2526import Network.Wai.Handler.Warp.Types
26−import Prelude hiding (catch)
27−
28−-- Sock.recv first tries to call recvfrom() optimistically.
29−-- If EAGAIN returns, it polls incoming data with epoll/kqueue.
30−-- This code first polls incoming data with epoll/kqueue.
27+import Network.Wai.Handler.Warp.Recv
3128
3229#if WINDOWS
3330import qualified Control.Concurrent.MVar as MV
@@ -48,14 +45,16 @@ bytesPerRead :: Int
4845bytesPerRead = 4096
4946
5047-- | Default action value for 'Connection'
51−socketConnection :: Socket -> Connection
52−socketConnection s = Connection
53− { connSendMany = Sock.sendMany s
54− , connSendAll = Sock.sendAll s
55− , connSendFile = sendFile s
56− , connClose = sClose s
57− , connRecv = Sock.recv s bytesPerRead
58− }
48+socketConnection :: Socket -> IO Connection
49+socketConnection s = do
50+ buf <- allocateRecvBuffer bytesPerRead
51+ return Connection {
52+ connSendMany = Sock.sendMany s
53+ , connSendAll = Sock.sendAll s
54+ , connSendFile = sendFile s
55+ , connClose = sClose s >> freeRecvBuffer buf
56+ , connRecv = receive s buf bytesPerRead
57+ }
5958
6059sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()
6160#if SENDFILEFD
@@ -110,12 +109,13 @@ runSettings set app =
110109-- 'serverPort' record.
111110runSettingsSocket :: Settings -> Socket -> Application -> IO ()
112111runSettingsSocket set socket app =
113− runSettingsConnection set getter app
112+ runSettingsConnection set getConn app
114113 where
115− getter = do
116− (conn, sa) <- accept socket
114+ getConn = do
115+ (s, sa) <- accept socket
117116 setSocketCloseOnExec socket
118− return (socketConnection conn, sa)
117+ conn <- socketConnection s
118+ return (conn, sa)
119119
120120runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
121121runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app
@@ -131,7 +131,7 @@ runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMa
131131--
132132-- Since 1.3.5
133133runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
134−runSettingsConnectionMaker set getConn app = do
134+runSettingsConnectionMaker set getConnMaker app = do
135135#if SENDFILEFD
136136 let duration = settingsFdCacheDuration set
137137 fc <- case duration of
@@ -199,7 +199,7 @@ runSettingsConnectionMaker set getConn app = do
199199 in unmask .
200200 -- Call the user-supplied on exception code if any
201201 -- exceptions are thrown.
202− handle onE .
202+ handle (onE Nothing) .
203203
204204 -- Call the user-supplied code for connection open and close events
205205 bracket_ onOpen onClose $
@@ -208,8 +208,8 @@ runSettingsConnectionMaker set getConn app = do
208208 serveConnection th set cleaner app conn addr
209209 where
210210 -- FIXME: only IOEception is caught. What about other exceptions?
211− getConnLoop = getConn `catch` \(e :: IOException) -> do
212− onE (toException e)
211+ getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do
212+ onE Nothing (toException e)
213213 -- "resource exhausted (Too many open files)" may happen by accept().
214214 -- Wait a second hoping that resource will be available.
215215 threadDelay 1000000
@@ -250,6 +250,15 @@ serveConnection timeoutHandle settings cleaner app conn remoteHost' =
250250 liftIO $ T.resume th
251251 sendResponse settings cleaner env conn restore res
252252
253+ -- | We just send a Response and it takes a time to
254+ -- receive a Request again. If we immediately call recv,
255+ -- it is likely to fail and the IO manager works.
256+ -- It is very costy. So, we yield to another Haskell
257+ -- thread hoping that the next Request will arraive
258+ -- when this Haskell thread will be re-scheduled.
259+ -- This improves performance at least when
260+ -- the number of cores is small.
261+ Conc.yield
253262 -- flush the rest of the request body
254263 requestBody env $$ CL.sinkNull
255264 ResumableSource fromClient' _ <- liftIO getSource
warp/Network/Wai/Handler/Warp/Settings.hs+3−3
@@ -21,7 +21,7 @@ import System.IO.Error (ioeGetErrorType)
2121data Settings = Settings
2222 { settingsPort :: Int -- ^ Port to listen on. Default value: 3000
2323 , settingsHost :: HostPreference -- ^ Default value: HostIPv4
24− , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
24+ , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
2525 , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing.
2626 , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing.
2727 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
@@ -61,8 +61,8 @@ defaultSettings = Settings
6161 , settingsServerName = S8.pack $ "Warp/" ++ warpVersion
6262 }
6363
64−defaultExceptionHandler :: SomeException -> IO ()
65−defaultExceptionHandler e = throwIO e `catches` handlers
64+defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()
65+defaultExceptionHandler _ e = throwIO e `catches` handlers
6666 where
6767 handlers = [Handler ah, Handler ih, Handler oh, Handler sh]
6868
warp/test/RunSpec.hs+1−1
@@ -118,7 +118,7 @@ runTerminateTest :: InvalidRequest
118118runTerminateTest expected input = do
119119 ref <- I.newIORef Nothing
120120 withApp defaultSettings
121− { settingsOnException = \e -> I.writeIORef ref $ Just e
121+ { settingsOnException = \_ e -> I.writeIORef ref $ Just e
122122 } dummyApp $ \port -> do
123123 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
124124 hPutStr handle input
warp/warp.cabal+1
@@ -59,6 +59,7 @@ Library
5959 Network.Wai.Handler.Warp.Run
6060 Network.Wai.Handler.Warp.Settings
6161 Network.Wai.Handler.Warp.Types
62+ Network.Wai.Handler.Warp.Recv
6263 Paths_warp
6364 Ghc-Options: -Wall
6465 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)