--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
+%
+\section[PosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
+
+\begin{code}
+module PosixIO (
+ FdOption(..),
+ FileLock,
+ LockRequest(..),
+
+ fdClose,
+ createPipe,
+ dup,
+ dupTo,
+
+ fdRead,
+ fdWrite,
+ fdSeek,
+
+ queryFdOption,
+ setFdOption,
+
+ getLock, setLock,
+ waitToSetLock,
+
+ -- Handle <-> Fd
+ handleToFd, fdToHandle,
+ ) where
+
+import GlaExts
+import ST
+import PrelIOBase
+import PrelHandle (filePtr, readHandle, writeHandle, newHandle)
+import IO
+import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST )
+import Addr
+import Foreign
+
+import PosixUtil
+import PosixFiles ( stdInput, stdOutput, stdError )
+
+
+createPipe :: IO (Fd, Fd)
+createPipe = do
+ bytes <- allocChars ``(2*sizeof(int))''
+ rc <- _casm_ ``%r = pipe((int *)%0);'' bytes
+ if rc /= -1
+ then do
+ rd <- _casm_ ``%r = ((int *)%0)[0];'' bytes
+ wd <- _casm_ ``%r = ((int *)%0)[1];'' bytes
+ return (rd, wd)
+ else
+ syserr "createPipe"
+
+dup :: Fd -> IO Fd
+dup fd =
+ _ccall_ dup fd >>= \ fd2@(I# fd2#) ->
+ if fd2 /= -1 then
+ return (FD# fd2#)
+ else
+ syserr "dup"
+
+dupTo :: Fd -> Fd -> IO ()
+dupTo fd1 fd2 = minusone_error (_ccall_ dup2 fd1 fd2) "dupTo"
+
+fdClose :: Fd -> IO ()
+fdClose fd = minusone_error (_ccall_ close fd) "fdClose"
+
+handleToFd :: Handle -> IO Fd
+handleToFd h = do
+ h_ <- readHandle h
+ case h_ of
+ ErrorHandle ioError -> writeHandle h h_ >> fail ioError
+ ClosedHandle -> writeHandle h h_ >>
+ fail (IOError Nothing IllegalOperation
+ "handle is closed")
+ SemiClosedHandle _ _ -> writeHandle h h_ >>
+ fail (IOError Nothing IllegalOperation
+ "handle is semi-closed")
+ other ->
+ let file = filePtr h_ in
+ _casm_ `` %r=fileno((FILE *)%0); '' file >>= \ fd@(FD# fd#) ->
+ writeHandle h h_ >>
+ if fd# /=# (negateInt# 1#) then
+ return fd
+ else
+ syserr "handleToFd"
+
+-- default is no buffering.
+fdToHandle :: Fd -> IO Handle
+fdToHandle fd@(FD# fd#) =
+ _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ flags@(I# flags#) ->
+ if flags /= -1 then
+ let
+ wH = (int2Word# flags# `and#` (case ``O_WRONLY'' of { W# x -> x}))
+ `neWord#` int2Word# 0#
+ aH = (int2Word# flags# `and#` (case ``O_APPEND'' of { W# x -> x}))
+ `neWord#` int2Word# 0#
+ rwH = (int2Word# flags# `and#` (case ``O_RDWR'' of { W# x -> x }))
+ `neWord#` int2Word# 0#
+ (ft,handle_t) =
+ if wH then
+ if aH
+ then ("a",AppendHandle)
+ else ("w",WriteHandle)
+ else if rwH then
+ ("r+",ReadWriteHandle)
+ else
+ ("r",ReadHandle)
+ in
+ _ccall_ fdopen fd ft >>= \ file_struct@(A# ptr#) ->
+ if file_struct /= (``NULL''::Addr) then
+ {-
+ A distinction is made here between std{Input,Output,Error} Fds
+ and all others. The standard descriptors have a finaliser
+ that will not close the underlying fd, the others have one
+ that will. Or rather, the closing of the standard descriptors is
+ delayed until the process exits.
+ -}
+#ifndef __PARALLEL_HASKELL__
+ (if fd == stdInput || fd == stdOutput || fd == stdError then
+ makeForeignObj file_struct (``&freeStdFile''::Addr)
+ else
+ makeForeignObj file_struct (``&freeFile''::Addr)) >>= \ fp ->
+ newHandle (handle_t fp Nothing False)
+#else
+ newHandle (handle_t file_struct Nothing False)
+#endif
+ else
+ syserr "fdToHandle"
+ else
+ syserr "fdToHandle"
+
+fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
+fdRead fd 0 = return ("", 0)
+fdRead fd nbytes = do
+ bytes <- allocChars nbytes
+ rc <- _ccall_ read fd bytes nbytes
+ case rc of
+ -1 -> syserr "fdRead"
+ 0 -> fail (IOError Nothing EOF "EOF")
+ n | n == nbytes -> do
+ buf <- freeze bytes
+ return (unpackPS (unsafeByteArrayToPS buf n), n)
+ | otherwise -> do
+ -- Let go of the excessively long ByteArray# by copying to a
+ -- shorter one. Maybe we need a new primitive, shrinkCharArray#?
+ bytes' <- allocChars n
+ _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
+ } while(0);'' bytes' bytes n
+ buf <- freeze bytes'
+ return (unpackPS (unsafeByteArrayToPS buf n), n)
+
+fdWrite :: Fd -> String -> IO ByteCount
+fdWrite fd str = do
+ buf <- stToIO (psToByteArrayST str)
+ rc <- _ccall_ write fd buf (length str)
+ if rc /= -1
+ then return rc
+ else syserr "fdWrite"
+
+data FdOption = AppendOnWrite
+ | CloseOnExec
+ | NonBlockingRead
+
+queryFdOption :: Fd -> FdOption -> IO Bool
+queryFdOption fd CloseOnExec =
+ _ccall_ fcntl fd (``F_GETFD''::Int) 0 >>= \ (I# flags#) ->
+ if flags# /=# -1# then
+ return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
+ else
+ syserr "queryFdOption"
+ where
+ fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
+queryFdOption fd other =
+ _ccall_ fcntl fd (``F_GETFL''::Int) 0 >>= \ (I# flags#) ->
+ if flags# >=# 0# then
+ return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
+ else
+ syserr "queryFdOption"
+ where
+ opt# = case (
+ case other of
+ AppendOnWrite -> ``O_APPEND''
+ NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
+
+setFdOption :: Fd -> FdOption -> Bool -> IO ()
+setFdOption fd CloseOnExec val = do
+ flags <- _ccall_ fcntl fd (``F_GETFD''::Int) 0
+ if flags /= -1 then do
+ rc <- (if val then
+ _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
+ else do
+ _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
+ if rc /= -1
+ then return ()
+ else fail
+ else fail
+ where
+ fail = syserr "setFdOption"
+
+setFdOption fd other val = do
+ flags <- _ccall_ fcntl fd (``F_GETFL''::Int) 0
+ if flags >= 0 then do
+ rc <- (if val then
+ _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
+ else do
+ _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
+ if rc /= -1
+ then return ()
+ else fail
+ else fail
+ where
+ fail = syserr "setFdOption"
+ opt =
+ case other of
+ AppendOnWrite -> (``O_APPEND''::Word)
+ NonBlockingRead -> (``O_NONBLOCK''::Word)
+
+data LockRequest = ReadLock
+ | WriteLock
+ | Unlock
+
+type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
+
+getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
+getLock fd lock = do
+ flock <- lock2Bytes lock
+ rc <- _ccall_ fcntl fd (``F_GETLK''::Int) flock
+ if rc /= -1
+ then do
+ result <- bytes2ProcessIDAndLock flock
+ return (maybeResult result)
+ else syserr "getLock"
+ where
+ maybeResult (_, (Unlock, _, _, _)) = Nothing
+ maybeResult x = Just x
+
+setLock :: Fd -> FileLock -> IO ()
+setLock fd lock = do
+ flock <- lock2Bytes lock
+ minusone_error (_ccall_ fcntl fd (``F_SETLK''::Int) flock) "setLock"
+
+waitToSetLock :: Fd -> FileLock -> IO ()
+waitToSetLock fd lock = do
+ flock <- lock2Bytes lock
+ minusone_error (_ccall_ fcntl fd (``F_SETLKW''::Int) flock) "waitToSetLock"
+
+fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
+fdSeek fd mode offset = do
+ rc <- _ccall_ lseek fd offset (mode2Int mode)
+ if rc /= -1
+ then return rc
+ else syserr "fdSeek"
+
+\end{code}
+
+Local utility functions
+
+\begin{code}
+
+-- Convert a Haskell SeekMode to an int
+
+mode2Int :: SeekMode -> Int
+mode2Int AbsoluteSeek = ``SEEK_SET''
+mode2Int RelativeSeek = ``SEEK_CUR''
+mode2Int SeekFromEnd = ``SEEK_END''
+
+-- Convert a Haskell FileLock to an flock structure
+lockRequest2Int :: LockRequest -> Int
+lockRequest2Int kind =
+ case kind of
+ ReadLock -> ``F_RDLCK''
+ WriteLock -> ``F_WRLCK''
+ Unlock -> ``F_UNLCK''
+
+lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld ())
+lock2Bytes (kind, mode, start, len) = do
+ bytes <- allocChars ``sizeof(struct flock)''
+ _casm_ ``do { struct flock *fl = (struct flock *)%0;
+ fl->l_type = %1;
+ fl->l_whence = %2;
+ fl->l_start = %3;
+ fl->l_len = %4;
+ } while(0);''
+ bytes (lockRequest2Int kind) (mode2Int mode) start len
+ return bytes
+-- where
+
+bytes2ProcessIDAndLock :: MutableByteArray s () -> IO (ProcessID, FileLock)
+bytes2ProcessIDAndLock bytes = do
+ ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
+ lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
+ lstart <- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
+ llen <- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
+ lpid <- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
+ return (lpid, (kind ltype, mode lwhence, lstart, llen))
+-- where
+kind :: Int -> LockRequest
+kind x
+ | x == ``F_RDLCK'' = ReadLock
+ | x == ``F_WRLCK'' = WriteLock
+ | x == ``F_UNLCK'' = Unlock
+mode :: Int -> SeekMode
+mode x
+ | x == ``SEEK_SET'' = AbsoluteSeek
+ | x == ``SEEK_CUR'' = RelativeSeek
+ | x == ``SEEK_END'' = SeekFromEnd
+
+\end{code}
projects / ghc-hetmet.git / blobdiff