X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=5085b9c65a658539be008c3f0b753b593ce923e7;hb=78d10ce46a7d0c60aab9e088a8004f1b6dd435d5;hp=10886a0bd37ca1aa862020cc789ea9f7b0b2c50d;hpb=449deb80dde91031b86b9cb4fb183696e0139bae;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index 10886a0..5085b9c 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -15,20 +15,25 @@ which are supported for them. 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 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 ) @@ -66,33 +71,71 @@ The @Handle@ and @Handle__@ types are defined in @IOBase@. \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. @@ -101,7 +144,6 @@ withHandle (Handle h) act = do v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex) return v -writeHandle (Handle h) hc = stToIO (writeVar h hc) #endif \end{code} @@ -180,11 +222,9 @@ stdout = unsafePerformIO (do (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 @@ -216,7 +256,7 @@ stdin = unsafePerformIO (do (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 @@ -248,7 +288,7 @@ stderr = unsafePerformIO (do (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 @@ -313,7 +353,7 @@ openFileEx f m = do #else -- 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-} + file_flags = file_flags' + 128 -- Don't block on I/O #endif (file_flags', file_mode) = @@ -358,14 +398,10 @@ implementation is free to impose stricter conditions. 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 @@ -377,12 +413,9 @@ hClose handle = 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} @@ -404,22 +437,15 @@ which can be read from {\em hdl}. \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) @@ -434,12 +460,11 @@ hFileSize handle = -- 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 @@ -456,7 +481,6 @@ hIsEOF handle = 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 @@ -510,14 +534,10 @@ hSetBuffering handle mode = "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 @@ -533,10 +553,9 @@ hSetBuffering handle mode = 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 @@ -557,7 +576,6 @@ hFlush handle = 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 @@ -592,8 +610,7 @@ hGetPosn :: Handle -> IO HandlePosn 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" @@ -603,8 +620,7 @@ hSetPosn (HandlePosn handle posn) = 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" @@ -641,13 +657,13 @@ hSeek handle mode offset = let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block #else +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" @@ -678,34 +694,20 @@ $( Just n )$ for block-buffering of {\em n} bytes. \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: @@ -719,20 +721,12 @@ hIsClosed handle = 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 @@ -740,20 +734,12 @@ hIsReadable handle = 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 @@ -784,45 +770,29 @@ Querying how a handle buffers its data: \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 @@ -846,17 +816,12 @@ hSetEcho handle on = do 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" @@ -867,17 +832,12 @@ hGetEcho handle = do 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 @@ -885,17 +845,12 @@ hGetEcho handle = do 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 @@ -910,12 +865,10 @@ hConnectTo :: Handle -> Handle -> IO () 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_ - writeHandle hW hW_ #ifndef __PARALLEL_HASKELL__ #define FILE_OBJECT ForeignObj @@ -937,7 +890,6 @@ hUngetChar :: Handle -> Char -> IO () 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 () @@ -963,11 +915,11 @@ slurpFile fname = do 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" @@ -988,7 +940,6 @@ hFillBufBA handle buf sz #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" @@ -1004,7 +955,6 @@ hFillBuf handle buf sz 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" @@ -1020,7 +970,6 @@ hPutBuf handle buf len = 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" @@ -1031,7 +980,6 @@ hPutBufBA handle buf len = 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" @@ -1043,18 +991,13 @@ the Handle contains.. \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} @@ -1087,30 +1030,71 @@ ioeGetFileName (IOError _ _ _ str) = \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 @@ -1118,21 +1102,13 @@ wantReadableHandle fun handle act = 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 @@ -1140,40 +1116,22 @@ wantWriteableHandle fun handle act = wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantRWHandle 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 - _ -> act handle_ - where - not_rw_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for reading or writing") + 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) @@ -1200,9 +1158,6 @@ mayBlock :: ForeignObj -> IO Int -> IO Int mayBlock :: Addr -> IO Int -> IO Int #endif -#ifndef notyet /*__CONCURRENT_HASKELL__*/ -mayBlock _ act = act -#else mayBlock fo act = do rc <- act case rc of @@ -1225,20 +1180,6 @@ mayBlock fo act = do 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}