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 )
55 import PS ( _PackedString, _unpackPS )
60 import PreludeMonadicIO ( IO(..), Either(..), return, (>>=), (>>) )
61 import PreludeIOError ( IOError13 )
63 infixr 1 `thenPrimIO`, `seqPrimIO`
66 %************************************************************************
68 \subsection[IO-monad]{The @IO@ monad}
70 %************************************************************************
73 type PrimIO a = _ST _RealWorld a
78 {-# GENERATE_SPECS returnPrimIO a #-}
79 returnPrimIO :: a -> PrimIO a
81 {-# GENERATE_SPECS thenPrimIO b #-}
82 thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
84 {-# GENERATE_SPECS seqPrimIO b #-}
85 seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b
87 fixPrimIO :: (a -> PrimIO a) -> PrimIO a
88 listPrimIO :: [PrimIO a] -> PrimIO [a]
89 mapPrimIO :: (a -> PrimIO b) -> [a] -> PrimIO [b]
90 mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c])
92 {-# INLINE returnPrimIO #-}
93 {-# INLINE thenPrimIO #-}
94 {-# INLINE seqPrimIO #-}
96 returnPrimIO x s = returnStrictlyST x s
97 thenPrimIO m k s = thenStrictlyST m k s
98 seqPrimIO m k s = seqStrictlyST m k s
102 listPrimIO [] = returnPrimIO []
103 listPrimIO (m:ms) = m `thenPrimIO` \ x ->
104 listPrimIO ms `thenPrimIO` \xs ->
107 -- An earlier definition of listPrimIO in terms of foldrPrimIO
108 -- was just wrong (it did the operations in the wrong order)
109 -- so I deleted foldrPrimIO and defined listPrimIO directly.
112 mapPrimIO f ms = listPrimIO (map f ms)
114 mapAndUnzipPrimIO f [] = returnPrimIO ([], [])
115 mapAndUnzipPrimIO f (m:ms)
116 = f m `thenPrimIO` \ ( r1, r2) ->
117 mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) ->
118 returnPrimIO (r1:rs1, r2:rs2)
122 {-# GENERATE_SPECS unsafePerformPrimIO a #-}
123 unsafePerformPrimIO :: PrimIO a -> a
125 unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
127 unsafePerformPrimIO k = case (k (S# realWorld#)) of (r, _) -> r
129 unsafeInterleavePrimIO m s = unsafeInterleaveST m s
132 Transitional: for pre-1.3 systems: Don't use them!
134 readChanPrimIO :: String -> PrimIO String
135 appendChanPrimIO :: String -> String -> PrimIO ()
136 appendFilePrimIO :: String -> String -> PrimIO ()
137 getArgsPrimIO :: PrimIO [String]
139 readChanPrimIO c = processIORequestString ( ReadChan c )
140 appendChanPrimIO c s = processIORequestUnit ( AppendChan c s )
141 appendFilePrimIO f s = processIORequestUnit ( AppendFile f s )
142 getArgsPrimIO = processIORequestStrList ( GetArgs )
144 processIORequestUnit :: Request -> PrimIO ()
145 processIORequestString :: Request -> PrimIO String
146 processIORequestStrList :: Request -> PrimIO [String]
148 processIORequestUnit req
149 = processIORequest req `thenPrimIO` \ resp ->
151 Success -> returnPrimIO ()
152 Failure ioerr -> error (ioErrMsg ioerr)
153 _ -> error "funny Response, expected a Success"
155 processIORequestString req
156 = processIORequest req `thenPrimIO` \ resp ->
158 Str str -> returnPrimIO str
159 Failure ioerr -> error (ioErrMsg ioerr)
160 _ -> error "funny Response, expected a String"
162 processIORequestStrList req
163 = processIORequest req `thenPrimIO` \ resp ->
165 StrList strl -> returnPrimIO strl
166 Failure ioerr -> error (ioErrMsg ioerr)
167 _ -> error "funny Response, expected a [String]"
169 ioErrMsg :: IOError -> String
170 ioErrMsg (ReadError s) = "Read Error: " ++ s
171 ioErrMsg (WriteError s) = "Write Error: " ++ s
172 ioErrMsg (FormatError s) = "Format Error: " ++ s
173 ioErrMsg (SearchError s) = "Search Error: " ++ s
174 ioErrMsg (OtherError s) = "Other Error: " ++ s
177 %************************************************************************
179 \subsection[PreludeGlaST-mvars]{M-Structures}
181 %************************************************************************
183 M-Vars are rendezvous points for concurrent threads. They begin
184 empty, and any attempt to read an empty M-Var blocks. When an M-Var
185 is written, a single blocked thread may be freed. Reading an M-Var
186 toggles its state from full back to empty. Therefore, any value
187 written to an M-Var may only be read once. Multiple reads and writes
188 are allowed, but there must be at least one read between any two
192 data _MVar a = _MVar (SynchVar# _RealWorld a)
193 type MVar a = _MVar a
197 newEmptyMVar :: IO (_MVar a)
199 newEmptyMVar (S# s#) =
200 case newSynchVar# s# of
201 StateAndSynchVar# s2# svar# -> (Right (_MVar svar#), S# s2#)
203 takeMVar :: _MVar a -> IO a
205 takeMVar (_MVar mvar#) (S# s#) =
206 case takeMVar# mvar# s# of
207 StateAndPtr# s2# r -> (Right r, S# s2#)
209 putMVar :: _MVar a -> a -> IO ()
211 putMVar (_MVar mvar#) x (S# s#) =
212 case putMVar# mvar# x s# of
213 s2# -> (Right (), S# s2#)
215 newMVar :: a -> IO (_MVar a)
218 newEmptyMVar >>= \ mvar ->
219 putMVar mvar value >>
222 readMVar :: _MVar a -> IO a
225 takeMVar mvar >>= \ value ->
226 putMVar mvar value >>
229 swapMVar :: _MVar a -> a -> IO a
232 takeMVar mvar >>= \ old ->
238 %************************************************************************
240 \subsection[PreludeGlaST-ivars]{I-Structures}
242 %************************************************************************
244 I-Vars are write-once variables. They start out empty, and any threads that
245 attempt to read them will block until they are filled. Once they are written,
246 any blocked threads are freed, and additional reads are permitted. Attempting
247 to write a value to a full I-Var results in a runtime error.
250 data _IVar a = _IVar (SynchVar# _RealWorld a)
251 type IVar a = _IVar a
255 newIVar :: IO (_IVar a)
258 case newSynchVar# s# of
259 StateAndSynchVar# s2# svar# -> (Right (_IVar svar#), S# s2#)
261 readIVar :: _IVar a -> IO a
263 readIVar (_IVar ivar#) (S# s#) =
264 case readIVar# ivar# s# of
265 StateAndPtr# s2# r -> (Right r, S# s2#)
267 writeIVar :: _IVar a -> a -> IO ()
269 writeIVar (_IVar ivar#) x (S# s#) =
270 case writeIVar# ivar# x s# of
271 s2# -> (Right (), S# s2#)
276 %************************************************************************
278 \subsection{Thread Wait Functions}
280 %************************************************************************
282 @threadDelay@ delays rescheduling of a thread until the indicated
283 number of microseconds have elapsed. Generally, the microseconds are
284 counted by the context switch timer, which ticks in virtual time;
285 however, when there are no runnable threads, we don't accumulate any
286 virtual time, so we start ticking in real time. (The granularity is
287 the effective resolution of the context switch timer, so it is
288 affected by the RTS -C option.)
290 @threadWait@ delays rescheduling of a thread until input on the
291 specified file descriptor is available for reading (just like select).
294 threadDelay, threadWait :: Int -> IO ()
296 threadDelay (I# x#) (S# s#) =
298 s2# -> (Right (), S# s2#)
300 threadWait (I# x#) (S# s#) =
302 s2# -> (Right (), S# s2#)