ghc/lib/haskell-1.3/LibPosixIO.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 \section[LibPosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
   5
   6 \begin{code}
   7 module LibPosixIO (
   8     ChannelOption(..),
   9     FileLock(..),
  10     LockRequest(..),
  11
  12     closeChannel,
  13     createPipe,
  14     dupChannel,
  15     dupChannelTo,
  16     getLock,
  17     queryChannelOption,
  18     readChannel,
  19     seekChannel,
  20     setChannelOption,
  21     setLock,
  22     waitToSetLock,
  23     writeChannel
  24     ) where
  25
  26 import PreludeGlaST
  27 import PS
  28
  29 import LibPosixUtil
  30
  31 createPipe :: IO (Channel, Channel)
  32 createPipe =
  33     allocChars ``(2*sizeof(int))''                  `thenStrictlyST` \ bytes ->
  34     _casm_ ``%r = pipe((int *)%0);'' bytes          `thenPrimIO` \ rc ->
  35     if rc /= -1 then
  36         _casm_ ``%r = ((int *)%0)[0];'' bytes       `thenPrimIO` \ wd ->
  37         _casm_ ``%r = ((int *)%0)[1];'' bytes       `thenPrimIO` \ rd ->
  38         return (wd, rd)
  39     else
  40         syserr "createPipe"
  41
  42 dupChannel :: Channel -> IO Channel
  43 dupChannel fd =
  44     _ccall_ dup fd                                  `thenPrimIO` \ fd2 ->
  45     if fd2 /= -1 then
  46         return fd2
  47     else
  48         syserr "dupChannel"
  49
  50 dupChannelTo :: Channel -> Channel -> IO ()
  51 dupChannelTo fd1 fd2 =
  52     _ccall_ dup2 fd1 fd2                            `thenPrimIO` \ rc ->
  53     if rc /= -1 then
  54         return ()
  55     else
  56         syserr "dupChannelTo"
  57
  58 closeChannel :: Channel -> IO ()
  59 closeChannel fd =
  60     _ccall_ close fd                                `thenPrimIO` \ rc ->
  61     if rc /= -1 then
  62         return ()
  63     else
  64         syserr "closeChannel"
  65
  66 readChannel :: Channel -> ByteCount -> IO (String, ByteCount)
  67 readChannel fd 0 = return ("", 0)
  68 readChannel fd nbytes =
  69     allocChars nbytes                               `thenStrictlyST` \ bytes ->
  70     _ccall_ read fd bytes nbytes                    `thenPrimIO` \ rc ->
  71     case rc of
  72       -1 -> syserr "readChannel"
  73       0  -> failWith EOF
  74       n | n == nbytes ->
  75             freeze bytes                            `thenStrictlyST` \ buf ->
  76             return (_unpackPS (_unsafeByteArrayToPS buf n), n)
  77         | otherwise ->
  78             -- Let go of the excessively long ByteArray# by copying to a shorter one.
  79             -- Maybe we need a new primitive, shrinkCharArray#?
  80             allocChars n                            `thenPrimIO` \ bytes' ->
  81             _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
  82                      } while(0);'' bytes' bytes n   `thenPrimIO` \ () ->
  83             freeze bytes'                           `thenStrictlyST` \ buf ->
  84             return (_unpackPS (_unsafeByteArrayToPS buf n), n)
  85
  86 writeChannel :: Channel -> String -> IO ByteCount
  87 writeChannel fd str =
  88     _packBytesForCST str                            `thenPrimIO` \ buf ->
  89     _ccall_ write fd buf (length str)               `thenPrimIO` \ rc ->
  90     if rc /= -1 then
  91         return rc
  92     else
  93         syserr "writeChannel"
  94
  95 data ChannelOption = AppendOnWrite
  96                    | CloseOnExec
  97                    | NonBlockingRead
  98
  99 queryChannelOption :: ChannelOption -> Channel -> IO Bool
 100 queryChannelOption CloseOnExec fd =
 101     _ccall_ fcntl fd (``F_GETFD''::Int) 0           `thenPrimIO` \ (I# flags#) ->
 102     if flags# /=# -1# then
 103         return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
 104     else
 105         syserr "queryChannelOption"
 106   where
 107     fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
 108 queryChannelOption other fd =
 109     _ccall_ fcntl fd (``F_GETFL''::Int) 0           `thenPrimIO` \ (I# flags#) ->
 110     if flags# >=# 0# then
 111         return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
 112     else
 113         syserr "queryChannelOption"
 114   where
 115     opt# = case (
 116         case other of
 117           AppendOnWrite -> ``O_APPEND''
 118           NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
 119
 120 setChannelOption :: ChannelOption -> Bool -> Channel -> IO ()
 121 setChannelOption CloseOnExec val fd =
 122     _ccall_ fcntl fd (``F_GETFD''::Int) 0           `thenPrimIO` \ flags ->
 123     if flags /= -1 then
 124         (if val then
 125             _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
 126         else
 127             _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
 128                                                     `thenPrimIO` \ rc ->
 129         if rc /= -1 then
 130             return ()
 131         else
 132             fail
 133     else
 134         fail
 135   where
 136     fail = syserr "setChannelOption"
 137 setChannelOption other val fd =
 138     _ccall_ fcntl fd (``F_GETFL''::Int) 0           `thenPrimIO` \ flags ->
 139     if flags >= 0 then
 140         (if val then
 141             _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
 142         else
 143             _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
 144                                                     `thenPrimIO` \ rc ->
 145         if rc /= -1 then
 146             return ()
 147         else
 148             fail
 149     else
 150         fail
 151   where
 152     fail = syserr "setChannelOption"
 153     opt =
 154         case other of
 155           AppendOnWrite -> (``O_APPEND''::_Word)
 156           NonBlockingRead -> (``O_NONBLOCK''::_Word)
 157
 158 data LockRequest = ReadLock
 159                  | WriteLock
 160                  | Unlock
 161
 162 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
 163
 164 getLock :: Channel -> FileLock -> IO (Maybe (ProcessID, FileLock))
 165 getLock fd lock =
 166     lock2Bytes lock                                 >>= \ flock ->
 167     _ccall_ fcntl fd (``F_GETLK''::Int) flock       `thenPrimIO` \ rc ->
 168     if rc /= -1 then
 169         bytes2ProcessIDAndLock flock                `thenPrimIO` \ result ->
 170             return (maybeResult result)
 171     else
 172         syserr "getLock"
 173   where
 174     maybeResult (_, (Unlock, _, _, _)) = Nothing
 175     maybeResult x = Just x
 176
 177 setLock :: Channel -> FileLock -> IO ()
 178 setLock fd lock =
 179     lock2Bytes lock                                 >>= \ flock ->
 180     _ccall_ fcntl fd (``F_SETLK''::Int) flock       `thenPrimIO` \ rc ->
 181     if rc /= -1 then
 182         return ()
 183     else
 184         syserr "setLock"
 185
 186 waitToSetLock :: Channel -> FileLock -> IO ()
 187 waitToSetLock fd lock =
 188     lock2Bytes lock                                 >>= \ flock ->
 189     _ccall_ fcntl fd (``F_SETLKW''::Int) flock      `thenPrimIO` \ rc ->
 190     if rc /= -1 then
 191         return ()
 192     else
 193         syserr "waitToSetLock"
 194
 195 seekChannel :: Channel -> SeekMode -> FileOffset -> IO FileOffset
 196 seekChannel fd mode offset =
 197     _ccall_ lseek fd offset (mode2Int mode)         `thenPrimIO` \ rc ->
 198     if rc /= -1 then
 199         return rc
 200     else
 201         syserr "seekChannel"
 202
 203 \end{code}
 204
 205 Local utility functions
 206
 207 \begin{code}
 208
 209 -- Convert a Haskell SeekMode to an int
 210
 211 mode2Int :: SeekMode -> Int
 212 mode2Int AbsoluteSeek = ``SEEK_SET''
 213 mode2Int RelativeSeek = ``SEEK_CUR''
 214 mode2Int SeekFromEnd  = ``SEEK_END''
 215
 216 -- Convert a Haskell FileLock to an flock structure
 217
 218 lock2Bytes :: FileLock -> IO (_MutableByteArray _RealWorld ())
 219 lock2Bytes (kind, mode, start, len) =
 220     allocChars ``sizeof(struct flock)''             `thenStrictlyST` \ bytes ->
 221     _casm_ ``do { struct flock *fl = (struct flock *)%0;
 222              fl->l_type = %1; fl->l_whence = %2; fl->l_start = %3; fl->l_len = %4;
 223              } while(0);'' bytes ltype (mode2Int mode) start len
 224                                                     `thenPrimIO` \ () ->
 225     return bytes
 226   where
 227     ltype :: Int
 228     ltype = case kind of
 229         ReadLock -> ``F_RDLCK''
 230         WriteLock -> ``F_WRLCK''
 231         Unlock -> ``F_UNLCK''
 232
 233 bytes2ProcessIDAndLock :: _MutableByteArray s () -> PrimIO (ProcessID, FileLock)
 234 bytes2ProcessIDAndLock bytes =
 235     _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
 236                                                     `thenPrimIO` \ ltype ->
 237     _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
 238                                                     `thenPrimIO` \ lwhence ->
 239     _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
 240                                                     `thenPrimIO` \ lstart ->
 241     _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
 242                                                     `thenPrimIO` \ llen ->
 243     _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
 244                                                     `thenPrimIO` \ lpid ->
 245     returnPrimIO (lpid, (kind ltype, mode lwhence, lstart, llen))
 246   where
 247     kind :: Int -> LockRequest
 248     kind x
 249       | x == ``F_RDLCK'' = ReadLock
 250       | x == ``F_WRLCK'' = WriteLock
 251       | x == ``F_UNLCK'' = Unlock
 252     mode :: Int -> SeekMode
 253     mode x
 254       | x == ``SEEK_SET'' = AbsoluteSeek
 255       | x == ``SEEK_CUR'' = RelativeSeek
 256       | x == ``SEEK_END'' = SeekFromEnd
 257
 258 \end{code}