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.2 2001/08/07 15:25:04 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 )
56 import GHC.Base ( fork# )
57 import GHC.Prim ( Addr#, unsafeCoerce# )
61 import IOExts ( unsafeInterleaveIO )
65 import Control.Concurrent.MVar
66 import Control.Concurrent.CVar
67 import Control.Concurrent.Chan
68 import Control.Concurrent.QSem
69 import Control.Concurrent.QSemN
70 import Control.Concurrent.SampleVar
72 -- Thread Ids, specifically the instances of Eq and Ord for these things.
73 -- The ThreadId type itself is defined in std/PrelConc.lhs.
75 -- Rather than define a new primitve, we use a little helper function
76 -- cmp_thread in the RTS.
78 #ifdef __GLASGOW_HASKELL__
79 foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
82 cmpThread :: ThreadId -> ThreadId -> Ordering
83 cmpThread (ThreadId t1) (ThreadId t2) =
84 case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
89 instance Eq ThreadId where
91 case t1 `cmpThread` t2 of
95 instance Ord ThreadId where
98 forkIO :: IO () -> IO ThreadId
99 forkIO action = IO $ \ s ->
100 case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
102 action_plus = Exception.catch action childHandler
104 childHandler :: Exception -> IO ()
105 childHandler err = Exception.catch (real_handler err) childHandler
107 real_handler :: Exception -> IO ()
110 -- ignore thread GC and killThread exceptions:
111 BlockedOnDeadMVar -> return ()
112 AsyncException ThreadKilled -> return ()
114 -- report all others:
115 AsyncException StackOverflow -> reportStackOverflow False
116 ErrorCall s -> reportError False s
117 other -> reportError False (showsPrec 0 other "\n")
119 #endif /* __GLASGOW_HASKELL__ */
125 mergeIO :: [a] -> [a] -> IO [a]
126 nmergeIO :: [[a]] -> IO [a]
129 = newEmptyMVar >>= \ tail_node ->
130 newMVar tail_node >>= \ tail_list ->
131 newQSem max_buff_size >>= \ e ->
132 newMVar 2 >>= \ branches_running ->
136 forkIO (suckIO branches_running buff ls) >>
137 forkIO (suckIO branches_running buff rs) >>
138 takeMVar tail_node >>= \ val ->
143 = (MVar (MVar [a]), QSem)
145 suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
147 suckIO branches_running buff@(tail_list,e) vs
149 [] -> takeMVar branches_running >>= \ val ->
151 takeMVar tail_list >>= \ node ->
153 putMVar tail_list node
155 putMVar branches_running (val-1)
158 takeMVar tail_list >>= \ node ->
159 newEmptyMVar >>= \ next_node ->
161 takeMVar next_node >>= \ y ->
163 return y) >>= \ next_node_val ->
164 putMVar node (x:next_node_val) >>
165 putMVar tail_list next_node >>
166 suckIO branches_running buff xs
172 newEmptyMVar >>= \ tail_node ->
173 newMVar tail_node >>= \ tail_list ->
174 newQSem max_buff_size >>= \ e ->
175 newMVar len >>= \ branches_running ->
179 mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
180 takeMVar tail_node >>= \ val ->
184 mapIO f xs = sequence (map f xs)