Commit d9eb68cf authored by simonm's avatar simonm
Browse files

[project @ 1999-03-17 13:19:19 by simonm]

- Stack overflow now generates an (AsyncException StackOverflow)
  exception, which can be caught as normal.

- Add a stack overflow handler to the top-level mainIO handler, with
  the standard behaviour (i.e. call the stack overflow hook and then
  exit).

- Add a test for stack overflow catching.

- Fix a couple of bugs in async exception support.
parent e28f99fd
......@@ -1201,6 +1201,8 @@ sub setupLinkOpts {
,'-u', "${uscore}PrelBase_False_static_closure"
,'-u', "${uscore}PrelBase_True_static_closure"
,'-u', "${uscore}PrelPack_unpackCString_closure"
,'-u', "${uscore}PrelException_stackOverflow_closure"
,'-u', "${uscore}PrelException_heapOverflow_closure"
));
if (!$NoHaskellMain) {
unshift (@Ld_flags,'-u', "${uscore}PrelMain_mainIO_closure");
......
/* -----------------------------------------------------------------------------
* $Id: Prelude.h,v 1.6 1999/03/02 19:44:11 sof Exp $
* $Id: Prelude.h,v 1.7 1999/03/17 13:19:19 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -18,6 +18,8 @@ extern DLL_IMPORT const StgClosure PrelBase_Z40Z41_static_closure;
extern DLL_IMPORT const StgClosure PrelBase_True_static_closure;
extern DLL_IMPORT const StgClosure PrelBase_False_static_closure;
extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure;
extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure;
extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure;
extern const StgClosure PrelMain_mainIO_closure;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info;
......@@ -41,29 +43,31 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info;
* module these names are defined in.
*/
#define Nil_closure PrelBase_ZMZN_static_closure
#define Unit_closure PrelBase_Z0T_static_closure
#define True_closure PrelBase_True_static_closure
#define False_closure PrelBase_False_static_closure
#define Czh_static_info PrelBase_Czh_static_info
#define Izh_static_info PrelBase_Izh_static_info
#define Fzh_static_info PrelBase_Fzh_static_info
#define Dzh_static_info PrelBase_Dzh_static_info
#define Azh_static_info PrelAddr_Azh_static_info
#define Wzh_static_info PrelAddr_Wzh_static_info
#define Czh_con_info PrelBase_Czh_con_info
#define Izh_con_info PrelBase_Izh_con_info
#define Fzh_con_info PrelBase_Fzh_con_info
#define Dzh_con_info PrelBase_Dzh_con_info
#define Azh_con_info PrelAddr_Azh_con_info
#define Wzh_con_info PrelAddr_Wzh_con_info
#define W64zh_con_info PrelAddr_W64zh_con_info
#define I64zh_con_info PrelAddr_I64zh_con_info
#define StablePtr_static_info PrelStable_StablePtr_static_info
#define StablePtr_con_info PrelStable_StablePtr_con_info
#define Nil_closure PrelBase_ZMZN_static_closure
#define Unit_closure PrelBase_Z0T_static_closure
#define True_closure PrelBase_True_static_closure
#define False_closure PrelBase_False_static_closure
#define stackOverflow_closure PrelException_stackOverflow_closure
#define heapOverflow_closure PrelException_heapOverflow_closure
#define Czh_static_info PrelBase_Czh_static_info
#define Izh_static_info PrelBase_Izh_static_info
#define Fzh_static_info PrelBase_Fzh_static_info
#define Dzh_static_info PrelBase_Dzh_static_info
#define Azh_static_info PrelAddr_Azh_static_info
#define Wzh_static_info PrelAddr_Wzh_static_info
#define Czh_con_info PrelBase_Czh_con_info
#define Izh_con_info PrelBase_Izh_con_info
#define Fzh_con_info PrelBase_Fzh_con_info
#define Dzh_con_info PrelBase_Dzh_con_info
#define Azh_con_info PrelAddr_Azh_con_info
#define Wzh_con_info PrelAddr_Wzh_con_info
#define W64zh_con_info PrelAddr_W64zh_con_info
#define I64zh_con_info PrelAddr_I64zh_con_info
#define StablePtr_static_info PrelStable_StablePtr_static_info
#define StablePtr_con_info PrelStable_StablePtr_con_info
#define mainIO_closure PrelMain_mainIO_closure
#define unpackCString_closure PrelPack_unpackCString_closure
#define mainIO_closure PrelMain_mainIO_closure
#define unpackCString_closure PrelPack_unpackCString_closure
#else /* INTERPRETER, I guess */
......
% -----------------------------------------------------------------------------
% $Id: PrelException.lhs,v 1.4 1999/01/14 18:12:57 sof Exp $
% $Id: PrelException.lhs,v 1.5 1999/03/17 13:19:20 simonm Exp $
%
% (c) The GRAP/AQUA Project, Glasgow University, 1998
%
......@@ -52,6 +52,10 @@ data AsyncException
| ThreadKilled
deriving (Eq, Ord)
stackOverflow, heapOverflow :: Exception -- for the RTS
stackOverflow = AsyncException StackOverflow
heapOverflow = AsyncException HeapOverflow
instance Show ArithException where
showsPrec _ Overflow = showString "arithmetic overflow"
showsPrec _ Underflow = showString "arithmetic underflow"
......
......@@ -34,14 +34,30 @@ 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
_ccall_ writeErrString__ (``&ErrorHdrHook''::Addr) bs len
_ccall_ stg_exit (1::Int)
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 ()
\end{code}
/* -----------------------------------------------------------------------------
* $Id: HeapStackCheck.hc,v 1.4 1999/03/16 13:20:15 simonm Exp $
* $Id: HeapStackCheck.hc,v 1.5 1999/03/17 13:19:21 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -798,6 +798,10 @@ FN_(stg_gen_hp)
FE_
}
/* -----------------------------------------------------------------------------
Yields
-------------------------------------------------------------------------- */
FN_(stg_gen_yield)
{
FB_
......@@ -806,10 +810,23 @@ FN_(stg_gen_yield)
FE_
}
INFO_TABLE_SRT_BITMAP(stg_yield_noregs_info, stg_yield_noregs_ret, 0/*BITMAP*/,
0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
RET_SMALL, const, EF_, 0, 0);
FN_(stg_yield_noregs_ret)
{
FB_
JMP_(ENTRY_CODE(Sp[0]))
FE_
}
FN_(stg_yield_noregs)
{
FB_
YIELD_GENERIC
Sp--;
Sp[0] = (W_)&stg_yield_noregs_info;
YIELD_GENERIC;
FE_
}
......@@ -821,6 +838,10 @@ FN_(stg_yield_to_Hugs)
FE_
}
/* -----------------------------------------------------------------------------
Blocks
-------------------------------------------------------------------------- */
FN_(stg_gen_block)
{
FB_
......
/* -----------------------------------------------------------------------------
* $Id: PrimOps.hc,v 1.22 1999/03/16 13:20:15 simonm Exp $
* $Id: PrimOps.hc,v 1.23 1999/03/17 13:19:22 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -845,6 +845,7 @@ FN_(takeMVarzh_fast)
mvar->tail->link = CurrentTSO;
}
CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
CurrentTSO->blocked_on = (StgClosure *)mvar;
mvar->tail = CurrentTSO;
BLOCK(R1_PTR, takeMVarzh_fast);
......
/* -----------------------------------------------------------------------------
* $Id: RtsUtils.c,v 1.7 1999/03/02 20:05:41 sof Exp $
* $Id: RtsUtils.c,v 1.8 1999/03/17 13:19:23 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -112,16 +112,13 @@ raiseError( StgStablePtr handler STG_UNUSED )
-------------------------------------------------------------------------- */
void
stackOverflow(nat max_stack_size)
stackOverflow(void)
{
fflush(stdout);
StackOverflowHook(max_stack_size * sizeof(W_)); /*msg*/
StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
#if defined(TICKY_TICKY)
if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
stg_exit(EXIT_FAILURE);
}
void
......
/* -----------------------------------------------------------------------------
* $Id: RtsUtils.h,v 1.3 1999/02/05 16:02:51 simonm Exp $
* $Id: RtsUtils.h,v 1.4 1999/03/17 13:19:23 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -19,7 +19,7 @@ extern void _stgAssert (char *filename, unsigned int linenum);
extern StgStablePtr errorHandler;
extern void raiseError( StgStablePtr handler );
extern void stackOverflow(nat stk_size);
extern void stackOverflow(void);
extern void heapOverflow(void);
extern nat stg_strlen(char *str);
......
/* -----------------------------------------------------------------------------
* $Id: Schedule.c,v 1.17 1999/03/17 09:50:08 simonm Exp $
* $Id: Schedule.c,v 1.18 1999/03/17 13:19:24 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -515,13 +515,14 @@ threadStackOverflow(StgTSO *tso)
StgTSO *dest;
if (tso->stack_size >= tso->max_stack_size) {
/* ToDo: just kill this thread? */
#ifdef DEBUG
#ifdef 0
/* If we're debugging, just print out the top of the stack */
printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
tso->sp+64));
#endif
stackOverflow(tso->max_stack_size);
/* Send this thread the StackOverflow exception */
raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
return tso;
}
/* Try to double the current stack size. If that takes us over the
......@@ -640,9 +641,10 @@ unblockThread(StgTSO *tso)
if (mvar->tail == tso) {
mvar->tail = last_tso;
}
break;
goto done;
}
}
barf("unblockThread (MVAR): TSO not found");
}
case BLACKHOLE_BQ:
......@@ -654,17 +656,20 @@ unblockThread(StgTSO *tso)
last = &t->link, t = t->link) {
if (t == tso) {
*last = tso->link;
break;
goto done;
}
}
barf("unblockThread (BLACKHOLE): TSO not found");
}
default:
barf("unblockThread");
}
done:
tso->link = END_TSO_QUEUE;
tso->blocked_on = NULL;
PUSH_ON_RUN_QUEUE(tso);
}
/* -----------------------------------------------------------------------------
......@@ -761,10 +766,6 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
tso->su = cf->link;
tso->sp = sp;
tso->whatNext = ThreadEnterGHC;
/* wake up the thread */
if (tso->link == END_TSO_QUEUE) {
PUSH_ON_RUN_QUEUE(tso);
}
return;
}
......
module Main where
import Concurrent
import Exception
data Result = Died Exception | Finished
-- Test stack overflow catching. Should print "Died: stack overflow".
main = do
let x = sum [1..100000] -- relies on sum being implemented badly :-)
result <- newEmptyMVar
forkIO (catchAllIO (x `seq` putMVar result Finished)
(\e -> putMVar result (Died e)))
res <- takeMVar result
case res of
Died e -> putStr ("Died: " ++ show e ++ "\n")
Finished -> putStr "Ok.\n"
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