threads 0.1 → 0.1.0.1
raw patch · 6 files changed
+78/−68 lines, 6 filesdep +stmdep ~concurrent-extradep ~test-framework
Dependencies added: stm
Dependency ranges changed: concurrent-extra, test-framework
Files
- Control/Concurrent/Thread.hs +20/−13
- Control/Concurrent/Thread/Group.hs +29/−29
- Control/Concurrent/Thread/Internal.hs +4/−2
- Utils.hs +17/−18
- test.hs +2/−2
- threads.cabal +6/−4
Control/Concurrent/Thread.hs view
@@ -50,33 +50,40 @@ -- from base: import qualified Control.Concurrent as C ( ThreadId, forkIO, forkOS, throwTo )-import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) import Control.Exception ( Exception, SomeException , AsyncException(ThreadKilled) , blocked, block, unblock, try )-#ifdef __HADDOCK__-import qualified Control.Concurrent as C ( killThread )-#endif import Control.Monad ( return, (>>=), (>>), fail )-import Data.Bool ( Bool(..) )-import Data.Either ( Either(..), either )+import Data.Bool ( Bool )+import Data.Either ( Either, either ) import Data.Function ( ($), const ) import Data.Functor ( fmap )-import Data.Maybe ( Maybe(..), isNothing )+import Data.Maybe ( Maybe, isNothing ) import System.IO ( IO ) +#ifdef __HADDOCK__+import qualified Control.Concurrent as C ( killThread )+import Data.Bool ( Bool (False, True) )+import Data.Either ( Either(Left, Right) )+import Data.Maybe ( Maybe (Nothing, Just) )+#endif+ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra:-import Utils ( void, throwInner, tryRead )+-- from stm:+import Control.Concurrent.STM.TMVar ( newEmptyTMVarIO, putTMVar, readTMVar )+import Control.Concurrent.STM ( atomically ) +-- from threads: import Control.Concurrent.Thread.Internal ( ThreadId(ThreadId) , result, threadId ) +import Utils ( void, throwInner, tryReadTMVar ) + ------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------@@ -119,10 +126,10 @@ -} fork ∷ (IO () → IO C.ThreadId) → IO α → IO (ThreadId α) fork doFork a = do- res ← newEmptyMVar+ res ← newEmptyTMVarIO b ← blocked fmap (ThreadId res) $ block $ doFork $ try (if b then a else unblock a) >>=- putMVar res+ atomically ∘ putTMVar res -------------------------------------------------------------------------------@@ -138,7 +145,7 @@ caught. -} wait ∷ ThreadId α → IO (Either SomeException α)-wait = readMVar ∘ result+wait = atomically ∘ readTMVar ∘ result -- | Like 'wait' but will ignore the value returned by the thread. wait_ ∷ ThreadId α → IO ()@@ -173,7 +180,7 @@ a program reacts on its result it may already be out of date. -} status ∷ ThreadId α → IO (Maybe (Either SomeException α))-status = tryRead ∘ result+status = tryReadTMVar ∘ result {-| Returns 'True' if the thread is currently running and 'False' otherwise.
Control/Concurrent/Thread/Group.hs view
@@ -46,15 +46,11 @@ ------------------------------------------------------------------------------- -- from base:-import Control.Applicative ( (<*>) )-import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar- , takeMVar, putMVar- ) import Control.Exception ( blocked, block, unblock, try )-import Control.Monad ( (>>=), (>>), fail )+import Control.Monad ( (>>=), (>>), fail, when, liftM2 ) import Data.Bool ( Bool(..) ) import Data.Function ( ($) )-import Data.Functor ( (<$>), fmap )+import Data.Functor ( fmap ) import Data.Typeable ( Typeable ) import System.IO ( IO ) import qualified Control.Concurrent as C ( ThreadId, forkIO, forkOS )@@ -64,30 +60,35 @@ import Data.Eq.Unicode ( (≡) ) import Data.Function.Unicode ( (∘) ) +-- from stm:+import Control.Concurrent.STM.TVar ( TVar, newTVar, writeTVar, readTVar )+import Control.Concurrent.STM.TMVar ( newEmptyTMVarIO, putTMVar )+import Control.Concurrent.STM ( atomically )+ -- from concurrent-extra:-import Control.Concurrent.Lock ( Lock )-import qualified Control.Concurrent.Lock as Lock ( new- , acquire, release- , wait, locked- )+import Control.Concurrent.STM.Lock ( Lock )+import qualified Control.Concurrent.STM.Lock as Lock ( new+ , acquire, release+ , wait, locked+ )+ -- from threads: import Control.Concurrent.Thread.Internal ( ThreadId( ThreadId ) ) -import Utils ( whenThen )- #ifdef __HADDOCK__ import qualified Control.Concurrent.Thread as Thread ( forkIO, forkOS ) #endif + ------------------------------------------------------------------------------- -- Thread groups ------------------------------------------------------------------------------- -data ThreadGroup = ThreadGroup (MVar Integer) Lock deriving Typeable+data ThreadGroup = ThreadGroup (TVar Integer) Lock deriving Typeable -- | Create a new empty group. new ∷ IO ThreadGroup-new = ThreadGroup <$> newMVar 0 <*> Lock.new+new = atomically $ liftM2 ThreadGroup (newTVar 0) (Lock.new) -- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds -- the thread to the group.@@ -101,29 +102,28 @@ fork ∷ (IO () → IO C.ThreadId) → ThreadGroup → IO α → IO (ThreadId α) fork doFork (ThreadGroup mc l) a = do- res ← newEmptyMVar+ res ← newEmptyTMVarIO b ← blocked block $ do- increment+ atomically increment fmap (ThreadId res) $ doFork $ do- try (if b then a else unblock a) >>= putMVar res- decrement+ r ← try (if b then a else unblock a)+ atomically $ putTMVar res r >> decrement where- increment = do numThreads ← takeMVar mc- whenThen (numThreads ≡ 0) (Lock.acquire l)- (putMVar mc $! numThreads + 1)+ increment = do numThreads ← readTVar mc+ when (numThreads ≡ 0) $ Lock.acquire l+ writeTVar mc $! numThreads + 1 - decrement = do numThreads ← takeMVar mc- whenThen (numThreads ≡ 1) (Lock.release l)- (putMVar mc $! numThreads - 1)+ decrement = do numThreads ← readTVar mc+ when (numThreads ≡ 1) $ Lock.release l+ writeTVar mc $! numThreads - 1 lock ∷ ThreadGroup → Lock lock (ThreadGroup _ l) = l --- | Block until all threads, that were added to the group before calling this--- function, have terminated.+-- | Block until all threads, that were added to the group have terminated. wait ∷ ThreadGroup → IO ()-wait = Lock.wait ∘ lock+wait = atomically ∘ Lock.wait ∘ lock {-| Returns 'True' if any thread in the group is running and returns 'False'@@ -133,7 +133,7 @@ a program reacts on its result it may already be out of date. -} isAnyRunning ∷ ThreadGroup → IO Bool-isAnyRunning = Lock.locked ∘ lock+isAnyRunning = atomically ∘ Lock.locked ∘ lock -- The End ---------------------------------------------------------------------
Control/Concurrent/Thread/Internal.hs view
@@ -11,7 +11,6 @@ ------------------------------------------------------------------------------- -- from base:-import Control.Concurrent.MVar ( MVar ) import Control.Exception ( SomeException ) import Data.Eq ( Eq, (==) ) import Data.Either ( Either )@@ -24,7 +23,10 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from stm:+import Control.Concurrent.STM.TMVar ( TMVar ) + ------------------------------------------------------------------------------- -- ThreadIds -------------------------------------------------------------------------------@@ -34,7 +36,7 @@ that is executing or has executed a computation of type @'IO' α@. -} data ThreadId α = ThreadId- { result ∷ MVar (Either SomeException α)+ { result ∷ TMVar (Either SomeException α) , threadId ∷ C.ThreadId -- ^ Extract the native -- @Control.Concurrent.'C.ThreadId'@. } deriving Typeable
Utils.hs view
@@ -7,18 +7,19 @@ -------------------------------------------------------------------------------- -- from base:-import Control.Concurrent.MVar ( MVar, putMVar, tryTakeMVar )-import Control.Exception ( SomeException(SomeException)- , block, throwIO- )-import Control.Monad ( Monad, return, (>>=), (>>), fail )-import Data.Bool ( Bool )-import Data.Function ( ($), flip )-import Data.Functor ( Functor, (<$>), (<$) )-import Data.Maybe ( Maybe(Nothing, Just) )-import System.IO ( IO )+import Control.Exception ( SomeException(SomeException), throwIO )+import Control.Monad ( Monad, return, (>>=), (>>), fail )+import Data.Bool ( Bool )+import Data.Function ( ($), flip )+import Data.Functor ( Functor, (<$>), (<$) )+import Data.Maybe ( Maybe(Nothing, Just) )+import System.IO ( IO ) +-- from stm:+import Control.Concurrent.STM ( atomically )+import Control.Concurrent.STM.TMVar ( TMVar, tryTakeTMVar, putTMVar ) + -------------------------------------------------------------------------------- -- Utility functions --------------------------------------------------------------------------------@@ -32,17 +33,15 @@ ifM ∷ Monad m ⇒ m Bool → m α → m α → m α ifM c t e = c >>= \b → if b then t else e -whenThen ∷ Monad m ⇒ Bool → m () → m α → m α-whenThen b t a = if b then t >> a else a- throwInner ∷ SomeException → IO α throwInner (SomeException e) = throwIO e -tryRead ∷ MVar α → IO (Maybe α)-tryRead mv = block $ do mx ← tryTakeMVar mv- case mx of- Nothing → return mx- Just x → putMVar mv x >> return mx+tryReadTMVar ∷ TMVar α → IO (Maybe α)+tryReadTMVar mv = atomically $ do+ mx ← tryTakeTMVar mv+ case mx of+ Nothing → return mx+ Just x → putTMVar mv x >> return mx -- The End ---------------------------------------------------------------------
test.hs view
@@ -18,7 +18,7 @@ import Data.Eq ( Eq ) import Data.Either ( either ) import Data.Function ( ($), id, const )-import Data.Functor ( fmap )+import Data.Functor ( fmap, (<$>) ) import Data.IORef ( newIORef, readIORef, writeIORef ) import Data.Maybe ( maybe ) import Data.Typeable ( Typeable )@@ -114,7 +114,7 @@ Thread.unsafeWait >>= assert test_unblockedState ∷ Fork Bool → Assertion-test_unblockedState fork = (unblock $ fork $ fmap not $ blocked) >>=+test_unblockedState fork = (unblock $ fork $ not <$> blocked) >>= Thread.unsafeWait >>= assert test_sync_exception ∷ Fork () → Assertion
threads.cabal view
@@ -1,5 +1,5 @@ name: threads-version: 0.1+version: 0.1.0.1 cabal-version: >= 1.6 build-type: Custom stability: experimental@@ -56,7 +56,8 @@ library build-depends: base >= 3 && < 4.3 , base-unicode-symbols >= 0.1.1 && < 0.3- , concurrent-extra >= 0.5 && < 0.6+ , stm >= 2.1 && < 2.2+ , concurrent-extra >= 0.5.1 && < 0.6 exposed-modules: Control.Concurrent.Thread , Control.Concurrent.Thread.Group other-modules: Control.Concurrent.Thread.Internal@@ -77,10 +78,11 @@ if flag(test) build-depends: base >= 3 && < 4.3 , base-unicode-symbols >= 0.1.1 && < 0.3- , concurrent-extra >= 0.5 && < 0.6+ , stm >= 2.1 && < 2.2+ , concurrent-extra >= 0.5.1 && < 0.6 , HUnit >= 1.2.2 && < 1.3 , QuickCheck >= 2.1.0 && < 2.2- , test-framework >= 0.2.4 && < 0.3+ , test-framework >= 0.2.4 && < 0.4 , test-framework-hunit >= 0.2.4 && < 0.3 , test-framework-quickcheck2 >= 0.2.4 && < 0.3 buildable: True