git.iko.soy/streamly
on master help sign in
Do not use a blocking wait when dispatching workers
71b4134Harendra Kumar
src/Asyncly/AsyncT.hs+12−11
compare with master
unifiedsplit
@@ -379,19 +379,20 @@ pushWorker :: MonadAsync m => Context m a -> m ()
379pushWorker ctx =
379pushWorker ctx =
380 doFork (runqueue ctx) (handleChildException ctx) >>= addThread ctx
380 doFork (runqueue ctx) (handleChildException ctx) >>= addThread ctx
381
381
382+-- XXX When the queue is LIFO we can put a limit on the number of dispatches.
383+-- Also, if a worker blocks on the output queue we can decide if we want to
384+-- block or make it go away entirely, depending on the number of workers and
385+-- the type of the queue.
382{-# INLINE sendWorkerWait #-}
386{-# INLINE sendWorkerWait #-}
383sendWorkerWait :: MonadAsync m => Context m a -> m ()
387sendWorkerWait :: MonadAsync m => Context m a -> m ()
384−sendWorkerWait ctx = dispatch >> void (liftIO $ takeMVar (doorBell ctx))
388+sendWorkerWait ctx = do
385−
386− where
387−
388− dispatch = do
389− liftIO $ threadDelay 200
389+ liftIO $ threadDelay 200
390− output <- liftIO $ readIORef (outputQueue ctx)
390+ output <- liftIO $ readIORef (outputQueue ctx)
391− when (null output) $ do
391+ when (null output) $ do
392− done <- queueEmpty ctx
392+ done <- queueEmpty ctx
393− when (not done) $ (pushWorker ctx) >> dispatch
393+ if (not done)
394−
394+ then (pushWorker ctx) >> sendWorkerWait ctx
395+ else void (liftIO $ takeMVar (doorBell ctx))
395
396
396data ContextUsedAfterEOF = ContextUsedAfterEOF deriving Show
397data ContextUsedAfterEOF = ContextUsedAfterEOF deriving Show
397instance Exception ContextUsedAfterEOF
398instance Exception ContextUsedAfterEOF
test/Main.hs−4
@@ -150,9 +150,6 @@ main = hspec $ do
150 ((t 4 <|> t 8) <> (t 1 <|> t 2))
150 ((t 4 <|> t 8) <> (t 1 <|> t 2))
151 <|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
151 <|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
152 `shouldReturn` ([4,4,8,8,1,1,2,2])
152 `shouldReturn` ([4,4,8,8,1,1,2,2])
153− -- FIXME: These two keep failing intermittently on Mac OS X
154− -- Need to examine and fix the tests.
155− {-
156 it "Nest <|>, <=>, <|> (1)" $
153 it "Nest <|>, <=>, <|> (1)" $
157 let t = timed
154 let t = timed
158 in toList (
155 in toList (
@@ -165,7 +162,6 @@ main = hspec $ do
165 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
162 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
166 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
163 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
167 `shouldReturn` ([4,4,1,1,8,2,9,2])
164 `shouldReturn` ([4,4,1,1,8,2,9,2])
168− -}
169 it "Nest <|>, <|>, <|>" $
165 it "Nest <|>, <|>, <|>" $
170 let t = timed
166 let t = timed
171 in toList (
167 in toList (