@@ -125,8 +125,8 @@ instance Monad m => Monoid (AsyncT m a) where
125125instance Monad m => Monad (AsyncT m) where
126126 return a = AsyncT $ \ctx _ yld -> yld a ctx Nothing
127127
128− -- | On bind the new computation does not inherit the parent thread
129− -- context, it starts a new node in the tree.
128+ -- | A thread context is valid only until the next bind. Upon a bind we
129+ -- reset the context to Nothing.
130130 AsyncT m >>= f = AsyncT $ \_ stp yld ->
131131 m Nothing stp $ \a _ r ->
132132 let run x = (runAsyncT x) Nothing stp yld
@@ -166,34 +166,23 @@ doFork action preExit =
166166
167167{-# NOINLINE push #-}
168168push :: MonadIO m => Context a -> AsyncT m a -> m ()
169−push ctx m = go (Just ctx) m
169+push context action = run (Just context) action
170170
171171 where
172172
173+ run ctx m = (runAsyncT m) ctx channelDone yield
174+
173175 -- XXX make this a bounded channel so that we block if the previous value
174176 -- is not consumed yet.
175− {-# INLINE channelDone #-}
176− channelDone chan = do
177+ chan = childChannel context
178+ channelYield a = liftIO $ atomically $ writeTChan chan (ChildYield a)
179+ channelDone = do
177180 tid <- liftIO myThreadId
178181 liftIO $ atomically $ writeTChan chan (ChildDone tid Nothing)
179182
180− {-# INLINE channelYield #-}
181− channelYield chan a = liftIO $ atomically $ writeTChan chan (ChildYield a)
182−
183− go c mx = (runAsyncT mx) c (channelDone pchan) yield
184− pchan = childChannel ctx
185−
186− done a = do
187− channelYield pchan a
188− channelDone pchan
189−
190− {-# INLINE continue #-}
191− continue a c mx = do
192− channelYield pchan a
193− go c mx
194−
195− {-# INLINE yield #-}
196− yield a c r = maybe (done a) (\x -> continue a c x) r
183+ done a = channelYield a >> channelDone
184+ continue a ctx m = channelYield a >> run ctx m
185+ yield a ctx r = maybe (done a) (\rx -> continue a ctx rx) r
197186
198187-- If an exception occurs we push it to the channel so that it can handled by
199188-- the parent. 'Paused' exceptions are to be collected at the top level.
@@ -255,10 +244,6 @@ pullFork m1 m2 = AsyncT $ \_ stp yld -> do
255244 -- XXX push from m2 only when the channel becomes empty
256245 push c mb
257246
258−-- If threads suspend due to IO we can start more of them to utilize concurrent
259−-- IO, but only if we have more IO bandwidth. If we have more parallel CPU
260−-- bandwidth we can start more threads appropriately, but we have to see that
261−-- the thread creation overhead is less than the actual work to be done.
262247canFork :: IO Bool
263248canFork = return True
264249