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 (newHandle, getBMode__, getHandleFd,
35 freeFileObject, freeStdFileObject )
39 import Weak ( addForeignFinalizer )
40 import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
43 import PosixFiles ( stdInput, stdOutput, stdError )
46 createPipe :: IO (Fd, Fd)
48 bytes <- allocChars ``(2*sizeof(int))''
49 rc <- _casm_ ``%r = pipe((int *)%0);'' bytes
52 rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
53 wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
60 _ccall_ dup fd >>= \ fd2@(I# fd2#) ->
66 dupTo :: Fd -> Fd -> IO ()
67 dupTo fd1 fd2 = minusone_error (_ccall_ dup2 fd1 fd2) "dupTo"
69 fdClose :: Fd -> IO ()
70 fdClose fd = minusone_error (_ccall_ close fd) "fdClose"
72 handleToFd :: Handle -> IO Fd
78 -- default is no buffering.
79 fdToHandle :: Fd -> IO Handle
80 fdToHandle fd@(FD# fd#) = do
81 -- first find out what kind of file desc. this is..
82 flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
83 if flags /= ((-1)::Int)
88 wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
89 `neWord#` int2Word# 0#
90 aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
91 `neWord#` int2Word# 0#
92 rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
93 `neWord#` int2Word# 0#
95 (handle_t, flush_on_close)
96 | wH && aH = (AppendHandle, 1)
97 | wH = (WriteHandle, 1)
98 | rwH = (ReadWriteHandle, 1)
99 | otherwise = (ReadHandle, 0)
101 fo <- _ccall_ openFd fd flags (flush_on_close::Int)
102 if fo /= nullAddr then do
104 A distinction is made here between std{Input,Output,Error} Fds
105 and all others. The standard descriptors have a finaliser
106 that will not close the underlying fd, the others have one
109 Delaying the closing of the standard descriptors until the process
110 exits is necessary since the RTS is likely to require these after
111 (or as a result of) program termination.
113 #ifndef __PARALLEL_HASKELL__
114 fo <- mkForeignObj fo
115 if fd == stdInput || fd == stdOutput || fd == stdError then
116 addForeignFinalizer fo (freeStdFileObject fo)
118 addForeignFinalizer fo (freeFileObject fo)
120 (bm, bf_size) <- getBMode__ fo
121 mkBuffer__ fo bf_size
122 newHandle (Handle__ fo handle_t bm fd_str)
128 fd_str = "<file descriptor: " ++ show (I# fd#) ++ ">"
130 fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
131 fdRead fd 0 = return ("", 0)
132 fdRead fd nbytes = do
133 bytes <- allocChars nbytes
134 rc <- _ccall_ read fd bytes nbytes
136 -1 -> syserr "fdRead"
137 0 -> ioError (IOError Nothing EOF "fdRead" "EOF")
138 n | n == nbytes -> do
140 s <- unpackNBytesBAIO buf n
143 -- Let go of the excessively long ByteArray# by copying to a
144 -- shorter one. Maybe we need a new primitive, shrinkCharArray#?
145 bytes' <- allocChars n
146 _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
147 } while(0);'' bytes' bytes n
149 s <- unpackNBytesBAIO buf n
152 fdWrite :: Fd -> String -> IO ByteCount
154 buf <- packStringIO str
155 rc <- _ccall_ write fd buf (length str)
158 else syserr "fdWrite"
160 data FdOption = AppendOnWrite
164 queryFdOption :: Fd -> FdOption -> IO Bool
165 queryFdOption fd CloseOnExec =
166 _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int) >>= \ (I# flags#) ->
167 if flags# /=# -1# then
168 return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
170 syserr "queryFdOption"
172 fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
173 queryFdOption fd other =
174 _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int) >>= \ (I# flags#) ->
175 if flags# >=# 0# then
176 return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
178 syserr "queryFdOption"
182 AppendOnWrite -> ``O_APPEND''
183 NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
185 setFdOption :: Fd -> FdOption -> Bool -> IO ()
186 setFdOption fd CloseOnExec val = do
187 flags <- _ccall_ fcntl fd (``F_GETFD''::Int) (0::Int)
188 if flags /= ((-1)::Int) then do
190 _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
192 _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
198 fail = syserr "setFdOption"
200 setFdOption fd other val = do
201 flags <- _ccall_ fcntl fd (``F_GETFL''::Int) (0::Int)
202 if flags >= (0::Int) then do
204 _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
206 _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
212 fail = syserr "setFdOption"
215 AppendOnWrite -> (``O_APPEND''::Word)
216 NonBlockingRead -> (``O_NONBLOCK''::Word)
218 data LockRequest = ReadLock
222 type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
224 getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
226 flock <- lock2Bytes lock
227 rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
230 result <- bytes2ProcessIDAndLock flock
231 return (maybeResult result)
232 else syserr "getLock"
234 maybeResult (_, (Unlock, _, _, _)) = Nothing
235 maybeResult x = Just x
237 setLock :: Fd -> FileLock -> IO ()
239 flock <- lock2Bytes lock
240 minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
242 waitToSetLock :: Fd -> FileLock -> IO ()
243 waitToSetLock fd lock = do
244 flock <- lock2Bytes lock
245 minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
247 fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
248 fdSeek fd mode offset = do
249 rc <- _ccall_ lseek fd offset (mode2Int mode)
256 Local utility functions
260 -- Convert a Haskell SeekMode to an int
262 mode2Int :: SeekMode -> Int
263 mode2Int AbsoluteSeek = ``SEEK_SET''
264 mode2Int RelativeSeek = ``SEEK_CUR''
265 mode2Int SeekFromEnd = ``SEEK_END''
267 -- Convert a Haskell FileLock to an flock structure
268 lockRequest2Int :: LockRequest -> Int
269 lockRequest2Int kind =
271 ReadLock -> ``F_RDLCK''
272 WriteLock -> ``F_WRLCK''
273 Unlock -> ``F_UNLCK''
275 lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int)
276 lock2Bytes (kind, mode, start, len) = do
277 bytes <- allocChars ``sizeof(struct flock)''
278 _casm_ ``do { struct flock *fl = (struct flock *)%0;
284 bytes (lockRequest2Int kind) (mode2Int mode) start len
288 bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock)
289 bytes2ProcessIDAndLock bytes = do
290 ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
291 lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
292 lstart <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
293 llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
294 lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
295 return (lpid, (kind ltype, mode lwhence, lstart, llen))
297 kind :: Int -> LockRequest
299 | x == ``F_RDLCK'' = ReadLock
300 | x == ``F_WRLCK'' = WriteLock
301 | x == ``F_UNLCK'' = Unlock
303 mode :: Int -> SeekMode
305 | x == ``SEEK_SET'' = AbsoluteSeek
306 | x == ``SEEK_CUR'' = RelativeSeek
307 | x == ``SEEK_END'' = SeekFromEnd