[project @ 1999-04-27 17:41:17 by sof]

* Added toplevel exception handler:

    topHandler :: Bool -- bomb on exception caught
               -> Exception
	       -> IO ()

   for PrelMain.mainIO and Concurrent.forkIO to use

 * moved forkIO out of PrelConc and into Concurrent.

ghc/lib/std/PrelConc.lhs

@@ -10,17 +10,13 @@ Basic concurrency stuff
 {-# OPTIONS -fno-implicit-prelude #-}
 
 module PrelConc
-
-	-- Thread Ids
-	( ThreadId	-- abstract
+	( ThreadId(..)
 
 	-- Forking and suchlike
-	, forkIO	-- :: IO () -> IO ThreadId
 	, myThreadId 	-- :: IO ThreadId
 	, killThread	-- :: ThreadId -> IO ()
 	, raiseInThread -- :: ThreadId -> Exception -> IO ()
 	, par  		-- :: a -> b -> b
-	, fork  	-- :: a -> b -> b
 	, seq  		-- :: a -> b -> b
 	{-threadDelay, threadWaitRead, threadWaitWrite,-}
 
@@ -43,7 +39,7 @@ import PrelIOBase	( IO(..), MVar(..), unsafePerformIO )
 import PrelBase		( Int(..) )
 import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`, `fork`
+infixr 0 `par`
 \end{code}
 
 %************************************************************************
@@ -58,9 +54,7 @@ data ThreadId = ThreadId ThreadId#
 -- But since ThreadId# is unlifted, the Weak type must use open
 -- type variables.
 
-forkIO :: IO () -> IO ThreadId
-forkIO action = IO $ \ s -> 
-   case (fork# action s) of (# s1, id #) -> (# s1, ThreadId id #)
+--forkIO has now been hoisted out into the concurrent library.
 
 killThread :: ThreadId -> IO ()
 killThread (ThreadId id) = IO $ \ s ->
@@ -89,18 +83,15 @@ myThreadId = IO $ \s ->
 seq :: a -> b -> b
 seq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 
-par, fork :: a -> b -> b
+par :: a -> b -> b
 
 {-# INLINE par  #-}
-{-# INLINE fork #-}
 #if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__)
 par  x y = case (par# x) of { 0# -> parError; _ -> y }
 #else
 par  _ y = y
 #endif
 
-fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
-
 \end{code}
 
 %************************************************************************

ghc/lib/std/PrelErr.lhs

@@ -32,28 +32,9 @@ module PrelErr
        ) where
 
 import PrelBase
-import PrelIOBase   ( IO(..) )
---import PrelHandle   ( catch )
-import PrelAddr
 import PrelList     ( span )
 import PrelException
-import PrelPack     ( packString )
-import PrelArr      ( ByteArray(..) )
-
-#ifndef __PARALLEL_HASKELL__
-import PrelStable  ( StablePtr, deRefStablePtr )
-#endif
-
----------------------------------------------------------------
--- HACK: Magic unfoldings not implemented for unboxed lists
---	 Need to define a "build" to avoid undefined symbol
--- in this module to avoid .hi proliferation.
-
---{-# GENERATE_SPECS build a #-}
---build 		:: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
---build g 	= g (:) []
---build   = error "GHCbase.build"
---augment = error "GHCbase.augment"
+
 \end{code}
 
 %*********************************************************
@@ -63,65 +44,9 @@ import PrelStable  ( StablePtr, deRefStablePtr )
 %*********************************************************
 
 \begin{code}
-{-
-errorIO :: IO () -> a
-
-errorIO (IO io)
-  = case (errorIO# io) of
-      _ -> bottom
-  where
-    bottom = bottom -- Never evaluated
--}
---ioError :: String -> a
---ioError s = error__ ``&IOErrorHdrHook'' s 
-
 -- error stops execution and displays an error message
 error :: String -> a
 error s = throw (ErrorCall s)
---error s = error__ ``&ErrorHdrHook'' s
-{-
--- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
--- but the former does exactly the same as the latter, so I nuked it.
---		SLPJ Jan 97
---
--- Hmm..distinguishing between these two kinds of error is quite useful in the
--- compiler sources, printing out a more verbose msg in the case of patter
--- matching failure.
--- So I've reinstated patError to invoke its own message function hook again.
---    SOF 8/98
-patError__ x = error__ ``&PatErrorHdrHook'' x
-
-error__ :: Addr{-C function pointer to hook-} -> String -> a
-
-error__ msg_hdr s
-#ifdef __PARALLEL_HASKELL__
-  = errorIO (do
-     (hFlush stdout) `catchException` (\ _ -> return ())
-     let bs@(ByteArray (_,len) _) = packString s
-     _ccall_ writeErrString__ msg_hdr bs len
-     _ccall_ stg_exit (1::Int)
-    )
-#else
-  = errorIO ( do
-      (hFlush stdout) `catchException` (\ _ -> return ())
-	    -- Note: there's potential for trouble here in a
-	    -- a concurrent setting if an error is flagged after the
-	    -- lock on the stdout handle. (I don't see a possibility
-	    -- of this occurring with the current impl, but still.)
-      let bs@(ByteArray (_,len) _) = packString s
-      _ccall_ writeErrString__ msg_hdr bs len
-      errorHandler <- _ccall_ getErrorHandler
-      if errorHandler == (-1::Int) then
-	 _ccall_ stg_exit (1::Int)
-       else do
-	osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
-	_ccall_ decrementErrorCount
-	oact  <- deRefStablePtr osptr
-	oact
-   )
-
-#endif {- !parallel -}
--}
 \end{code}
 
 %*********************************************************

ghc/lib/std/PrelHandle.lhs

@@ -15,20 +15,22 @@ 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 PrelAddr		( Addr, nullAddr )
 import PrelBounded      ()   -- get at Bounded Int instance.
 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 )
@@ -1088,6 +1090,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:
 

ghc/lib/std/PrelIOBase.lhs

 % -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.8 1999/03/31 09:52:05 sof Exp $
+% $Id: PrelIOBase.lhs,v 1.9 1999/04/27 17:41:19 sof Exp $
 % 
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
@@ -164,7 +164,6 @@ data IOErrorType
   | EOF
 #ifdef _WIN32
   | ComError Int           -- HRESULT
-	     (Maybe Addr)  -- Pointer to 'exception' object. (IExceptionInfo..)
 #endif
   deriving (Eq)
 
@@ -191,6 +190,9 @@ instance Show IOErrorType where
       UserError         -> "failed"
       UnsupportedOperation -> "unsupported operation"
       EOF		-> "end of file"
+#ifdef _WIN32
+      ComError _	-> "COM error"
+#endif
 
 
 

ghc/lib/std/PrelMain.lhs

@@ -5,59 +5,20 @@
 \section[PrelMain]{Module @PrelMain@}
 
 \begin{code}
-{-# OPTIONS -#include "cbits/stgio.h" #-}
-
 module PrelMain( mainIO ) where
 
 import Prelude
 import {-# SOURCE #-} qualified Main	-- for type of "Main.main"
-import IO 		( hFlush, hPutStr, stdout, stderr )
-import PrelAddr 	( Addr )
+
 import PrelException
-import PrelPack     ( packString )
-import PrelArr      ( ByteArray(..) )
+import PrelHandle ( topHandler )
+
 \end{code}
 
 \begin{code}
 mainIO :: IO ()		-- It must be of type (IO t) because that's what
 			-- the RTS expects.  GHC doesn't check this, so
 			-- make sure this type signature stays!
-mainIO = catchException Main.main handler
-
--- make sure we handle errors while reporting the error!
--- (e.g. evaluating the string passed to 'error' might generate
---  another error, etc.)
-
-handler :: Exception -> IO ()
-handler err = catchException (real_handler err) handler
-
-real_handler :: Exception -> IO ()
-real_handler ex =
-  case ex of
-	AsyncException StackOverflow -> reportStackOverflow
-	ErrorCall s -> reportError s
-	other       -> reportError (showsPrec 0 other "\n")
-
-reportStackOverflow :: IO ()
-reportStackOverflow = do
-   (hFlush stdout) `catchException` (\ _ -> return ())
-   callStackOverflowHook
-   stg_exit 2  
-
-reportError :: String -> IO ()
-reportError str = do
-   (hFlush stdout) `catchException` (\ _ -> return ())
-   let bs@(ByteArray (_,len) _) = packString str
-   writeErrString (``&ErrorHdrHook''::Addr) bs len
-   stg_exit 1
-
-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 ()
-
+mainIO = catchException Main.main (topHandler True)
 \end{code}
+