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