From d9eb68cf8382efdeb8f8e127044ef865a0dcc82a Mon Sep 17 00:00:00 2001 From: simonm Date: Wed, 17 Mar 1999 13:19:28 +0000 Subject: [PATCH] [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. --- ghc/driver/ghc.lprl | 2 + ghc/includes/Prelude.h | 50 +++++++++++++----------- ghc/lib/std/PrelException.lhs | 6 ++- ghc/lib/std/PrelMain.lhs | 20 +++++++++- ghc/rts/HeapStackCheck.hc | 25 +++++++++++- ghc/rts/PrimOps.hc | 3 +- ghc/rts/RtsUtils.c | 9 ++--- ghc/rts/RtsUtils.h | 4 +- ghc/rts/Schedule.c | 21 +++++----- ghc/tests/concurrent/should_run/conc012.hs | 18 +++++++++ ghc/tests/concurrent/should_run/conc012.stdout | 1 + 11 files changed, 112 insertions(+), 47 deletions(-) create mode 100644 ghc/tests/concurrent/should_run/conc012.hs create mode 100644 ghc/tests/concurrent/should_run/conc012.stdout diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index fc09cb2..f48a311 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -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"); diff --git a/ghc/includes/Prelude.h b/ghc/includes/Prelude.h index f6d38a4..ac19a18 100644 --- a/ghc/includes/Prelude.h +++ b/ghc/includes/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 */ diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index 586d68e..7f9b54f 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $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" diff --git a/ghc/lib/std/PrelMain.lhs b/ghc/lib/std/PrelMain.lhs index 05aae47..764f201 100644 --- a/ghc/lib/std/PrelMain.lhs +++ b/ghc/lib/std/PrelMain.lhs @@ -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} diff --git a/ghc/rts/HeapStackCheck.hc b/ghc/rts/HeapStackCheck.hc index ff31c74..2861372 100644 --- a/ghc/rts/HeapStackCheck.hc +++ b/ghc/rts/HeapStackCheck.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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_ diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 76e76db..5f0837d 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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); diff --git a/ghc/rts/RtsUtils.c b/ghc/rts/RtsUtils.c index 081c205..aab8a38 100644 --- a/ghc/rts/RtsUtils.c +++ b/ghc/rts/RtsUtils.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 diff --git a/ghc/rts/RtsUtils.h b/ghc/rts/RtsUtils.h index 94693f2..8f4b2f6 100644 --- a/ghc/rts/RtsUtils.h +++ b/ghc/rts/RtsUtils.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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); diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 6e80db9..ffad52f 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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; } diff --git a/ghc/tests/concurrent/should_run/conc012.hs b/ghc/tests/concurrent/should_run/conc012.hs new file mode 100644 index 0000000..e9dd408 --- /dev/null +++ b/ghc/tests/concurrent/should_run/conc012.hs @@ -0,0 +1,18 @@ +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" diff --git a/ghc/tests/concurrent/should_run/conc012.stdout b/ghc/tests/concurrent/should_run/conc012.stdout new file mode 100644 index 0000000..12e0c90 --- /dev/null +++ b/ghc/tests/concurrent/should_run/conc012.stdout @@ -0,0 +1 @@ +Died: stack overflow -- 1.7.10.4