threads 0.3 → 0.3.1
raw patch · 4 files changed
+83/−30 lines, 4 filesdep ~basedep ~concurrent-extradep ~stm
Dependency ranges changed: base, concurrent-extra, stm
Files
- Control/Concurrent/Thread.hs +24/−14
- Control/Concurrent/Thread/Group.hs +33/−7
- Mask.hs +15/−0
- threads.cabal +11/−9
Control/Concurrent/Thread.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock -------------------------------------------------------------------------------- -- |@@ -39,8 +40,10 @@ , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO+#if MIN_VERSION_base(4,3,0)+ , forkIOUnmasked #endif-+#endif -- * Results , Result , unsafeResult@@ -55,9 +58,10 @@ import qualified Control.Concurrent ( forkIO, forkOS ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar )-import Control.Exception ( SomeException(SomeException)- , blocked, block, unblock, try, throwIO- )+import Control.Exception ( SomeException, try, throwIO )+#if MIN_VERSION_base(4,3,0)+import Control.Exception ( block, unblock )+#endif import Control.Monad ( return, (>>=), fail ) import Data.Either ( Either(..), either ) import Data.Function ( ($) )@@ -71,7 +75,10 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from ourselves:+import Mask ( mask ) + -------------------------------------------------------------------------------- -- * Forking threads --------------------------------------------------------------------------------@@ -126,7 +133,17 @@ -} forkOnIO ∷ Int → IO α → IO (ThreadId, IO (Result α)) forkOnIO = fork ∘ GHC.Conc.forkOnIO++#if MIN_VERSION_base(4,3,0)+-- | Like 'forkIO', but the child thread is created with asynchronous exceptions+-- unmasked (see 'Control.Exception.mask').+forkIOUnmasked ∷ IO α → IO (ThreadId, IO (Result α))+forkIOUnmasked a = do+ res ← newEmptyMVar+ tid ← block $ Control.Concurrent.forkIO $ try (unblock a) >>= putMVar res+ return (tid, readMVar res) #endif+#endif -------------------------------------------------------------------------------- @@ -135,9 +152,7 @@ fork ∷ (IO () → IO ThreadId) → (IO α → IO (ThreadId, IO (Result α))) fork doFork = \a → do res ← newEmptyMVar- parentIsBlocked ← blocked- tid ← block $ doFork $- try (if parentIsBlocked then a else unblock a) >>= putMVar res+ tid ← mask $ \restore → doFork $ try (restore a) >>= putMVar res return (tid, readMVar res) @@ -151,15 +166,10 @@ {-| Unsafely retrieve the actual value from the result. -When the result is 'SomeException' the exception stored inside of the-'SomeException' is rethrown in the current thread.+When the result is 'SomeException' the exception is thrown. -} unsafeResult ∷ Result α → IO α-unsafeResult = either throwInner return---- | Throw the exception stored inside the 'SomeException'.-throwInner ∷ SomeException → IO α-throwInner (SomeException e) = throwIO e+unsafeResult = either throwIO return -- The End ---------------------------------------------------------------------
Control/Concurrent/Thread/Group.hs view
@@ -3,6 +3,7 @@ , NoImplicitPrelude , UnicodeSyntax #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock -------------------------------------------------------------------------------- -- |@@ -37,7 +38,10 @@ , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO+#if MIN_VERSION_base(4,3,0)+ , forkIOUnmasked #endif+#endif -- * Waiting , wait@@ -52,7 +56,10 @@ import qualified Control.Concurrent ( forkIO, forkOS ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar )-import Control.Exception ( blocked, block, unblock, try )+import Control.Exception ( try )+#if MIN_VERSION_base(4,3,0)+import Control.Exception ( block, unblock )+#endif import Control.Monad ( return, (>>=), (>>), fail, when ) import Data.Function ( ($) ) import Data.Functor ( fmap )@@ -70,22 +77,28 @@ import Data.Function.Unicode ( (∘) ) -- from stm:-import Control.Concurrent.STM.TVar ( TVar, newTVar, readTVar, writeTVar )+import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVar, writeTVar ) import Control.Concurrent.STM ( STM, atomically, retry ) -- from threads:-import Control.Concurrent.Thread ( Result )+import Control.Concurrent.Thread ( Result ) #ifdef __HADDOCK__ import qualified Control.Concurrent.Thread as Thread ( forkIO , forkOS #ifdef __GLASGOW_HASKELL__ , forkOnIO+#if MIN_VERSION_base(4,3,0)+ , forkIOUnmasked #endif+#endif ) #endif +-- from ourselves:+import Mask ( mask ) + -------------------------------------------------------------------------------- -- * Thread groups --------------------------------------------------------------------------------@@ -110,7 +123,7 @@ -- | Create an empty group of threads. new ∷ IO ThreadGroup-new = atomically $ fmap ThreadGroup $ newTVar 0+new = fmap ThreadGroup $ newTVarIO 0 {-| Yield a transaction that returns the number of running threads in the group.@@ -141,7 +154,21 @@ -- additionaly adds the thread to the group. (GHC only) forkOnIO ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) forkOnIO = fork ∘ GHC.Conc.forkOnIO++#if MIN_VERSION_base(4,3,0)+-- | Same as @Control.Concurrent.Thread.'Thread.forkIOUnmasked'@ but+-- additionaly adds the thread to the group. (GHC only)+forkIOUnmasked ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α))+forkIOUnmasked (ThreadGroup numThreadsTV) a = do+ res ← newEmptyMVar+ tid ← block $ do+ atomically $ modifyTVar numThreadsTV succ+ Control.Concurrent.forkIO $ do+ try (unblock a) >>= putMVar res+ atomically $ modifyTVar numThreadsTV pred+ return (tid, readMVar res) #endif+#endif -------------------------------------------------------------------------------- @@ -150,11 +177,10 @@ fork ∷ (IO () → IO ThreadId) → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) fork doFork (ThreadGroup numThreadsTV) a = do res ← newEmptyMVar- parentIsBlocked ← blocked- tid ← block $ do+ tid ← mask $ \restore → do atomically $ modifyTVar numThreadsTV succ doFork $ do- try (if parentIsBlocked then a else unblock a) >>= putMVar res+ try (restore a) >>= putMVar res atomically $ modifyTVar numThreadsTV pred return (tid, readMVar res)
+ Mask.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-}++module Mask ( mask ) where++#if MIN_VERSION_base(4,3,0)+import Control.Exception ( mask )+#else+import Control.Monad ( (>>=) )+import Control.Exception ( blocked, block, unblock )+import Data.Function ( ($), id )+import System.IO ( IO )++mask ∷ ((IO α → IO α) → IO β) → IO β+mask io = blocked >>= \b → if b then io id else block $ io unblock+#endif
threads.cabal view
@@ -1,5 +1,5 @@ name: threads-version: 0.3+version: 0.3.1 cabal-version: >= 1.6 build-type: Custom stability: experimental@@ -20,8 +20,9 @@ this packages also provides functions to wait for a group of threads to terminate. .- This package is similar to the @threadmanager@- and @async@ packages. The advantages of this package are:+ This package is similar to the+ @threadmanager@, @async@ and @spawn@ packages.+ The advantages of this package are: . * Simpler API. .@@ -31,7 +32,7 @@ . * Correct handling of asynchronous exceptions. .- * GHC specific functionality like @forkOnIO@.+ * GHC specific functionality like @forkOnIO@ and @forkIOUnmasked@. source-repository head Type: darcs@@ -50,11 +51,12 @@ ------------------------------------------------------------------------------- library- build-depends: base >= 3 && < 4.3+ build-depends: base >= 3 && < 4.4 , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.2+ , stm >= 2.1 && < 2.3 exposed-modules: Control.Concurrent.Thread , Control.Concurrent.Thread.Group+ other-modules: Mask ghc-options: -Wall -------------------------------------------------------------------------------@@ -65,10 +67,10 @@ ghc-options: -Wall -threaded if flag(test)- build-depends: base >= 3 && < 4.3+ build-depends: base >= 3 && < 4.4 , base-unicode-symbols >= 0.1.1 && < 0.3- , stm >= 2.1 && < 2.2- , concurrent-extra >= 0.5.1 && < 0.6+ , stm >= 2.1 && < 2.3+ , concurrent-extra >= 0.5.1 && < 0.7 , HUnit >= 1.2.2 && < 1.3 , test-framework >= 0.2.4 && < 0.4 , test-framework-hunit >= 0.2.4 && < 0.3