Commit ca2ab438 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-01-30 10:25:27 by simonmar]

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.
parent 11a43a34
......@@ -886,6 +886,9 @@ unboxedPair = mkUnboxedTupleTy 2
unboxedTriple = mkUnboxedTupleTy 3
unboxedQuadruple = mkUnboxedTupleTy 4
mkIOTy ty = mkFunTy realWorldStatePrimTy
(unboxedPair [realWorldStatePrimTy,ty])
integerMonadic name = mkGenPrimOp name [] one_Integer_ty
(unboxedPair one_Integer_ty)
......@@ -1481,8 +1484,10 @@ primOpInfo SameMutVarOp
%* *
%************************************************************************
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
......@@ -1495,8 +1500,11 @@ primOpInfo CatchOp
= let
a = alphaTy; a_tv = alphaTyVar
b = betaTy; b_tv = betaTyVar;
io_a = mkIOTy a
in
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])
primOpInfo RaiseOp
= let
......@@ -1510,9 +1518,7 @@ primOpInfo BlockAsyncExceptionsOp
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
......@@ -1520,9 +1526,7 @@ primOpInfo UnblockAsyncExceptionsOp
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}
......
% -----------------------------------------------------------------------------
% $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
%
......@@ -96,22 +96,24 @@ throw exception = raise# exception
#endif
\end{code}
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 ())
Now catch# has type
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
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
......
/* -----------------------------------------------------------------------------
* $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
*
......@@ -52,9 +52,11 @@ FN_(blockAsyncExceptionszh_fast)
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--;
Sp[0] = (W_)&blockAsyncExceptionszh_ret_info;
Sp[0] = (W_)&unblockAsyncExceptionszh_ret_info;
}
}
Sp--;
......@@ -106,7 +108,9 @@ FN_(unblockAsyncExceptionszh_fast)
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;
}
......@@ -254,8 +258,10 @@ FN_(catchzh_fast)
StgCatchFrame *fp;
FB_
/* 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);
......@@ -264,6 +270,10 @@ FN_(catchzh_fast)
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));
......@@ -356,7 +366,7 @@ FN_(raisezh_fast)
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.
......@@ -366,7 +376,7 @@ FN_(raisezh_fast)
* 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.
......@@ -375,9 +385,12 @@ FN_(raisezh_fast)
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 = R1.w;
Sp -= 2;
Sp[0] = R1.w;
Sp[1] = ARG_TAG(0);
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
*
......@@ -597,6 +597,7 @@ schedule( void )
/* grab a thread from the run queue
*/
t = POP_RUN_QUEUE();
IF_DEBUG(sanity,checkTSO(t));
#endif
......@@ -704,6 +705,7 @@ schedule( void )
m->tso = new_t;
}
}
threadPaused(new_t);
ready_to_gc = rtsTrue;
context_switch = 1;
PUSH_ON_RUN_QUEUE(new_t);
......@@ -1598,6 +1600,7 @@ threadStackOverflow(StgTSO *tso)
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 */
......@@ -2159,25 +2162,27 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
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.
*/
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);
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[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
......
/* -----------------------------------------------------------------------------
* $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
*
......@@ -705,7 +705,7 @@ FN_(forceIO_ret_entry)
}
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);
FN_(forceIO_entry)
{
FB_
......
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