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}
%*********************************************************
-- exception occur while performing said op.
withHandle (Handle h) act = do
h_ <- takeMVar h
- v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ v <- catchNonIO (act h_) (\ ex -> putMVar h h_ >> throw ex)
return v
writeHandle (Handle h) hc = putMVar h hc
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}
%* *
%*********************************************************
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
#ifdef __HUGS__
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
- addForeignFinaliser fo (freeStdFileObject fo)
+ addForeignFinalizer fo (freeStdFileObject fo)
#endif
hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
-- when stderr and stdout are both connected to a terminal, ensure
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
ioError theError
ClosedHandle -> do
writeHandle handle handle_
- ioe_closedHandle "hClose" handle
+ return ()
_ -> 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)
-- 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
+ case int2Integer# hack# of
+ (# s, d #) -> do
+ rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
writeHandle handle handle_
if rc == (0::Int) then
- return result
+ return (J# s d)
else
constructErrorAndFail "hFileSize"
#endif
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
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
withHandle handle $ \ handle_ -> do
- case haType__ handle_ of
+ case haType__ handle_ of
ErrorHandle theError -> do
writeHandle handle handle_
ioError theError
hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
-hConnectHdl_ hW hR is_tty =
- wantRWHandle "hConnectTo" hW $ \ hW_ -> 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_
\begin{code}
getHandleFd :: Handle -> IO Int
-getHandleFd handle = do
+getHandleFd handle =
withHandle handle $ \ handle_ -> do
case (haType__ handle_) of
ErrorHandle theError -> do
\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:
projects / ghc-hetmet.git / blobdiff