From ca2ab438fbdbc163db46592879146df96dd03cd9 Mon Sep 17 00:00:00 2001 From: simonmar Date: Sun, 30 Jan 2000 10:25:29 +0000 Subject: [PATCH] [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. --- ghc/compiler/prelude/PrimOp.lhs | 22 +++++++++++++--------- ghc/lib/std/PrelException.lhs | 20 +++++++++++--------- ghc/rts/Exception.hc | 33 +++++++++++++++++++++++---------- ghc/rts/Schedule.c | 23 ++++++++++++++--------- ghc/rts/StgMiscClosures.hc | 4 ++-- 5 files changed, 63 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 13fc502..c514f02 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -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} diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index bed83d7..0a548df 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $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 diff --git a/ghc/rts/Exception.hc b/ghc/rts/Exception.hc index ce7ba7a..56eeb87 100644 --- a/ghc/rts/Exception.hc +++ b/ghc/rts/Exception.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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)); diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 88a66d8..2501608 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $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 diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index f8bece0..645a442 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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_ -- 1.7.10.4