Change the type of catch# to
catch# :: (W# -> (# W#, a #))
-> (b -> W# -> (# W#, a #))
-> W# -> (# W# , a #)
where W# == State# RealWorld. In other words, make it explicit that
catch# is an IO operation and takes IO operations as arguments. The
previous type was too general, and resulted in catch# having the wrong
arity which could cause mis-optimisations.
The down side is that we now have to pass the state token around
inside the primop instead of doing it in the Haskell wrapper, and
raiseAsync() also has to build a PAP(handler,exception,realworld)
instead of just a PAP(handler,exception) when it invokes a handler as
a result of an async exception.
I also added some optimisations to (un)?blockAsyncException to not
grow the stack if it can be avoided, such as when we're about to block
async exceptions and there's a blockAsyncExceptions_ret stack frame on
the top of the stack.
unboxedTriple = mkUnboxedTupleTy 3
unboxedQuadruple = mkUnboxedTupleTy 4
unboxedTriple = mkUnboxedTupleTy 3
unboxedQuadruple = mkUnboxedTupleTy 4
+mkIOTy ty = mkFunTy realWorldStatePrimTy
+ (unboxedPair [realWorldStatePrimTy,ty])
+
integerMonadic name = mkGenPrimOp name [] one_Integer_ty
(unboxedPair one_Integer_ty)
integerMonadic name = mkGenPrimOp name [] one_Integer_ty
(unboxedPair one_Integer_ty)
%* *
%************************************************************************
%* *
%************************************************************************
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch# :: a -> (b -> a) -> a
+catch# :: (State# RealWorld -> (# State# RealWorld, a))
+ -> (b -> State# RealWorld -> (# State# RealWorld, a))
+ -> State# RealWorld
+ -> (# State# RealWorld, a)
throw :: Exception -> a
raise# :: a -> b
throw :: Exception -> a
raise# :: a -> b
= let
a = alphaTy; a_tv = alphaTyVar
b = betaTy; b_tv = betaTyVar;
= let
a = alphaTy; a_tv = alphaTyVar
b = betaTy; b_tv = betaTyVar;
- mkGenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
+ mkGenPrimOp SLIT("catch#") [a_tv, b_tv]
+ [io_a, mkFunTy b io_a, realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy, a])
a = alphaTy; a_tv = alphaTyVar
in
mkGenPrimOp SLIT("blockAsyncExceptions#") [a_tv]
a = alphaTy; a_tv = alphaTyVar
in
mkGenPrimOp SLIT("blockAsyncExceptions#") [a_tv]
- [ mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,a]),
- realWorldStatePrimTy
- ]
+ [ mkIOTy a, realWorldStatePrimTy ]
(unboxedPair [realWorldStatePrimTy,a])
primOpInfo UnblockAsyncExceptionsOp
(unboxedPair [realWorldStatePrimTy,a])
primOpInfo UnblockAsyncExceptionsOp
a = alphaTy; a_tv = alphaTyVar
in
mkGenPrimOp SLIT("unblockAsyncExceptions#") [a_tv]
a = alphaTy; a_tv = alphaTyVar
in
mkGenPrimOp SLIT("unblockAsyncExceptions#") [a_tv]
- [ mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,a]),
- realWorldStatePrimTy
- ]
+ [ mkIOTy a, realWorldStatePrimTy ]
(unboxedPair [realWorldStatePrimTy,a])
\end{code}
(unboxedPair [realWorldStatePrimTy,a])
\end{code}
% -----------------------------------------------------------------------------
% -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.10 1999/11/11 15:20:29 simonmar Exp $
+% $Id: PrelException.lhs,v 1.11 2000/01/30 10:25:28 simonmar Exp $
%
% (c) The GRAP/AQUA Project, Glasgow University, 1998
%
%
% (c) The GRAP/AQUA Project, Glasgow University, 1998
%
-catch handles the passing around of the state in the IO monad; if we
-don't actually apply (and hence run) an IO computation, we don't get
-any exceptions! Hence a large mantrap to watch out for is
+catchException used to handle the passing around of the state to the
+action and the handler. This turned out to be a bad idea - it meant
+that we had to wrap both arguments in thunks so they could be entered
+as normal (remember IO returns an unboxed pair...).
- catch# (m :: IO ()) (handler :: NDSet Exception -> IO ())
-since the computation 'm' won't actually be performed in the context
-of the 'catch#'. In fact, don't use catch# at all.
+ catch# :: IO a -> (b -> IO a) -> IO a
+
+(well almost; the compiler doesn't know about the IO newtype so we
+have to work around that in the definition of catchException below).
\begin{code}
catchException :: IO a -> (Exception -> IO a) -> IO a
#ifdef __HUGS__
catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
#else
\begin{code}
catchException :: IO a -> (Exception -> IO a) -> IO a
#ifdef __HUGS__
catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
#else
-catchException m k = IO $ \s -> case catch# (liftIO m s) (\exs -> liftIO (k exs) s)
- of STret s1 r -> (# s1, r #)
+catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
#endif
catch :: IO a -> (IOError -> IO a) -> IO a
#endif
catch :: IO a -> (IOError -> IO a) -> IO a
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.5 2000/01/22 18:00:03 simonmar Exp $
+ * $Id: Exception.hc,v 1.6 2000/01/30 10:25:28 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* (c) The GHC Team, 1998-1999
*
if (CurrentTSO->blocked_exceptions == NULL) {
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
/* avoid growing the stack unnecessarily */
if (CurrentTSO->blocked_exceptions == NULL) {
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
/* avoid growing the stack unnecessarily */
- if (Sp[0] != (W_)&blockAsyncExceptionszh_ret_info) {
+ if (Sp[0] == (W_)&blockAsyncExceptionszh_ret_info) {
+ Sp++;
+ } else {
- Sp[0] = (W_)&blockAsyncExceptionszh_ret_info;
+ Sp[0] = (W_)&unblockAsyncExceptionszh_ret_info;
CurrentTSO->blocked_exceptions = NULL;
/* avoid growing the stack unnecessarily */
CurrentTSO->blocked_exceptions = NULL;
/* avoid growing the stack unnecessarily */
- if (Sp[0] != (W_)&blockAsyncExceptionszh_ret_info) {
+ if (Sp[0] == (W_)&unblockAsyncExceptionszh_ret_info) {
+ Sp++;
+ } else {
Sp--;
Sp[0] = (W_)&blockAsyncExceptionszh_ret_info;
}
Sp--;
Sp[0] = (W_)&blockAsyncExceptionszh_ret_info;
}
- /* args: R1 = m, R2 = handler */
- STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchzh_fast, );
+ /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
+ STK_CHK_GEN(sizeofW(StgCatchFrame) + 1, R1_PTR | R2_PTR, catchzh_fast, );
+
+ /* Set up the catch frame */
Sp -= sizeofW(StgCatchFrame);
fp = (StgCatchFrame *)Sp;
SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS);
Sp -= sizeofW(StgCatchFrame);
fp = (StgCatchFrame *)Sp;
SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS);
fp -> link = Su;
Su = (StgUpdateFrame *)fp;
TICK_CATCHF_PUSHED();
fp -> link = Su;
Su = (StgUpdateFrame *)fp;
TICK_CATCHF_PUSHED();
+
+ /* Push realworld token and enter R1. */
+ Sp--;
+ Sp[0] = ARG_TAG(0);
TICK_ENT_VIA_NODE();
JMP_(GET_ENTRY(R1.cl));
TICK_ENT_VIA_NODE();
JMP_(GET_ENTRY(R1.cl));
Su = ((StgCatchFrame *)p)->link;
handler = ((StgCatchFrame *)p)->handler;
Su = ((StgCatchFrame *)p)->link;
handler = ((StgCatchFrame *)p)->handler;
- Sp = (P_)p + sizeofW(StgCatchFrame) - 1;
+ Sp = (P_)p + sizeofW(StgCatchFrame);
/* Restore the blocked/unblocked state for asynchronous exceptions
* at the CATCH_FRAME.
/* Restore the blocked/unblocked state for asynchronous exceptions
* at the CATCH_FRAME.
* unblockAsyncExceptions_ret stack frame.
*/
if (! ((StgCatchFrame *)p)->exceptions_blocked) {
* unblockAsyncExceptions_ret stack frame.
*/
if (! ((StgCatchFrame *)p)->exceptions_blocked) {
- *(Sp--) = (W_)&unblockAsyncExceptionszh_ret_info;
+ *(--Sp) = (W_)&unblockAsyncExceptionszh_ret_info;
}
/* Ensure that async excpetions are blocked when running the handler.
}
/* Ensure that async excpetions are blocked when running the handler.
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
}
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
}
- /* Enter the handler, passing the exception value as an argument.
+ /* Enter the handler, passing the exception value and a realworld
+ * token as arguments.
+ Sp -= 2;
+ Sp[0] = R1.w;
+ Sp[1] = ARG_TAG(0);
TICK_ENT_VIA_NODE();
R1.cl = handler;
JMP_(GET_ENTRY(R1.cl));
TICK_ENT_VIA_NODE();
R1.cl = handler;
JMP_(GET_ENTRY(R1.cl));
/* ---------------------------------------------------------------------------
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.45 2000/01/22 18:00:03 simonmar Exp $
+ * $Id: Schedule.c,v 1.46 2000/01/30 10:25:29 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* (c) The GHC Team, 1998-1999
*
/* grab a thread from the run queue
*/
t = POP_RUN_QUEUE();
/* grab a thread from the run queue
*/
t = POP_RUN_QUEUE();
+ IF_DEBUG(sanity,checkTSO(t));
ready_to_gc = rtsTrue;
context_switch = 1;
PUSH_ON_RUN_QUEUE(new_t);
ready_to_gc = rtsTrue;
context_switch = 1;
PUSH_ON_RUN_QUEUE(new_t);
StgPtr new_sp;
StgTSO *dest;
StgPtr new_sp;
StgTSO *dest;
+ IF_DEBUG(sanity,checkTSO(tso));
if (tso->stack_size >= tso->max_stack_size) {
#if 0
/* If we're debugging, just print out the top of the stack */
if (tso->stack_size >= tso->max_stack_size) {
#if 0
/* If we're debugging, just print out the top of the stack */
StgAP_UPD * ap;
/* If we find a CATCH_FRAME, and we've got an exception to raise,
StgAP_UPD * ap;
/* If we find a CATCH_FRAME, and we've got an exception to raise,
- * then build PAP(handler,exception), and leave it on top of
- * the stack ready to enter.
+ * then build PAP(handler,exception,realworld#), and leave it on
+ * top of the stack ready to enter.
*/
if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
StgCatchFrame *cf = (StgCatchFrame *)su;
/* we've got an exception to raise, so let's pass it to the
* handler in this frame.
*/
*/
if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
StgCatchFrame *cf = (StgCatchFrame *)su;
/* we've got an exception to raise, so let's pass it to the
* handler in this frame.
*/
- ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
- TICK_ALLOC_UPD_PAP(2,0);
+ ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 2);
+ TICK_ALLOC_UPD_PAP(3,0);
SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
- ap->n_args = 1;
- ap->fun = cf->handler;
+ ap->n_args = 2;
+ ap->fun = cf->handler; /* :: Exception -> IO a */
ap->payload[0] = (P_)exception;
ap->payload[0] = (P_)exception;
+ ap->payload[1] = ARG_TAG(0); /* realworld token */
- /* sp currently points to the word above the CATCH_FRAME on the stack.
+ /* throw away the stack from Sp up to and including the
+ * CATCH_FRAME.
- sp += sizeofW(StgCatchFrame);
+ sp = (P_)su + sizeofW(StgCatchFrame) - 1;
tso->su = cf->link;
/* Restore the blocked/unblocked state for asynchronous exceptions
tso->su = cf->link;
/* Restore the blocked/unblocked state for asynchronous exceptions
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.33 2000/01/14 13:22:21 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.34 2000/01/30 10:25:29 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* (c) The GHC Team, 1998-1999
*
-INFO_TABLE(forceIO_info,forceIO_entry,1,0,FUN,,EF_,0,0);
+INFO_TABLE(forceIO_info,forceIO_entry,1,0,FUN_STATIC,,EF_,0,0);