4d4894c · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Move the thread contol primitive to threads module

4d4894cHarendra Kumar9 years ago

src/Asyncly/AsyncT.hs+3−13

compare with master

unifiedsplit

@@ -46,16 +46,16 @@ import Control.Monad.Base (MonadBase (..), liftBaseDefault)

46import Control.Monad.Catch (MonadThrow, throwM)

47import Control.Monad.State (MonadIO (..), MonadPlus (..),

48 StateT (..), liftM, runStateT,

49− gets, modify)

49+ modify)

50import Control.Monad.Trans.Class (MonadTrans (lift))

51import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),

52 MonadTransControl (..),

53 defaultLiftBaseWith,

54 defaultRestoreM, liftBaseWith)

55+import Data.IORef (newIORef, readIORef, writeIORef)

55import Unsafe.Coerce (unsafeCoerce)

56import Unsafe.Coerce (unsafeCoerce)

57import Control.Monad.Trans.Recorder (MonadRecorder(..))

58import Control.Monad.Trans.Recorder (MonadRecorder(..))

58−import Data.IORef (newIORef, readIORef, writeIORef)

59--import Debug.Trace (traceM)

61import Asyncly.Threads

@@ -287,18 +287,8 @@ makeAsync = AsyncT . makeCont

287-- Controlling thread quota

288------------------------------------------------------------------------------

289

290−-- XXX Should n be Word32 instead?

291-- | Runs a computation under a given thread limit. A limit of 0 means all new

290-- | Runs a computation under a given thread limit. A limit of 0 means all new

292-- tasks start synchronously in the current thread unless overridden by

291-- tasks start synchronously in the current thread unless overridden by

293-- 'async'.

292-- 'async'.

294threads :: MonadAsync m => Int -> AsyncT m a -> AsyncT m a

293threads :: MonadAsync m => Int -> AsyncT m a -> AsyncT m a

295−threads n process = AsyncT $ do

294+threads n action = AsyncT $ threadCtl n (runAsyncT action)

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

src/Asyncly/Threads.hs+21

@@ -18,6 +18,7 @@ module Asyncly.Threads

18 , initContext

19 , runAsyncTask

20 , makeCont

21+ , threadCtl

21 -- , Location(..)

22 -- , Location(..)

22 -- , getLocation

23 -- , getLocation

23 -- , setLocation

24 -- , setLocation

@@ -429,3 +430,23 @@ makeCont cbsetter = do

429 _ <- runStateT s ctx

430 _ <- runStateT s ctx

430 return ()

431 return ()

431 spawningParentDone

432 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