[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / 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}