ghc/lib/glaExts/PreludePrimIO.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[PrimIO]{@PrimIO@ monad}
   5
   6 This sits on top of the state-transformer monad.  See
   7 state-interface.verb.
   8
   9 We follow the Haskell~1.3 I/O proposal nomenclature.
  10
  11 \begin{code}
  12 module PreludePrimIO (
  13         -- PrimIO(..): no, the compiler already knows about it
  14
  15         fixPrimIO,
  16         listPrimIO,
  17         mapAndUnzipPrimIO,
  18         mapPrimIO,
  19         returnPrimIO,
  20         seqPrimIO,
  21         thenPrimIO,
  22         unsafePerformPrimIO,
  23         unsafeInterleavePrimIO,
  24 --      forkPrimIO,
  25
  26         -- all the Stdio stuff (this is how you get to it)
  27         -- (well, why not?)
  28         fclose, fdopen, fflush, fopen, fread, freopen,
  29         fwrite, _FILE(..),
  30
  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,
  36
  37         threadWait, threadDelay,
  38
  39         -- backward compatibility -- don't use!
  40         readChanPrimIO,
  41         appendChanPrimIO,
  42         appendFilePrimIO,
  43         getArgsPrimIO,
  44
  45         -- make interface self-sufficient
  46         fixST, unsafeInterleaveST
  47     ) where
  48
  49 import PreludeGlaST
  50 import TyArray          ( Array(..) )
  51 import Cls
  52 import Core
  53 import List             ( (++), map )
  54 import PreludeDialogueIO ( processIORequest )
  55 import TyIO
  56 import Stdio
  57
  58 import PreludeMonadicIO ( IO(..), Either(..), return, (>>=), (>>) )
  59 import PreludeIOError   ( IOError13 )
  60
  61 infixr 1 `thenPrimIO`, `seqPrimIO`
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection[IO-monad]{The @IO@ monad}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 type PrimIO a     = _ST _RealWorld a
  72 \end{code}
  73
  74 The usual business:
  75 \begin{code}
  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])
  83
  84 {-# INLINE returnPrimIO #-}
  85 {-# INLINE thenPrimIO   #-}
  86 {-# INLINE seqPrimIO  #-}
  87
  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
  91
  92 fixPrimIO           = fixST
  93
  94 listPrimIO []     = returnPrimIO []
  95 listPrimIO (m:ms) = m                   `thenPrimIO` \ x ->
  96                     listPrimIO ms       `thenPrimIO` \xs ->
  97                     returnPrimIO (x:xs)
  98
  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.
 102 -- SLPJ Feb 95
 103
 104 mapPrimIO f ms = listPrimIO (map f ms)
 105
 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)
 111 \end{code}
 112
 113 \begin{code}
 114 unsafePerformPrimIO    :: PrimIO a -> a
 115 unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
 116
 117 unsafePerformPrimIO k = case (k (S# realWorld#)) of (r, _) -> r
 118
 119 unsafeInterleavePrimIO m s = unsafeInterleaveST m s
 120 \end{code}
 121
 122 Transitional: for pre-1.3 systems: Don't use them!
 123 \begin{code}
 124 readChanPrimIO    :: String  ->             PrimIO String
 125 appendChanPrimIO  :: String  -> String   -> PrimIO ()
 126 appendFilePrimIO  :: String  -> String   -> PrimIO ()
 127 getArgsPrimIO     ::                        PrimIO [String]
 128
 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 )
 133
 134 processIORequestUnit    :: Request -> PrimIO ()
 135 processIORequestString  :: Request -> PrimIO String
 136 processIORequestStrList :: Request -> PrimIO [String]
 137
 138 processIORequestUnit req
 139   = processIORequest req        `thenPrimIO` \ resp ->
 140     case resp of
 141       Success       -> returnPrimIO ()
 142       Failure ioerr -> error (ioErrMsg ioerr)
 143       _             -> error "funny Response, expected a Success"
 144
 145 processIORequestString req
 146   = processIORequest req        `thenPrimIO` \ resp ->
 147     case resp of
 148       Str str       -> returnPrimIO str
 149       Failure ioerr -> error (ioErrMsg ioerr)
 150       _             -> error "funny Response, expected a String"
 151
 152 processIORequestStrList req
 153   = processIORequest req        `thenPrimIO` \ resp ->
 154     case resp of
 155       StrList strl  -> returnPrimIO strl
 156       Failure ioerr -> error (ioErrMsg ioerr)
 157       _             -> error "funny Response, expected a [String]"
 158
 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
 165 \end{code}
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection[PreludeGlaST-mvars]{M-Structures}
 170 %*                                                                      *
 171 %************************************************************************
 172
 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
 179 writes.
 180
 181 \begin{code}
 182 data _MVar a = _MVar (SynchVar# _RealWorld a)
 183 type MVar a = _MVar a
 184 \end{code}
 185
 186 \begin{code}
 187 newEmptyMVar  :: IO (_MVar a)
 188
 189 newEmptyMVar (S# s#) =
 190     case newSynchVar# s# of
 191         StateAndSynchVar# s2# svar# -> (Right (_MVar svar#), S# s2#)
 192
 193 takeMVar :: _MVar a -> IO a
 194
 195 takeMVar (_MVar mvar#) (S# s#) =
 196     case takeMVar# mvar# s# of
 197         StateAndPtr# s2# r -> (Right r, S# s2#)
 198
 199 putMVar  :: _MVar a -> a -> IO ()
 200
 201 putMVar (_MVar mvar#) x (S# s#) =
 202     case putMVar# mvar# x s# of
 203         s2# -> (Right (), S# s2#)
 204
 205 newMVar :: a -> IO (_MVar a)
 206
 207 newMVar value =
 208     newEmptyMVar        >>= \ mvar ->
 209     putMVar mvar value  >>
 210     return mvar
 211
 212 readMVar :: _MVar a -> IO a
 213
 214 readMVar mvar =
 215     takeMVar mvar       >>= \ value ->
 216     putMVar mvar value  >>
 217     return value
 218
 219 swapMVar :: _MVar a -> a -> IO a
 220
 221 swapMVar mvar new =
 222     takeMVar mvar       >>= \ old ->
 223     putMVar mvar new    >>
 224     return old
 225
 226 \end{code}
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection[PreludeGlaST-ivars]{I-Structures}
 231 %*                                                                      *
 232 %************************************************************************
 233
 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.
 238
 239 \begin{code}
 240 data _IVar a = _IVar (SynchVar# _RealWorld a)
 241 type IVar a = _IVar a
 242 \end{code}
 243
 244 \begin{code}
 245 newIVar :: IO (_IVar a)
 246
 247 newIVar (S# s#) =
 248     case newSynchVar# s# of
 249         StateAndSynchVar# s2# svar# -> (Right (_IVar svar#), S# s2#)
 250
 251 readIVar :: _IVar a -> IO a
 252
 253 readIVar (_IVar ivar#) (S# s#) =
 254     case readIVar# ivar# s# of
 255         StateAndPtr# s2# r -> (Right r, S# s2#)
 256
 257 writeIVar :: _IVar a -> a -> IO ()
 258
 259 writeIVar (_IVar ivar#) x (S# s#) =
 260     case writeIVar# ivar# x s# of
 261         s2# -> (Right (), S# s2#)
 262
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection{Thread Wait Functions}
 269 %*                                                                      *
 270 %************************************************************************
 271
 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.)
 279
 280 @threadWait@ delays rescheduling of a thread until input on the
 281 specified file descriptor is available for reading (just like select).
 282
 283 \begin{code}
 284 threadDelay, threadWait :: Int -> IO ()
 285
 286 threadDelay (I# x#) (S# s#) =
 287     case delay# x# s# of
 288       s2# -> (Right (), S# s2#)
 289
 290 threadWait (I# x#) (S# s#) =
 291     case wait# x# s# of
 292       s2# -> (Right (), S# s2#)
 293 \end{code}