diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index 6c1df4af01cabe95079a2bacd213bc6b69ea1971..10ebbe4d94ca0be8cf03f562b56d9129ec4f4474 100644
--- a/ghc/lib/std/PrelConc.lhs
+++ b/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}
%************************************************************************
diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs
index 9415258f030a1fba1032685d7dac01d3f4408b29..7c96aacd80414882f310ecf8973151fc8cdae90b 100644
--- a/ghc/lib/std/PrelErr.lhs
+++ b/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}
%*********************************************************
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index ebb444feb15aa6ea5555da2e0d260a15efa32a23..1c63aea771b5ad2ed3ce6299e4b90aaae63aa7f8 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/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:
diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 1893f1f7f0faba020650070a1894c734911a5a20..4aaff4518f1ca5a6b955ce2ac75e0f09f7468564 100644
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $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
diff --git a/ghc/lib/std/PrelMain.lhs b/ghc/lib/std/PrelMain.lhs
index 764f201ce4d532e2284360f7e4828057deccc231..9f176fd9e427b7fbb328ea676a64805569b5305b 100644
--- a/ghc/lib/std/PrelMain.lhs
+++ b/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}
+