,'-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
*
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;
* 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
%
| 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"
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
*
FE_
}
+/* -----------------------------------------------------------------------------
+ Yields
+ -------------------------------------------------------------------------- */
+
FN_(stg_gen_yield)
{
FB_
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_
}
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
*
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
*
-------------------------------------------------------------------------- */
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
*
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
*
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
if (mvar->tail == tso) {
mvar->tail = last_tso;
}
- break;
+ goto done;
}
}
+ barf("unblockThread (MVAR): TSO not found");
}
case BLACKHOLE_BQ:
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);
}
/* -----------------------------------------------------------------------------
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;
}
--- /dev/null
+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"
--- /dev/null
+Died: stack overflow
projects / ghc-hetmet.git / commitdiff