unboxedTriple = mkUnboxedTupleTy 3
unboxedQuadruple = mkUnboxedTupleTy 4
+mkIOTy ty = mkFunTy realWorldStatePrimTy
+ (unboxedPair [realWorldStatePrimTy,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
= 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
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
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
%
#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
*
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--;
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;
}
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);
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));
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.
* 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.
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
*
/* grab a thread from the run queue
*/
t = POP_RUN_QUEUE();
+ IF_DEBUG(sanity,checkTSO(t));
#endif
m->tso = new_t;
}
}
+ threadPaused(new_t);
ready_to_gc = rtsTrue;
context_switch = 1;
PUSH_ON_RUN_QUEUE(new_t);
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 */
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
*
}
-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_
projects / ghc-hetmet.git / commitdiff