1 -----------------------------------------------------------------------------
3 -- Module : Control.Concurrent
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable
11 -- $Id: Concurrent.hs,v 1.6 2002/04/24 16:31:37 simonmar Exp $
13 -- A common interface to a collection of useful concurrency
16 -----------------------------------------------------------------------------
18 module Control.Concurrent (
19 module Control.Concurrent.Chan,
20 module Control.Concurrent.CVar,
21 module Control.Concurrent.MVar,
22 module Control.Concurrent.QSem,
23 module Control.Concurrent.QSemN,
24 module Control.Concurrent.SampleVar,
26 forkIO, -- :: IO () -> IO ()
29 #ifdef __GLASGOW_HASKELL__
32 -- Forking and suchlike
33 myThreadId, -- :: IO ThreadId
34 killThread, -- :: ThreadId -> IO ()
35 throwTo, -- :: ThreadId -> Exception -> IO ()
37 threadDelay, -- :: Int -> IO ()
38 threadWaitRead, -- :: Int -> IO ()
39 threadWaitWrite, -- :: Int -> IO ()
43 mergeIO, -- :: [a] -> [a] -> IO [a]
44 nmergeIO -- :: [[a]] -> IO [a]
49 import Control.Exception as Exception
51 #ifdef __GLASGOW_HASKELL__
53 import GHC.TopHandler ( reportStackOverflow, reportError )
54 import GHC.IOBase ( IO(..) )
55 import GHC.IOBase ( unsafeInterleaveIO )
60 import IOExts ( unsafeInterleaveIO )
64 import Control.Concurrent.MVar
65 import Control.Concurrent.CVar
66 import Control.Concurrent.Chan
67 import Control.Concurrent.QSem
68 import Control.Concurrent.QSemN
69 import Control.Concurrent.SampleVar
71 -- Thread Ids, specifically the instances of Eq and Ord for these things.
72 -- The ThreadId type itself is defined in std/PrelConc.lhs.
74 -- Rather than define a new primitve, we use a little helper function
75 -- cmp_thread in the RTS.
77 #ifdef __GLASGOW_HASKELL__
78 foreign import ccall unsafe "cmp_thread" cmp_thread :: Addr# -> Addr# -> Int
81 cmpThread :: ThreadId -> ThreadId -> Ordering
82 cmpThread (ThreadId t1) (ThreadId t2) =
83 case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
88 instance Eq ThreadId where
90 case t1 `cmpThread` t2 of
94 instance Ord ThreadId where
97 foreign import ccall unsafe "rts_getThreadId" getThreadId :: Addr# -> Int
99 instance Show ThreadId where
100 showsPrec d (ThreadId t) =
101 showString "ThreadId " .
102 showsPrec d (getThreadId (unsafeCoerce# t))
104 forkIO :: IO () -> IO ThreadId
105 forkIO action = IO $ \ s ->
106 case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
108 action_plus = Exception.catch action childHandler
110 childHandler :: Exception -> IO ()
111 childHandler err = Exception.catch (real_handler err) childHandler
113 real_handler :: Exception -> IO ()
116 -- ignore thread GC and killThread exceptions:
117 BlockedOnDeadMVar -> return ()
118 AsyncException ThreadKilled -> return ()
120 -- report all others:
121 AsyncException StackOverflow -> reportStackOverflow False
122 ErrorCall s -> reportError False s
123 other -> reportError False (showsPrec 0 other "\n")
125 #endif /* __GLASGOW_HASKELL__ */
131 mergeIO :: [a] -> [a] -> IO [a]
132 nmergeIO :: [[a]] -> IO [a]
135 = newEmptyMVar >>= \ tail_node ->
136 newMVar tail_node >>= \ tail_list ->
137 newQSem max_buff_size >>= \ e ->
138 newMVar 2 >>= \ branches_running ->
142 forkIO (suckIO branches_running buff ls) >>
143 forkIO (suckIO branches_running buff rs) >>
144 takeMVar tail_node >>= \ val ->
149 = (MVar (MVar [a]), QSem)
151 suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
153 suckIO branches_running buff@(tail_list,e) vs
155 [] -> takeMVar branches_running >>= \ val ->
157 takeMVar tail_list >>= \ node ->
159 putMVar tail_list node
161 putMVar branches_running (val-1)
164 takeMVar tail_list >>= \ node ->
165 newEmptyMVar >>= \ next_node ->
167 takeMVar next_node >>= \ y ->
169 return y) >>= \ next_node_val ->
170 putMVar node (x:next_node_val) >>
171 putMVar tail_list next_node >>
172 suckIO branches_running buff xs
178 newEmptyMVar >>= \ tail_node ->
179 newMVar tail_node >>= \ tail_list ->
180 newQSem max_buff_size >>= \ e ->
181 newMVar len >>= \ branches_running ->
185 mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
186 takeMVar tail_node >>= \ val ->
190 mapIO f xs = sequence (map f xs)