[project @ 2002-05-09 13:05:46 by simonmar]
[packages/random.git] / GHC / Conc.lhs
1 \begin{code}
2 {-# OPTIONS -fno-implicit-prelude #-}
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module      :  GHC.Conc
6 -- Copyright   :  (c) The University of Glasgow, 1994-2002
7 -- License     :  see libraries/base/LICENSE
8 -- 
9 -- Maintainer  :  cvs-ghc@haskell.org
10 -- Stability   :  internal
11 -- Portability :  non-portable (GHC extensions)
12 --
13 -- Basic concurrency stuff.
14 -- 
15 -----------------------------------------------------------------------------
16
17 module GHC.Conc
18         ( ThreadId(..)
19
20         -- Forking and suchlike
21         , myThreadId    -- :: IO ThreadId
22         , killThread    -- :: ThreadId -> IO ()
23         , throwTo       -- :: ThreadId -> Exception -> IO ()
24         , par           -- :: a -> b -> b
25         , pseq          -- :: a -> b -> b
26         , yield         -- :: IO ()
27         , labelThread   -- :: String -> IO ()
28         , forkProcess   -- :: IO Int
29
30         -- Waiting
31         , threadDelay           -- :: Int -> IO ()
32         , threadWaitRead        -- :: Int -> IO ()
33         , threadWaitWrite       -- :: Int -> IO ()
34
35         -- MVars
36         , MVar          -- abstract
37         , newMVar       -- :: a -> IO (MVar a)
38         , newEmptyMVar  -- :: IO (MVar a)
39         , takeMVar      -- :: MVar a -> IO a
40         , putMVar       -- :: MVar a -> a -> IO ()
41         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
42         , tryPutMVar    -- :: MVar a -> a -> IO Bool
43         , isEmptyMVar   -- :: MVar a -> IO Bool
44         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
45
46     ) where
47
48 import Data.Maybe
49
50 import GHC.Base
51 import GHC.Err          ( parError, seqError )
52 import GHC.IOBase       ( IO(..), MVar(..) )
53 import GHC.Base         ( Int(..) )
54 import GHC.Exception    ( Exception(..), AsyncException(..) )
55 import GHC.Pack         ( packCString# )
56
57 infixr 0 `par`, `pseq`
58 \end{code}
59
60 %************************************************************************
61 %*                                                                      *
62 \subsection{@ThreadId@, @par@, and @fork@}
63 %*                                                                      *
64 %************************************************************************
65
66 \begin{code}
67 data ThreadId = ThreadId ThreadId#
68 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
69 -- But since ThreadId# is unlifted, the Weak type must use open
70 -- type variables.
71
72 --forkIO has now been hoisted out into the Concurrent library.
73
74 killThread :: ThreadId -> IO ()
75 killThread (ThreadId id) = IO $ \ s ->
76    case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
77
78 throwTo :: ThreadId -> Exception -> IO ()
79 throwTo (ThreadId id) ex = IO $ \ s ->
80    case (killThread# id ex s) of s1 -> (# s1, () #)
81
82 myThreadId :: IO ThreadId
83 myThreadId = IO $ \s ->
84    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
85
86 yield :: IO ()
87 yield = IO $ \s -> 
88    case (yield# s) of s1 -> (# s1, () #)
89
90 labelThread :: String -> IO ()
91 labelThread str = IO $ \ s ->
92    let ps  = packCString# str
93        adr = byteArrayContents# ps in
94      case (labelThread# adr s) of s1 -> (# s1, () #)
95
96 forkProcess :: IO Int
97 forkProcess = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
98
99 --      Nota Bene: 'pseq' used to be 'seq'
100 --                 but 'seq' is now defined in PrelGHC
101 --
102 -- "pseq" is defined a bit weirdly (see below)
103 --
104 -- The reason for the strange "0# -> parError" case is that
105 -- it fools the compiler into thinking that seq is non-strict in
106 -- its second argument (even if it inlines seq at the call site).
107 -- If it thinks seq is strict in "y", then it often evaluates
108 -- "y" before "x", which is totally wrong.  
109 --
110 -- Just before converting from Core to STG there's a bit of magic
111 -- that recognises the seq# and eliminates the duff case.
112
113 {-# INLINE pseq  #-}
114 pseq :: a -> b -> b
115 pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
116
117 {-# INLINE par  #-}
118 par :: a -> b -> b
119 par  x y = case (par# x) of { 0# -> parError; _ -> y }
120 \end{code}
121
122 %************************************************************************
123 %*                                                                      *
124 \subsection[mvars]{M-Structures}
125 %*                                                                      *
126 %************************************************************************
127
128 M-Vars are rendezvous points for concurrent threads.  They begin
129 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
130 is written, a single blocked thread may be freed.  Reading an M-Var
131 toggles its state from full back to empty.  Therefore, any value
132 written to an M-Var may only be read once.  Multiple reads and writes
133 are allowed, but there must be at least one read between any two
134 writes.
135
136 \begin{code}
137 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
138
139 newEmptyMVar  :: IO (MVar a)
140 newEmptyMVar = IO $ \ s# ->
141     case newMVar# s# of
142          (# s2#, svar# #) -> (# s2#, MVar svar# #)
143
144 takeMVar :: MVar a -> IO a
145 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
146
147 putMVar  :: MVar a -> a -> IO ()
148 putMVar (MVar mvar#) x = IO $ \ s# ->
149     case putMVar# mvar# x s# of
150         s2# -> (# s2#, () #)
151
152 tryPutMVar  :: MVar a -> a -> IO Bool
153 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
154     case tryPutMVar# mvar# x s# of
155         (# s, 0# #) -> (# s, False #)
156         (# s, _  #) -> (# s, True #)
157
158 newMVar :: a -> IO (MVar a)
159 newMVar value =
160     newEmptyMVar        >>= \ mvar ->
161     putMVar mvar value  >>
162     return mvar
163
164 -- tryTakeMVar is a non-blocking takeMVar
165 tryTakeMVar :: MVar a -> IO (Maybe a)
166 tryTakeMVar (MVar m) = IO $ \ s ->
167     case tryTakeMVar# m s of
168         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
169         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
170
171 {- 
172  Low-level op. for checking whether an MVar is filled-in or not.
173  Notice that the boolean value returned  is just a snapshot of
174  the state of the MVar. By the time you get to react on its result,
175  the MVar may have been filled (or emptied) - so be extremely
176  careful when using this operation.  
177
178  Use tryTakeMVar instead if possible.
179
180  If you can re-work your abstractions to avoid having to
181  depend on isEmptyMVar, then you're encouraged to do so,
182  i.e., consider yourself warned about the imprecision in
183  general of isEmptyMVar :-)
184 -}
185 isEmptyMVar :: MVar a -> IO Bool
186 isEmptyMVar (MVar mv#) = IO $ \ s# -> 
187     case isEmptyMVar# mv# s# of
188         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
189
190 -- Like addForeignPtrFinalizer, but for MVars
191 addMVarFinalizer :: MVar a -> IO () -> IO ()
192 addMVarFinalizer (MVar m) finalizer = 
193   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
194 \end{code}
195
196
197 %************************************************************************
198 %*                                                                      *
199 \subsection{Thread waiting}
200 %*                                                                      *
201 %************************************************************************
202
203 @threadDelay@ delays rescheduling of a thread until the indicated
204 number of microseconds have elapsed.  Generally, the microseconds are
205 counted by the context switch timer, which ticks in virtual time;
206 however, when there are no runnable threads, we don't accumulate any
207 virtual time, so we start ticking in real time.  (The granularity is
208 the effective resolution of the context switch timer, so it is
209 affected by the RTS -C option.)
210
211 @threadWaitRead@ delays rescheduling of a thread until input on the
212 specified file descriptor is available for reading (just like select).
213 @threadWaitWrite@ is similar, but for writing on a file descriptor.
214
215 \begin{code}
216 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
217
218 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
219 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
220 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
221 \end{code}