Commit 65bec1e3 authored by sof's avatar sof
Browse files

[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.
parent 90c0b29e
......@@ -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}
%************************************************************************
......
......@@ -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}
%*********************************************************
......
......@@ -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:
......
% -----------------------------------------------------------------------------
% $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
......
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment