git.iko.soy/streamly
on master help sign in
Move the thread contol primitive to threads module
commit4d4894c6f108fc4f459ea96b567254d422260c7d authorHarendra Kumar <harendra.kumar@gmail.com> dateFri 21 Jul 2017, 14:13 (9 years ago) parent3c7a92a
2 files changed+24−13
compare with master
unifiedsplit
src/Asyncly/AsyncT.hs+3−13 src/Asyncly/Threads.hs+21
src/Asyncly/AsyncT.hs+3−13
@@ -46,16 +46,16 @@ import Control.Monad.Base (MonadBase (..), liftBaseDefault)
4646import Control.Monad.Catch (MonadThrow, throwM)
4747import Control.Monad.State (MonadIO (..), MonadPlus (..),
4848 StateT (..), liftM, runStateT,
49− gets, modify)
49+ modify)
5050import Control.Monad.Trans.Class (MonadTrans (lift))
5151import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
5252 MonadTransControl (..),
5353 defaultLiftBaseWith,
5454 defaultRestoreM, liftBaseWith)
55+import Data.IORef (newIORef, readIORef, writeIORef)
5556import Unsafe.Coerce (unsafeCoerce)
5657
5758import Control.Monad.Trans.Recorder (MonadRecorder(..))
58−import Data.IORef (newIORef, readIORef, writeIORef)
5959--import Debug.Trace (traceM)
6060
6161import Asyncly.Threads
@@ -287,18 +287,8 @@ makeAsync = AsyncT . makeCont
287287-- Controlling thread quota
288288------------------------------------------------------------------------------
289289
290−-- XXX Should n be Word32 instead?
291290-- | Runs a computation under a given thread limit. A limit of 0 means all new
292291-- tasks start synchronously in the current thread unless overridden by
293292-- 'async'.
294293threads :: MonadAsync m => Int -> AsyncT m a -> AsyncT m a
295−threads n process = AsyncT $ do
296− oldCr <- gets threadCredit
297− newCr <- liftIO $ newIORef n
298− modify $ \s -> s { threadCredit = newCr }
299− r <- runAsyncT $ process
300− >>* (AsyncT $ do
301− modify $ \s -> s { threadCredit = oldCr }
302− return (Just ())
303− ) -- restore old credit
304− return r
294+threads n action = AsyncT $ threadCtl n (runAsyncT action)
src/Asyncly/Threads.hs+21
@@ -18,6 +18,7 @@ module Asyncly.Threads
1818 , initContext
1919 , runAsyncTask
2020 , makeCont
21+ , threadCtl
2122 -- , Location(..)
2223 -- , getLocation
2324 -- , setLocation
@@ -429,3 +430,23 @@ makeCont cbsetter = do
429430 _ <- runStateT s ctx
430431 return ()
431432 spawningParentDone
433+
434+------------------------------------------------------------------------------
435+-- Controlling thread quota
436+------------------------------------------------------------------------------
437+
438+-- XXX Should n be Word32 instead?
439+-- | Runs a computation under a given thread limit. A limit of 0 means all new
440+-- tasks start synchronously in the current thread unless overridden by
441+-- 'async'.
442+threadCtl :: MonadAsync m
443+ => Int
444+ -> StateT Context m (Maybe a)
445+ -> StateT Context m (Maybe a)
446+threadCtl n action = do
447+ oldCr <- gets threadCredit
448+ newCr <- liftIO $ newIORef n
449+ modify $ \s -> s { threadCredit = newCr }
450+ r <- action
451+ modify $ \s -> s { threadCredit = oldCr }
452+ return r