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 PS               ( _PackedString, _unpackPS )
  56 import TyComplex
  57 import TyIO
  58 import Stdio
  59
  60 import PreludeMonadicIO ( IO(..), Either(..), return, (>>=), (>>) )
  61 import PreludeIOError   ( IOError13 )
  62
  63 infixr 1 `thenPrimIO`, `seqPrimIO`
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection[IO-monad]{The @IO@ monad}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 type PrimIO a     = _ST _RealWorld a
  74 \end{code}
  75
  76 The usual business:
  77 \begin{code}
  78 {-# GENERATE_SPECS returnPrimIO a #-}
  79 returnPrimIO    :: a -> PrimIO a
  80
  81 {-# GENERATE_SPECS thenPrimIO b #-}
  82 thenPrimIO      :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
  83
  84 {-# GENERATE_SPECS seqPrimIO b #-}
  85 seqPrimIO       :: PrimIO a -> PrimIO b -> PrimIO b
  86
  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])
  91
  92 {-# INLINE returnPrimIO #-}
  93 {-# INLINE thenPrimIO   #-}
  94 {-# INLINE seqPrimIO  #-}
  95
  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
  99
 100 fixPrimIO           = fixST
 101
 102 listPrimIO []     = returnPrimIO []
 103 listPrimIO (m:ms) = m                   `thenPrimIO` \ x ->
 104                     listPrimIO ms       `thenPrimIO` \xs ->
 105                     returnPrimIO (x:xs)
 106
 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.
 110 -- SLPJ Feb 95
 111
 112 mapPrimIO f ms = listPrimIO (map f ms)
 113
 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)
 119 \end{code}
 120
 121 \begin{code}
 122 {-# GENERATE_SPECS unsafePerformPrimIO a #-}
 123 unsafePerformPrimIO    :: PrimIO a -> a
 124
 125 unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
 126
 127 unsafePerformPrimIO k = case (k (S# realWorld#)) of (r, _) -> r
 128
 129 unsafeInterleavePrimIO m s = unsafeInterleaveST m s
 130 \end{code}
 131
 132 Transitional: for pre-1.3 systems: Don't use them!
 133 \begin{code}
 134 readChanPrimIO    :: String  ->             PrimIO String
 135 appendChanPrimIO  :: String  -> String   -> PrimIO ()
 136 appendFilePrimIO  :: String  -> String   -> PrimIO ()
 137 getArgsPrimIO     ::                        PrimIO [String]
 138
 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 )
 143
 144 processIORequestUnit    :: Request -> PrimIO ()
 145 processIORequestString  :: Request -> PrimIO String
 146 processIORequestStrList :: Request -> PrimIO [String]
 147
 148 processIORequestUnit req
 149   = processIORequest req        `thenPrimIO` \ resp ->
 150     case resp of
 151       Success       -> returnPrimIO ()
 152       Failure ioerr -> error (ioErrMsg ioerr)
 153       _             -> error "funny Response, expected a Success"
 154
 155 processIORequestString req
 156   = processIORequest req        `thenPrimIO` \ resp ->
 157     case resp of
 158       Str str       -> returnPrimIO str
 159       Failure ioerr -> error (ioErrMsg ioerr)
 160       _             -> error "funny Response, expected a String"
 161
 162 processIORequestStrList req
 163   = processIORequest req        `thenPrimIO` \ resp ->
 164     case resp of
 165       StrList strl  -> returnPrimIO strl
 166       Failure ioerr -> error (ioErrMsg ioerr)
 167       _             -> error "funny Response, expected a [String]"
 168
 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
 175 \end{code}
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection[PreludeGlaST-mvars]{M-Structures}
 180 %*                                                                      *
 181 %************************************************************************
 182
 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
 189 writes.
 190
 191 \begin{code}
 192 data _MVar a = _MVar (SynchVar# _RealWorld a)
 193 type MVar a = _MVar a
 194 \end{code}
 195
 196 \begin{code}
 197 newEmptyMVar  :: IO (_MVar a)
 198
 199 newEmptyMVar (S# s#) =
 200     case newSynchVar# s# of
 201         StateAndSynchVar# s2# svar# -> (Right (_MVar svar#), S# s2#)
 202
 203 takeMVar :: _MVar a -> IO a
 204
 205 takeMVar (_MVar mvar#) (S# s#) =
 206     case takeMVar# mvar# s# of
 207         StateAndPtr# s2# r -> (Right r, S# s2#)
 208
 209 putMVar  :: _MVar a -> a -> IO ()
 210
 211 putMVar (_MVar mvar#) x (S# s#) =
 212     case putMVar# mvar# x s# of
 213         s2# -> (Right (), S# s2#)
 214
 215 newMVar :: a -> IO (_MVar a)
 216
 217 newMVar value =
 218     newEmptyMVar        >>= \ mvar ->
 219     putMVar mvar value  >>
 220     return mvar
 221
 222 readMVar :: _MVar a -> IO a
 223
 224 readMVar mvar =
 225     takeMVar mvar       >>= \ value ->
 226     putMVar mvar value  >>
 227     return value
 228
 229 swapMVar :: _MVar a -> a -> IO a
 230
 231 swapMVar mvar new =
 232     takeMVar mvar       >>= \ old ->
 233     putMVar mvar new    >>
 234     return old
 235
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[PreludeGlaST-ivars]{I-Structures}
 241 %*                                                                      *
 242 %************************************************************************
 243
 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.
 248
 249 \begin{code}
 250 data _IVar a = _IVar (SynchVar# _RealWorld a)
 251 type IVar a = _IVar a
 252 \end{code}
 253
 254 \begin{code}
 255 newIVar :: IO (_IVar a)
 256
 257 newIVar (S# s#) =
 258     case newSynchVar# s# of
 259         StateAndSynchVar# s2# svar# -> (Right (_IVar svar#), S# s2#)
 260
 261 readIVar :: _IVar a -> IO a
 262
 263 readIVar (_IVar ivar#) (S# s#) =
 264     case readIVar# ivar# s# of
 265         StateAndPtr# s2# r -> (Right r, S# s2#)
 266
 267 writeIVar :: _IVar a -> a -> IO ()
 268
 269 writeIVar (_IVar ivar#) x (S# s#) =
 270     case writeIVar# ivar# x s# of
 271         s2# -> (Right (), S# s2#)
 272
 273 \end{code}
 274
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsection{Thread Wait Functions}
 279 %*                                                                      *
 280 %************************************************************************
 281
 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.)
 289
 290 @threadWait@ delays rescheduling of a thread until input on the
 291 specified file descriptor is available for reading (just like select).
 292
 293 \begin{code}
 294 threadDelay, threadWait :: Int -> IO ()
 295
 296 threadDelay (I# x#) (S# s#) =
 297     case delay# x# s# of
 298       s2# -> (Right (), S# s2#)
 299
 300 threadWait (I# x#) (S# s#) =
 301     case wait# x# s# of
 302       s2# -> (Right (), S# s2#)
 303 \end{code}