2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
4 \section[PosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
7 {-# OPTIONS -#include "../std/cbits/stgio.h" #-}
29 handleToFd, fdToHandle,
34 import PrelHandle (readHandle, writeHandle, newHandle, getBMode__, getHandleFd )
38 import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
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
76 -- default is no buffering.
77 fdToHandle :: Fd -> IO Handle
78 fdToHandle fd@(FD# fd#) = do
79 -- first find out what kind of file desc. this is..
80 flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
86 wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
87 `neWord#` int2Word# 0#
88 aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
89 `neWord#` int2Word# 0#
90 rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
91 `neWord#` int2Word# 0#
93 (handle_t, flush_on_close)
94 | wH && aH = (AppendHandle, 1)
95 | wH = (WriteHandle, 1)
96 | rwH = (ReadWriteHandle, 1)
97 | otherwise = (ReadHandle, 0)
99 fo <- _ccall_ openFd fd flags flush_on_close
100 if fo /= nullAddr then do
102 A distinction is made here between std{Input,Output,Error} Fds
103 and all others. The standard descriptors have a finaliser
104 that will not close the underlying fd, the others have one
107 Delaying the closing of the standard descriptors until the process
108 exits is necessary since the RTS is likely to require these after
109 (or as a result of) program termination.
111 #ifndef __PARALLEL_HASKELL__
113 (if fd == stdInput || fd == stdOutput || fd == stdError then
114 makeForeignObj fo (``&freeStdFile''::Addr)
116 makeForeignObj fo (``&freeFileObject''::Addr))
118 (bm, bf_size) <- getBMode__ fo
119 mkBuffer__ fo bf_size
120 newHandle (Handle__ fo handle_t bm fd_str)
126 fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
128 fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
129 fdRead fd 0 = return ("", 0)
130 fdRead fd nbytes = do
131 bytes <- allocChars nbytes
132 rc <- _ccall_ read fd bytes nbytes
134 -1 -> syserr "fdRead"
135 0 -> fail (IOError Nothing EOF "fdRead" "EOF")
136 n | n == nbytes -> do
138 s <- unpackNBytesBAIO buf n
141 -- Let go of the excessively long ByteArray# by copying to a
142 -- shorter one. Maybe we need a new primitive, shrinkCharArray#?
143 bytes' <- allocChars n
144 _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
145 } while(0);'' bytes' bytes n
147 s <- unpackNBytesBAIO buf n
150 fdWrite :: Fd -> String -> IO ByteCount
152 buf <- packStringIO str
153 rc <- _ccall_ write fd buf (length str)
156 else syserr "fdWrite"
158 data FdOption = AppendOnWrite
162 queryFdOption :: Fd -> FdOption -> IO Bool
163 queryFdOption fd CloseOnExec =
164 _ccall_ fcntl fd (``F_GETFD''::Int) 0 >>= \ (I# flags#) ->
165 if flags# /=# -1# then
166 return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
168 syserr "queryFdOption"
170 fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
171 queryFdOption fd other =
172 _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ (I# flags#) ->
173 if flags# >=# 0# then
174 return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
176 syserr "queryFdOption"
180 AppendOnWrite -> ``O_APPEND''
181 NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
183 setFdOption :: Fd -> FdOption -> Bool -> IO ()
184 setFdOption fd CloseOnExec val = do
185 flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
186 if flags /= -1 then do
188 _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
190 _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
196 fail = syserr "setFdOption"
198 setFdOption fd other val = do
199 flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
200 if flags >= 0 then do
202 _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
204 _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
210 fail = syserr "setFdOption"
213 AppendOnWrite -> (``O_APPEND''::Word)
214 NonBlockingRead -> (``O_NONBLOCK''::Word)
216 data LockRequest = ReadLock
220 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
222 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
224 flock <- lock2Bytes lock
225 rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
228 result <- bytes2ProcessIDAndLock flock
229 return (maybeResult result)
230 else syserr "getLock"
232 maybeResult (_, (Unlock, _, _, _)) = Nothing
233 maybeResult x = Just x
235 setLock :: Fd -> FileLock -> IO ()
237 flock <- lock2Bytes lock
238 minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
240 waitToSetLock :: Fd -> FileLock -> IO ()
241 waitToSetLock fd lock = do
242 flock <- lock2Bytes lock
243 minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
245 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
246 fdSeek fd mode offset = do
247 rc <- _ccall_ lseek fd offset (mode2Int mode)
254 Local utility functions
258 -- Convert a Haskell SeekMode to an int
260 mode2Int :: SeekMode -> Int
261 mode2Int AbsoluteSeek = ``SEEK_SET''
262 mode2Int RelativeSeek = ``SEEK_CUR''
263 mode2Int SeekFromEnd = ``SEEK_END''
265 -- Convert a Haskell FileLock to an flock structure
266 lockRequest2Int :: LockRequest -> Int
267 lockRequest2Int kind =
269 ReadLock -> ``F_RDLCK''
270 WriteLock -> ``F_WRLCK''
271 Unlock -> ``F_UNLCK''
273 lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int)
274 lock2Bytes (kind, mode, start, len) = do
275 bytes <- allocChars ``sizeof(struct flock)''
276 _casm_ ``do { struct flock *fl = (struct flock *)%0;
282 bytes (lockRequest2Int kind) (mode2Int mode) start len
286 bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock)
287 bytes2ProcessIDAndLock bytes = do
288 ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
289 lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
290 lstart <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
291 llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
292 lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
293 return (lpid, (kind ltype, mode lwhence, lstart, llen))
295 kind :: Int -> LockRequest
297 | x == ``F_RDLCK'' = ReadLock
298 | x == ``F_WRLCK'' = WriteLock
299 | x == ``F_UNLCK'' = Unlock
301 mode :: Int -> SeekMode
303 | x == ``SEEK_SET'' = AbsoluteSeek
304 | x == ``SEEK_CUR'' = RelativeSeek
305 | x == ``SEEK_END'' = SeekFromEnd