2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
4 \section[PosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
28 handleToFd, fdToHandle,
34 import PrelHandle (filePtr, readHandle, writeHandle, newHandle)
36 import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST )
41 import PosixFiles ( stdInput, stdOutput, stdError )
44 createPipe :: IO (Fd, Fd)
46 bytes <- allocChars ``(2*sizeof(int))''
47 rc <- _casm_ ``%r = pipe((int *)%0);'' bytes
50 rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
51 wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
58 _ccall_ dup fd >>= \ fd2@(I# fd2#) ->
64 dupTo :: Fd -> Fd -> IO ()
65 dupTo fd1 fd2 = minusone_error (_ccall_ dup2 fd1 fd2) "dupTo"
67 fdClose :: Fd -> IO ()
68 fdClose fd = minusone_error (_ccall_ close fd) "fdClose"
70 handleToFd :: Handle -> IO Fd
74 ErrorHandle ioError -> writeHandle h h_ >> fail ioError
75 ClosedHandle -> writeHandle h h_ >>
76 fail (IOError Nothing IllegalOperation
78 SemiClosedHandle _ _ -> writeHandle h h_ >>
79 fail (IOError Nothing IllegalOperation
80 "handle is semi-closed")
82 let file = filePtr h_ in
83 _casm_ `` %r=fileno((FILE *)%0); '' file >>= \ fd@(FD# fd#) ->
85 if fd# /=# (negateInt# 1#) then
90 -- default is no buffering.
91 fdToHandle :: Fd -> IO Handle
92 fdToHandle fd@(FD# fd#) =
93 _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ flags@(I# flags#) ->
96 wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
97 `neWord#` int2Word# 0#
98 aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
99 `neWord#` int2Word# 0#
100 rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
101 `neWord#` int2Word# 0#
105 then ("a",AppendHandle)
106 else ("w",WriteHandle)
108 ("r+",ReadWriteHandle)
112 _ccall_ fdopen fd ft >>= \ file_struct@(A# ptr#) ->
113 if file_struct /= (``NULL''::Addr) then
115 A distinction is made here between std{Input,Output,Error} Fds
116 and all others. The standard descriptors have a finaliser
117 that will not close the underlying fd, the others have one
118 that will. Or rather, the closing of the standard descriptors is
119 delayed until the process exits.
121 #ifndef __PARALLEL_HASKELL__
122 (if fd == stdInput || fd == stdOutput || fd == stdError then
123 makeForeignObj file_struct (``&freeStdFile''::Addr)
125 makeForeignObj file_struct (``&freeFile''::Addr)) >>= \ fp ->
126 newHandle (handle_t fp Nothing False)
128 newHandle (handle_t file_struct Nothing False)
135 fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
136 fdRead fd 0 = return ("", 0)
137 fdRead fd nbytes = do
138 bytes <- allocChars nbytes
139 rc <- _ccall_ read fd bytes nbytes
141 -1 -> syserr "fdRead"
142 0 -> fail (IOError Nothing EOF "EOF")
143 n | n == nbytes -> do
145 return (unpackPS (unsafeByteArrayToPS buf n), n)
147 -- Let go of the excessively long ByteArray# by copying to a
148 -- shorter one. Maybe we need a new primitive, shrinkCharArray#?
149 bytes' <- allocChars n
150 _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
151 } while(0);'' bytes' bytes n
153 return (unpackPS (unsafeByteArrayToPS buf n), n)
155 fdWrite :: Fd -> String -> IO ByteCount
157 buf <- stToIO (psToByteArrayST str)
158 rc <- _ccall_ write fd buf (length str)
161 else syserr "fdWrite"
163 data FdOption = AppendOnWrite
167 queryFdOption :: Fd -> FdOption -> IO Bool
168 queryFdOption fd CloseOnExec =
169 _ccall_ fcntl fd (``F_GETFD''::Int) 0 >>= \ (I# flags#) ->
170 if flags# /=# -1# then
171 return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
173 syserr "queryFdOption"
175 fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
176 queryFdOption fd other =
177 _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ (I# flags#) ->
178 if flags# >=# 0# then
179 return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
181 syserr "queryFdOption"
185 AppendOnWrite -> ``O_APPEND''
186 NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
188 setFdOption :: Fd -> FdOption -> Bool -> IO ()
189 setFdOption fd CloseOnExec val = do
190 flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
191 if flags /= -1 then do
193 _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
195 _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
201 fail = syserr "setFdOption"
203 setFdOption fd other val = do
204 flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
205 if flags >= 0 then do
207 _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
209 _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
215 fail = syserr "setFdOption"
218 AppendOnWrite -> (``O_APPEND''::Word)
219 NonBlockingRead -> (``O_NONBLOCK''::Word)
221 data LockRequest = ReadLock
225 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
227 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
229 flock <- lock2Bytes lock
230 rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
233 result <- bytes2ProcessIDAndLock flock
234 return (maybeResult result)
235 else syserr "getLock"
237 maybeResult (_, (Unlock, _, _, _)) = Nothing
238 maybeResult x = Just x
240 setLock :: Fd -> FileLock -> IO ()
242 flock <- lock2Bytes lock
243 minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
245 waitToSetLock :: Fd -> FileLock -> IO ()
246 waitToSetLock fd lock = do
247 flock <- lock2Bytes lock
248 minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
250 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
251 fdSeek fd mode offset = do
252 rc <- _ccall_ lseek fd offset (mode2Int mode)
259 Local utility functions
263 -- Convert a Haskell SeekMode to an int
265 mode2Int :: SeekMode -> Int
266 mode2Int AbsoluteSeek = ``SEEK_SET''
267 mode2Int RelativeSeek = ``SEEK_CUR''
268 mode2Int SeekFromEnd = ``SEEK_END''
270 -- Convert a Haskell FileLock to an flock structure
271 lockRequest2Int :: LockRequest -> Int
272 lockRequest2Int kind =
274 ReadLock -> ``F_RDLCK''
275 WriteLock -> ``F_WRLCK''
276 Unlock -> ``F_UNLCK''
278 lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld ())
279 lock2Bytes (kind, mode, start, len) = do
280 bytes <- allocChars ``sizeof(struct flock)''
281 _casm_ ``do { struct flock *fl = (struct flock *)%0;
287 bytes (lockRequest2Int kind) (mode2Int mode) start len
291 bytes2ProcessIDAndLock :: MutableByteArray s () -> IO (ProcessID, FileLock)
292 bytes2ProcessIDAndLock bytes = do
293 ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
294 lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
295 lstart <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
296 llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
297 lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
298 return (lpid, (kind ltype, mode lwhence, lstart, llen))
300 kind :: Int -> LockRequest
302 | x == ``F_RDLCK'' = ReadLock
303 | x == ``F_WRLCK'' = WriteLock
304 | x == ``F_UNLCK'' = Unlock
305 mode :: Int -> SeekMode
307 | x == ``SEEK_SET'' = AbsoluteSeek
308 | x == ``SEEK_CUR'' = RelativeSeek
309 | x == ``SEEK_END'' = SeekFromEnd