@@ -18,7 +18,7 @@ import Control.Concurrent
1818import Control.Concurrent.STM
1919 (TChan, atomically, newTChan, readTChan, tryReadTChan, writeTChan)
2020import Control.Exception (SomeException(..), ErrorCall(..), catch)
21−import qualified Control.Exception.Lifted as E
21+import qualified Control.Exception.Lifted as EL
2222import Data.Dynamic (Typeable)
2323import Data.IORef
2424 (IORef, atomicModifyIORef, readIORef, writeIORef, modifyIORef,
@@ -102,20 +102,19 @@ instance Read SomeException where
102102forkFinally1 :: (MonadIO m, MonadBaseControl IO m) =>
103103 m a -> (Either SomeException a -> IO ()) -> m ThreadId
104104forkFinally1 action and_then =
105− E.mask $ \restore ->
105+ EL.mask $ \restore ->
106106 liftBaseWith $ \runInIO -> forkIO $ do
107− runInIO $ E.try (restore action) >>= liftIO . and_then
107+ _ <- runInIO $ EL.try (restore action) >>= liftIO . and_then
108108 return ()
109109
110110forkIt :: (MonadBaseControl IO m, MonadIO m) => EventF -> (EventF -> m t) -> m ()
111111forkIt current proc = do
112112 child <- newChildCont current
113113 tid <- forkFinally1 (runInChild proc child)
114− $ \res -> do
115− thId <- myThreadId
116− beforeExit child{threadId = thId} res
114+ $ \res -> do
115+ thId <- myThreadId
116+ beforeExit child{threadId = thId} res
117117 updatePendingThreads current child{threadId = tid}
118− return ()
119118
120119 where
121120
@@ -151,6 +150,8 @@ forkIt current proc = do
151150
152151 waitForChildren (zombieChannel cur) (pendingThreads cur)
153152 signalQSemB (threadCredit cur)
153+ -- We are guaranteed to have a parent because we have been explicitly
154+ -- forked by some parent.
154155 let p = fromJust (parent cur)
155156 liftIO $ atomically $ writeTChan (zombieChannel p) (threadId cur)
156157
@@ -182,10 +183,14 @@ data StreamData a =
182183 | SError SomeException -- ^ An error occurred
183184 deriving (Typeable, Show,Read)
184185
186+-- XXX instead of starting a new thread every time, reuse the existing child
187+-- threads and send them work via a shared channel. When there is no more work
188+-- available we need a way to close the channel and wakeup all waiters so that
189+-- they can go away.
190+--
185191-- | Execute the IO action and the continuation
186192genAsyncEvents :: (MonadIO m, MonadBaseControl IO m) => EventF -> IO (StreamData t) -> m ()
187−genAsyncEvents parentc rec =
188− forkMaybe parentc $ \childcont -> loop childcont >> return ()
193+genAsyncEvents parentc rec = forkMaybe parentc loop
189194
190195 where
191196