2 % (c) The AQUA Project, Glasgow University, 1994-1995
4 \section[PrimIO]{@PrimIO@ monad}
6 This sits on top of the state-transformer monad. See
9 We follow the Haskell~1.3 I/O proposal nomenclature.
12 module PreludePrimIO (
13 -- PrimIO(..): no, the compiler already knows about it
23 unsafeInterleavePrimIO,
26 -- all the Stdio stuff (this is how you get to it)
28 fclose, fdopen, fflush, fopen, fread, freopen,
31 -- IVars and MVars come from here, too
32 _IVar, _MVar, -- abstract
33 IVar(..), MVar(..), -- for convenience
34 newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, swapMVar,
35 newIVar, readIVar, writeIVar,
37 threadWait, threadDelay,
39 -- backward compatibility -- don't use!
45 -- make interface self-sufficient
46 fixST, unsafeInterleaveST
50 import TyArray ( Array(..) )
53 import List ( (++), map )
54 import PreludeDialogueIO ( processIORequest )
58 import PreludeMonadicIO ( IO(..), Either(..), return, (>>=), (>>) )
59 import PreludeIOError ( IOError13 )
61 infixr 1 `thenPrimIO`, `seqPrimIO`
64 %************************************************************************
66 \subsection[IO-monad]{The @IO@ monad}
68 %************************************************************************
71 type PrimIO a = _ST _RealWorld a
76 returnPrimIO :: a -> PrimIO a
77 thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
78 seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b
79 fixPrimIO :: (a -> PrimIO a) -> PrimIO a
80 listPrimIO :: [PrimIO a] -> PrimIO [a]
81 mapPrimIO :: (a -> PrimIO b) -> [a] -> PrimIO [b]
82 mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c])
84 {-# INLINE returnPrimIO #-}
85 {-# INLINE thenPrimIO #-}
86 {-# INLINE seqPrimIO #-}
88 returnPrimIO x s = returnStrictlyST x s
89 thenPrimIO m k s = thenStrictlyST m k s
90 seqPrimIO m k s = seqStrictlyST m k s
94 listPrimIO [] = returnPrimIO []
95 listPrimIO (m:ms) = m `thenPrimIO` \ x ->
96 listPrimIO ms `thenPrimIO` \xs ->
99 -- An earlier definition of listPrimIO in terms of foldrPrimIO
100 -- was just wrong (it did the operations in the wrong order)
101 -- so I deleted foldrPrimIO and defined listPrimIO directly.
104 mapPrimIO f ms = listPrimIO (map f ms)
106 mapAndUnzipPrimIO f [] = returnPrimIO ([], [])
107 mapAndUnzipPrimIO f (m:ms)
108 = f m `thenPrimIO` \ ( r1, r2) ->
109 mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) ->
110 returnPrimIO (r1:rs1, r2:rs2)
114 unsafePerformPrimIO :: PrimIO a -> a
115 unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
117 unsafePerformPrimIO k = case (k (S# realWorld#)) of (r, _) -> r
119 unsafeInterleavePrimIO m s = unsafeInterleaveST m s
122 Transitional: for pre-1.3 systems: Don't use them!
124 readChanPrimIO :: String -> PrimIO String
125 appendChanPrimIO :: String -> String -> PrimIO ()
126 appendFilePrimIO :: String -> String -> PrimIO ()
127 getArgsPrimIO :: PrimIO [String]
129 readChanPrimIO c = processIORequestString ( ReadChan c )
130 appendChanPrimIO c s = processIORequestUnit ( AppendChan c s )
131 appendFilePrimIO f s = processIORequestUnit ( AppendFile f s )
132 getArgsPrimIO = processIORequestStrList ( GetArgs )
134 processIORequestUnit :: Request -> PrimIO ()
135 processIORequestString :: Request -> PrimIO String
136 processIORequestStrList :: Request -> PrimIO [String]
138 processIORequestUnit req
139 = processIORequest req `thenPrimIO` \ resp ->
141 Success -> returnPrimIO ()
142 Failure ioerr -> error (ioErrMsg ioerr)
143 _ -> error "funny Response, expected a Success"
145 processIORequestString req
146 = processIORequest req `thenPrimIO` \ resp ->
148 Str str -> returnPrimIO str
149 Failure ioerr -> error (ioErrMsg ioerr)
150 _ -> error "funny Response, expected a String"
152 processIORequestStrList req
153 = processIORequest req `thenPrimIO` \ resp ->
155 StrList strl -> returnPrimIO strl
156 Failure ioerr -> error (ioErrMsg ioerr)
157 _ -> error "funny Response, expected a [String]"
159 ioErrMsg :: IOError -> String
160 ioErrMsg (ReadError s) = "Read Error: " ++ s
161 ioErrMsg (WriteError s) = "Write Error: " ++ s
162 ioErrMsg (FormatError s) = "Format Error: " ++ s
163 ioErrMsg (SearchError s) = "Search Error: " ++ s
164 ioErrMsg (OtherError s) = "Other Error: " ++ s
167 %************************************************************************
169 \subsection[PreludeGlaST-mvars]{M-Structures}
171 %************************************************************************
173 M-Vars are rendezvous points for concurrent threads. They begin
174 empty, and any attempt to read an empty M-Var blocks. When an M-Var
175 is written, a single blocked thread may be freed. Reading an M-Var
176 toggles its state from full back to empty. Therefore, any value
177 written to an M-Var may only be read once. Multiple reads and writes
178 are allowed, but there must be at least one read between any two
182 data _MVar a = _MVar (SynchVar# _RealWorld a)
183 type MVar a = _MVar a
187 newEmptyMVar :: IO (_MVar a)
189 newEmptyMVar (S# s#) =
190 case newSynchVar# s# of
191 StateAndSynchVar# s2# svar# -> (Right (_MVar svar#), S# s2#)
193 takeMVar :: _MVar a -> IO a
195 takeMVar (_MVar mvar#) (S# s#) =
196 case takeMVar# mvar# s# of
197 StateAndPtr# s2# r -> (Right r, S# s2#)
199 putMVar :: _MVar a -> a -> IO ()
201 putMVar (_MVar mvar#) x (S# s#) =
202 case putMVar# mvar# x s# of
203 s2# -> (Right (), S# s2#)
205 newMVar :: a -> IO (_MVar a)
208 newEmptyMVar >>= \ mvar ->
209 putMVar mvar value >>
212 readMVar :: _MVar a -> IO a
215 takeMVar mvar >>= \ value ->
216 putMVar mvar value >>
219 swapMVar :: _MVar a -> a -> IO a
222 takeMVar mvar >>= \ old ->
228 %************************************************************************
230 \subsection[PreludeGlaST-ivars]{I-Structures}
232 %************************************************************************
234 I-Vars are write-once variables. They start out empty, and any threads that
235 attempt to read them will block until they are filled. Once they are written,
236 any blocked threads are freed, and additional reads are permitted. Attempting
237 to write a value to a full I-Var results in a runtime error.
240 data _IVar a = _IVar (SynchVar# _RealWorld a)
241 type IVar a = _IVar a
245 newIVar :: IO (_IVar a)
248 case newSynchVar# s# of
249 StateAndSynchVar# s2# svar# -> (Right (_IVar svar#), S# s2#)
251 readIVar :: _IVar a -> IO a
253 readIVar (_IVar ivar#) (S# s#) =
254 case readIVar# ivar# s# of
255 StateAndPtr# s2# r -> (Right r, S# s2#)
257 writeIVar :: _IVar a -> a -> IO ()
259 writeIVar (_IVar ivar#) x (S# s#) =
260 case writeIVar# ivar# x s# of
261 s2# -> (Right (), S# s2#)
266 %************************************************************************
268 \subsection{Thread Wait Functions}
270 %************************************************************************
272 @threadDelay@ delays rescheduling of a thread until the indicated
273 number of microseconds have elapsed. Generally, the microseconds are
274 counted by the context switch timer, which ticks in virtual time;
275 however, when there are no runnable threads, we don't accumulate any
276 virtual time, so we start ticking in real time. (The granularity is
277 the effective resolution of the context switch timer, so it is
278 affected by the RTS -C option.)
280 @threadWait@ delays rescheduling of a thread until input on the
281 specified file descriptor is available for reading (just like select).
284 threadDelay, threadWait :: Int -> IO ()
286 threadDelay (I# x#) (S# s#) =
288 s2# -> (Right (), S# s2#)
290 threadWait (I# x#) (S# s#) =
292 s2# -> (Right (), S# s2#)