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.3 2001/12/21 15:07:21 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 "cmp_thread" unsafe 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 forkIO :: IO () -> IO ThreadId
98 forkIO action = IO $ \ s ->
99 case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
101 action_plus = Exception.catch action childHandler
103 childHandler :: Exception -> IO ()
104 childHandler err = Exception.catch (real_handler err) childHandler
106 real_handler :: Exception -> IO ()
109 -- ignore thread GC and killThread exceptions:
110 BlockedOnDeadMVar -> return ()
111 AsyncException ThreadKilled -> return ()
113 -- report all others:
114 AsyncException StackOverflow -> reportStackOverflow False
115 ErrorCall s -> reportError False s
116 other -> reportError False (showsPrec 0 other "\n")
118 #endif /* __GLASGOW_HASKELL__ */
124 mergeIO :: [a] -> [a] -> IO [a]
125 nmergeIO :: [[a]] -> IO [a]
128 = newEmptyMVar >>= \ tail_node ->
129 newMVar tail_node >>= \ tail_list ->
130 newQSem max_buff_size >>= \ e ->
131 newMVar 2 >>= \ branches_running ->
135 forkIO (suckIO branches_running buff ls) >>
136 forkIO (suckIO branches_running buff rs) >>
137 takeMVar tail_node >>= \ val ->
142 = (MVar (MVar [a]), QSem)
144 suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
146 suckIO branches_running buff@(tail_list,e) vs
148 [] -> takeMVar branches_running >>= \ val ->
150 takeMVar tail_list >>= \ node ->
152 putMVar tail_list node
154 putMVar branches_running (val-1)
157 takeMVar tail_list >>= \ node ->
158 newEmptyMVar >>= \ next_node ->
160 takeMVar next_node >>= \ y ->
162 return y) >>= \ next_node_val ->
163 putMVar node (x:next_node_val) >>
164 putMVar tail_list next_node >>
165 suckIO branches_running buff xs
171 newEmptyMVar >>= \ tail_node ->
172 newMVar tail_node >>= \ tail_list ->
173 newQSem max_buff_size >>= \ e ->
174 newMVar len >>= \ branches_running ->
178 mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
179 takeMVar tail_node >>= \ val ->
183 mapIO f xs = sequence (map f xs)