[project @ 1999-06-01 16:15:42 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelHandle.lhs

diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index 10886a0..d044bf8 100644 (file)
--- 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 )
@@ -83,7 +88,7 @@ newHandle hc  = newMVar       hc      >>= \ h ->
   -- 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
@@ -365,7 +370,7 @@ hClose handle =
          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
@@ -434,12 +439,12 @@ 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
+          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
@@ -641,6 +646,7 @@ 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_
@@ -886,7 +892,7 @@ hGetEcho handle = do
 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
@@ -910,8 +916,8 @@ 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_
@@ -1043,7 +1049,7 @@ the Handle contains..
 
 \begin{code}
 getHandleFd :: Handle -> IO Int
-getHandleFd handle = do
+getHandleFd handle =
     withHandle handle $ \ handle_ -> do
     case (haType__ handle_) of
       ErrorHandle theError -> do
@@ -1087,6 +1093,57 @@ 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: