module PrelHandle where
import PrelBase
-import PrelArr ( newVar, readVar, writeVar, ByteArray )
+import PrelAddr ( Addr, nullAddr )
+import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelException ( throw, ioError, catchException )
+import PrelException
import PrelMaybe ( Maybe(..) )
+import PrelEnum
+import PrelNum
+import PrelShow
import PrelAddr ( Addr, nullAddr )
-import PrelBounded () -- get at Bounded Int instance.
-import PrelNum ( toInteger )
-import PrelWeak ( addForeignFinaliser )
+import PrelNum ( toInteger, toBig )
+import PrelPack ( packString )
+import PrelWeak ( addForeignFinalizer )
+import Ix
+
#if __CONCURRENT_HASKELL__
import PrelConc
#endif
-import Ix
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( makeForeignObj )
#else
#define FILE_OBJECT Addr
#endif
-
\end{code}
%*********************************************************
\begin{code}
{-# INLINE newHandle #-}
{-# INLINE withHandle #-}
-{-# INLINE writeHandle #-}
newHandle :: Handle__ -> IO Handle
-withHandle :: Handle -> (Handle__ -> IO a) -> IO a
-writeHandle :: Handle -> Handle__ -> IO ()
#if defined(__CONCURRENT_HASKELL__)
-- Use MVars for concurrent Haskell
newHandle hc = newMVar hc >>= \ h ->
return (Handle h)
+#else
+
+-- Use ordinary MutableVars for non-concurrent Haskell
+newHandle hc = stToIO (newVar hc >>= \ h ->
+ return (Handle h))
+#endif
+\end{code}
- -- withHandle grabs the handle lock, performs
- -- some operation over it, making sure that we
- -- unlock & reset the handle state should an
- -- exception occur while performing said op.
+%*********************************************************
+%* *
+\subsection{@withHandle@ operations}
+%* *
+%*********************************************************
+
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+orignal handle is always replaced [ this is the case at the moment,
+but we might want to revisit this in the future --SDM ].
+
+\begin{code}
+#ifdef __CONCURRENT_HASKELL__
+withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle (Handle h) act = do
h_ <- takeMVar h
+ (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h'
+ return v
+
+withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
+withHandle_ (Handle h) act = do
+ h_ <- takeMVar h
v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h_
return v
-writeHandle (Handle h) hc = putMVar h hc
-#else
-
--- Use ordinary MutableVars for non-concurrent Haskell
-newHandle hc = stToIO (newVar hc >>= \ h ->
- return (Handle h))
+withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
+withHandle__ (Handle h) act = do
+ h_ <- takeMVar h
+ h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ putMVar h h'
+ return ()
+#else
-- of questionable value to install this exception
-- handler, but let's do it in the non-concurrent
-- case too, for now.
v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
return v
-writeHandle (Handle h) hc = stToIO (writeVar h hc)
#endif
-
\end{code}
nullFile__ is only used for closed handles, plugging it in as a null
%*********************************************************
%* *
-\subsection{Handle Finalisers}
+\subsection{Handle Finalizers}
%* *
%*********************************************************
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#else
fo <- CCALL(openStdFile) (1::Int)
- ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int)
+ ((1{-flush on close-} + 128 {- don't block on I/O-})::Int)
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#endif
- -- NOTE: turn off non-blocking I/O until
- -- we've got proper support for threadWait{Read,Write}
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
#ifdef __HUGS__
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#else
fo <- CCALL(openStdFile) (0::Int)
- ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int)
+ ((0{-flush on close-} + 128 {- don't block on I/O-})::Int)
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#endif
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#else
fo <- CCALL(openStdFile) (2::Int)
- ((1{-flush on close-} {- + 128 don't block on I/O-})::Int)
+ ((1{-flush on close-} + 128 {- don't block on I/O-})::Int)
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#endif
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+ hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+ -- when stderr and stdout are both connected to a terminal, ensure
+ -- that anything buffered on stdout is flushed prior to writing to
+ -- stderr.
+ hConnectTo stdout hdl
+ return hdl
+
_ -> do ioError <- constructError "stderr"
newHandle (mkErrorHandle__ ioError)
)
if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeFileObject fo)
+ addForeignFinalizer fo (freeFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
#ifndef __CONCURRENT_HASKELL__
file_flags = file_flags'
#else
- file_flags = file_flags' {-+ 128 Don't block on I/O-}
+ -- See comment next to 'stderr' for why we leave
+ -- non-blocking off for now.
+ file_flags = file_flags' + 128 -- Don't block on I/O
#endif
(file_flags', file_mode) =
hClose :: Handle -> IO ()
hClose handle =
- withHandle handle $ \ handle_ -> do
+ withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hClose" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return handle_
_ -> do
rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
has been performed, the ForeignObj embedded in the Handle
is still lying around in the heap, so care is taken
to avoid closing the file object when the ForeignObj
- is finalised. (we overwrite the file ptr in the underlying
+ is finalized. (we overwrite the file ptr in the underlying
FileObject with a NULL as part of closeFile())
-}
if rc == (0::Int)
- then
- writeHandle handle (handle_{ haType__ = ClosedHandle,
- haFO__ = nullFile__ })
- else do
- writeHandle handle handle_
- constructErrorAndFail "hClose"
+ then return (handle_{ haType__ = ClosedHandle,
+ haFO__ = nullFile__ })
+ else constructErrorAndFail "hClose"
\end{code}
\begin{code}
hFileSize :: Handle -> IO Integer
hFileSize handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hFileSize" handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hFileSize" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hFileSize" handle
+ SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
_ -> do
mem <- primNewByteArray sizeof_int64
rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
- writeHandle handle handle_
if rc == 0 then do
result <- primReadInt64Array mem 0
return (primInt64ToInteger result)
-- For some reason, this fails to typecheck if converted to a do
-- expression --SDM
_casm_ ``%r = 1;'' >>= \(I# hack#) ->
- case int2Integer hack# of
- result@(J# _ _ d#) -> do
- rc <- CCALL(fileSize) (haFO__ handle_) d# -- ConcHask: SAFE, won't block
- writeHandle handle handle_
+ case int2Integer# hack# of
+ (# s, d #) -> do
+ rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
if rc == (0::Int) then
- return result
+ return (J# s d)
else
constructErrorAndFail "hFileSize"
#endif
wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
- writeHandle handle handle_
case rc of
0 -> return False
1 -> return True
"hSetBuffering"
("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
_ ->
- withHandle handle $ \ handle_ -> do
+ withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hSetBuffering" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
- we flush the old buffer regardless of whether
rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
if rc == 0
then do
- writeHandle handle (handle_{ haBufferMode__ = mode })
+ return (handle_{ haBufferMode__ = mode })
else do
-- Note: failure to change the buffer size will cause old buffer to be flushed.
- writeHandle handle handle_
constructErrorAndFail "hSetBuffering"
where
bsize :: Int
wantWriteableHandle "hFlush" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
- writeHandle handle handle_
if rc == 0 then
return ()
else
hGetPosn handle =
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
- if posn /= -1 then
+ if posn /= -1 then do
return (HandlePosn handle posn)
else
constructErrorAndFail "hGetPosn"
wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
- writeHandle handle handle_
- if rc == 0 then
+ if rc == 0 then do
return ()
else
constructErrorAndFail "hSetPosn"
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
#else
-hSeek handle mode (J# _ s# d#) =
+hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
+hSeek handle mode (J# s# d#) =
wantSeekableHandle "hSeek" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
#endif
- writeHandle handle handle_
- if rc == 0 then
+ if rc == 0 then do
return ()
else
constructErrorAndFail "hSeek"
\begin{code}
hIsOpen :: Handle -> IO Bool
hIsOpen handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- return False
- SemiClosedHandle -> do
- writeHandle handle handle_
- return False
- _ -> do
- writeHandle handle handle_
- return True
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
hIsClosed :: Handle -> IO Bool
hIsClosed handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- return True
- _ -> do
- writeHandle handle handle_
- return False
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> return True
+ _ -> return False
{- not defined, nor exported, but mentioned
here for documentation purposes:
hIsReadable :: Handle -> IO Bool
hIsReadable handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsReadable" handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsReadable" handle
- htype -> do
- writeHandle handle handle_
- return (isReadable htype)
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ htype -> return (isReadable htype)
where
isReadable ReadHandle = True
isReadable ReadWriteHandle = True
hIsWritable :: Handle -> IO Bool
hIsWritable handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsWritable" handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsWritable" handle
- htype -> do
- writeHandle handle handle_
- return (isWritable htype)
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ htype -> return (isWritable htype)
where
isWritable AppendHandle = True
isWritable WriteHandle = True
\begin{code}
hGetBuffering :: Handle -> IO BufferMode
hGetBuffering handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hGetBuffering" handle
- _ -> do
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
+ _ ->
{-
We're being non-standard here, and allow the buffering
of a semi-closed handle to be queried. -- sof 6/98
-}
- let v = haBufferMode__ handle_
- writeHandle handle handle_
- return v -- could be stricter..
-
+ return (haBufferMode__ handle_) -- could be stricter..
\end{code}
\begin{code}
hIsSeekable :: Handle -> IO Bool
hIsSeekable handle =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsSeekable" handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsSeekable" handle
- AppendHandle -> do
- writeHandle handle handle_
- return False
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
+ AppendHandle -> return False
_ -> do
rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
case (rc::Int) of
0 -> return False
1 -> return True
if not isT
then return ()
else
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hSetEcho" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hSetEcho" handle
_ -> do
rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
if rc /= ((-1)::Int)
then return ()
else constructErrorAndFail "hSetEcho"
if not isT
then return False
else
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hGetEcho" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hGetEcho" handle
_ -> do
rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
case (rc::Int) of
1 -> return True
0 -> return False
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
- withHandle handle $ \ handle_ -> do
- case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsTerminalDevice" handle
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
_ -> do
rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
case (rc::Int) of
1 -> return True
0 -> return False
hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
-hConnectHdl_ hW hR is_tty =
- wantWriteableHandle "hConnectTo" hW $ \ hW_ -> do
- wantReadableHandle "hConnectTo" hR $ \ hR_ -> do
+hConnectHdl_ hW hR is_tty =
+ wantRWHandle "hConnectTo" hW $ \ hW_ ->
+ wantRWHandle "hConnectTo" hR $ \ hR_ -> do
CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
- writeHandle hR hR_
- writeHandle hW hW_
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+
+flushConnectedBuf :: FILE_OBJECT -> IO ()
+flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
\end{code}
As an extension, we also allow characters to be pushed back.
hUngetChar handle c =
wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
- writeHandle handle handle_
if rc == ((-1)::Int)
then constructErrorAndFail "hUngetChar"
else return ()
then do
hClose handle
constructErrorAndFail "slurpFile"
- else
- withHandle handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
- writeHandle handle handle_
+ else do
+ rc <- withHandle_ handle ( \ handle_ -> do
+ let fo = haFO__ handle_
+ mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ )
hClose handle
if rc < (0::Int)
then constructErrorAndFail "slurpFile"
#else
rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
#endif
- writeHandle handle handle_
if rc >= (0::Int)
then return rc
else constructErrorAndFail "hFillBufBA"
wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
- writeHandle handle handle_
if rc >= 0
then return rc
else constructErrorAndFail "hFillBuf"
wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
- writeHandle handle handle_
if rc == (0::Int)
then return ()
else constructErrorAndFail "hPutBuf"
wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
let fo = haFO__ handle_
rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
- writeHandle handle handle_
if rc == (0::Int)
then return ()
else constructErrorAndFail "hPutBuf"
\begin{code}
getHandleFd :: Handle -> IO Int
-getHandleFd handle = do
- withHandle handle $ \ handle_ -> do
+getHandleFd handle =
+ withHandle_ handle $ \ handle_ -> do
case (haType__ handle_) of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "getHandleFd" handle
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
fd <- CCALL(getFileFd) (haFO__ handle_)
- writeHandle handle handle_
return fd
\end{code}
\end{code}
+'Top-level' IO actions want to catch exceptions (e.g., forkIO and
+PrelMain.mainIO) and report them - topHandler is the exception
+handler they should use for this:
+
+\begin{code}
+-- make sure we handle errors while reporting the error!
+-- (e.g. evaluating the string passed to 'error' might generate
+-- another error, etc.)
+topHandler :: Bool -> Exception -> IO ()
+topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
+
+real_handler :: Bool -> Exception -> IO ()
+real_handler bombOut ex =
+ case ex of
+ AsyncException StackOverflow -> reportStackOverflow bombOut
+ ErrorCall s -> reportError bombOut s
+ other -> reportError bombOut (showsPrec 0 other "\n")
+
+reportStackOverflow :: Bool -> IO ()
+reportStackOverflow bombOut = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ callStackOverflowHook
+ if bombOut then
+ stg_exit 2
+ else
+ return ()
+
+reportError :: Bool -> String -> IO ()
+reportError bombOut str = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ let bs@(ByteArray (_,len) _) = packString str
+ writeErrString addrOf_ErrorHdrHook bs len
+ if bombOut then
+ stg_exit 1
+ else
+ return ()
+
+foreign label "ErrorHdrHook"
+ addrOf_ErrorHdrHook :: Addr
+
+foreign import ccall "writeErrString__"
+ writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
+
+foreign import ccall "stackOverflow"
+ callStackOverflowHook :: IO ()
+
+foreign import ccall "stg_exit"
+ stg_exit :: Int -> IO ()
+\end{code}
+
+
A number of operations want to get at a readable or writeable handle, and fail
if it isn't:
\begin{code}
wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle fun handle act =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- AppendHandle -> do
- writeHandle handle handle_
- ioError not_readable_error
- WriteHandle -> do
- writeHandle handle handle_
- ioError not_readable_error
- _ -> act handle_
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ AppendHandle -> ioError not_readable_error
+ WriteHandle -> ioError not_readable_error
+ _ -> act handle_
where
not_readable_error =
IOError (Just handle) IllegalOperation fun
wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWriteableHandle fun handle act =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- ReadHandle -> do
- writeHandle handle handle_
- ioError not_writeable_error
- _ -> act handle_
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ ReadHandle -> ioError not_writeable_error
+ _ -> act handle_
where
not_writeable_error =
IOError (Just handle) IllegalOperation fun
("handle is not open for writing")
+wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantRWHandle fun handle act =
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ _ -> act handle_
+
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun handle act =
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> do
- writeHandle handle handle_
- ioError theError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- AppendHandle -> do
- writeHandle handle handle_
- ioError not_seekable_error
- _ -> act handle_
+ ErrorHandle theError -> ioError theError
+ ClosedHandle -> ioe_closedHandle fun handle
+ SemiClosedHandle -> ioe_closedHandle fun handle
+ AppendHandle -> ioError not_seekable_error
+ _ -> act handle_
where
not_seekable_error =
IOError (Just handle)
mayBlock :: Addr -> IO Int -> IO Int
#endif
-#ifndef notyet /*__CONCURRENT_HASKELL__*/
-mayBlock _ act = act
-#else
mayBlock fo act = do
rc <- act
case rc of
CCALL(setNonBlockingIOFlag__) fo -- reset file object.
CCALL(setConnNonBlockingIOFlag__) fo -- reset (connected) file object.
return rc
-
-#endif
-
--- #ifdef __HUGS__
-#if 1
-threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
-
--- Hugs does actually have the primops needed to implement these
--- but, like GHC, the primops don't actually do anything...
-threadDelay _ = return ()
-threadWaitRead _ = return ()
-threadWaitWrite _ = return ()
-#endif
-
\end{code}
foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC