From e1dc924bbb4efde0128e9dbeafa7580daada2706 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 1 Dec 1999 14:34:49 +0000 Subject: [PATCH] [project @ 1999-12-01 14:34:38 by simonmar] Support for blocking & unblocking asynchronous exceptions. - new primops: blockAsyncExceptions#, unblockAsyncExceptions# :: IO a -> IO a - raiseInThread will block if the target thread is currently blocking async exceptions. - async exceptions are currently implicitly blocked inside an exception handler. This decision might be reversed when we have more experience with this stuff. - Move exception-related stuff in the RTS into its own file, Exception.{h,hc}. --- ghc/compiler/prelude/PrimOp.lhs | 102 ++++++++---- ghc/includes/Closures.h | 3 +- ghc/includes/PrimOps.h | 12 +- ghc/includes/TSO.h | 42 +++-- ghc/lib/std/PrelGHC.hi-boot | 2 + ghc/rts/Exception.h | 11 ++ ghc/rts/Exception.hc | 348 +++++++++++++++++++++++++++++++++++++++ ghc/rts/PrimOps.hc | 39 +---- ghc/rts/Schedule.c | 53 +++++- ghc/rts/Updates.hc | 180 +------------------- 10 files changed, 516 insertions(+), 276 deletions(-) create mode 100644 ghc/rts/Exception.h create mode 100644 ghc/rts/Exception.hc diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 5535f97..ad858b2 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -173,6 +173,8 @@ data PrimOp -- exceptions | CatchOp | RaiseOp + | BlockAsyncExceptionsOp + | UnblockAsyncExceptionsOp -- foreign objects | MakeForeignObjOp @@ -560,8 +562,10 @@ tagOf_PrimOp WriteMutVarOp = ILIT(239) tagOf_PrimOp SameMutVarOp = ILIT(240) tagOf_PrimOp CatchOp = ILIT(241) tagOf_PrimOp RaiseOp = ILIT(242) -tagOf_PrimOp DataToTagOp = ILIT(243) -tagOf_PrimOp TagToEnumOp = ILIT(244) +tagOf_PrimOp BlockAsyncExceptionsOp = ILIT(243) +tagOf_PrimOp UnblockAsyncExceptionsOp = ILIT(244) +tagOf_PrimOp DataToTagOp = ILIT(245) +tagOf_PrimOp TagToEnumOp = ILIT(246) tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) --panic# "tagOf_PrimOp: pattern-match" @@ -793,6 +797,8 @@ allThePrimOps SameMutVarOp, CatchOp, RaiseOp, + BlockAsyncExceptionsOp, + UnblockAsyncExceptionsOp, NewMVarOp, TakeMVarOp, PutMVarOp, @@ -927,6 +933,8 @@ primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False) primOpStrictness CatchOp = ([wwLazy, wwLazy], False) primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom +primOpStrictness BlockAsyncExceptionsOp = ([wwLazy], False) +primOpStrictness UnblockAsyncExceptionsOp = ([wwLazy], False) primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False) primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False) @@ -1473,6 +1481,12 @@ primOpInfo SameMutVarOp catch :: IO a -> (IOError -> IO a) -> IO a catch# :: a -> (b -> a) -> a +throw :: Exception -> a +raise# :: a -> b + +blockAsyncExceptions# :: IO a -> IO a +unblockAsyncExceptions# :: IO a -> IO a + \begin{code} primOpInfo CatchOp = let @@ -1487,6 +1501,26 @@ primOpInfo RaiseOp b = betaTy; b_tv = betaTyVar; in mkGenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b + +primOpInfo BlockAsyncExceptionsOp + = let + a = alphaTy; a_tv = alphaTyVar + in + mkGenPrimOp SLIT("blockAsyncExceptions#") [a_tv] + [ mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,a]), + realWorldStatePrimTy + ] + (unboxedPair [realWorldStatePrimTy,a]) + +primOpInfo UnblockAsyncExceptionsOp + = let + a = alphaTy; a_tv = alphaTyVar + in + mkGenPrimOp SLIT("unblockAsyncExceptions#") [a_tv] + [ mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,a]), + realWorldStatePrimTy + ] + (unboxedPair [realWorldStatePrimTy,a]) \end{code} %************************************************************************ @@ -1927,37 +1961,39 @@ perform a heap check or they block. \begin{code} primOpOutOfLine op = case op of - TakeMVarOp -> True - PutMVarOp -> True - DelayOp -> True - WaitReadOp -> True - WaitWriteOp -> True - CatchOp -> True - RaiseOp -> True - NewArrayOp -> True - NewByteArrayOp _ -> True - IntegerAddOp -> True - IntegerSubOp -> True - IntegerMulOp -> True - IntegerGcdOp -> True - IntegerQuotRemOp -> True - IntegerDivModOp -> True - Int2IntegerOp -> True - Word2IntegerOp -> True - Addr2IntegerOp -> True - Word64ToIntegerOp -> True - Int64ToIntegerOp -> True - FloatDecodeOp -> True - DoubleDecodeOp -> True - MkWeakOp -> True - FinalizeWeakOp -> True - MakeStableNameOp -> True - MakeForeignObjOp -> True - NewMutVarOp -> True - NewMVarOp -> True - ForkOp -> True - KillThreadOp -> True - YieldOp -> True + TakeMVarOp -> True + PutMVarOp -> True + DelayOp -> True + WaitReadOp -> True + WaitWriteOp -> True + CatchOp -> True + RaiseOp -> True + BlockAsyncExceptionsOp -> True + UnblockAsyncExceptionsOp -> True + NewArrayOp -> True + NewByteArrayOp _ -> True + IntegerAddOp -> True + IntegerSubOp -> True + IntegerMulOp -> True + IntegerGcdOp -> True + IntegerQuotRemOp -> True + IntegerDivModOp -> True + Int2IntegerOp -> True + Word2IntegerOp -> True + Addr2IntegerOp -> True + Word64ToIntegerOp -> True + Int64ToIntegerOp -> True + FloatDecodeOp -> True + DoubleDecodeOp -> True + MkWeakOp -> True + FinalizeWeakOp -> True + MakeStableNameOp -> True + MakeForeignObjOp -> True + NewMutVarOp -> True + NewMVarOp -> True + ForkOp -> True + KillThreadOp -> True + YieldOp -> True CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_ -- the next one doesn't perform any heap checks, -- but it is of such an esoteric nature that diff --git a/ghc/includes/Closures.h b/ghc/includes/Closures.h index 541c6ad..3ed2809 100644 --- a/ghc/includes/Closures.h +++ b/ghc/includes/Closures.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: Closures.h,v 1.13 1999/05/11 16:47:40 keithw Exp $ + * $Id: Closures.h,v 1.14 1999/12/01 14:34:48 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -226,6 +226,7 @@ typedef struct { typedef struct { StgHeader header; struct _StgUpdateFrame *link; + StgInt exceptions_blocked; StgClosure *handler; } StgCatchFrame; diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 45cea3f..cad9a20 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.39 1999/11/09 10:05:07 sewardj Exp $ + * $Id: PrimOps.h,v 1.40 1999/12/01 14:34:48 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -703,19 +703,15 @@ EF_(makeStableNamezh_fast); #endif /* ----------------------------------------------------------------------------- - Parallel PrimOps. + Concurrency/Exception PrimOps. -------------------------------------------------------------------------- */ EF_(forkzh_fast); EF_(yieldzh_fast); EF_(killThreadzh_fast); EF_(seqzh_fast); -EF_(unblockExceptionszh_fast); - -#define blockExceptionszh_fast \ - if (CurrentTSO->pending_exceptions == NULL) { \ - CurrentTSO->pending_exceptions = &END_EXCEPTION_LIST_closure; \ - } +EF_(blockAsyncExceptionszh_fast); +EF_(unblockAsyncExceptionszh_fast); #define myThreadIdzh(t) (t = CurrentTSO) diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h index 2c53ab9..5cc34be 100644 --- a/ghc/includes/TSO.h +++ b/ghc/includes/TSO.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: TSO.h,v 1.8 1999/08/25 16:11:44 simonmar Exp $ + * $Id: TSO.h,v 1.9 1999/12/01 14:34:49 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -82,6 +82,7 @@ typedef enum { NotBlocked, BlockedOnMVar, BlockedOnBlackHole, + BlockedOnException, BlockedOnRead, BlockedOnWrite, BlockedOnDelay @@ -89,6 +90,7 @@ typedef enum { typedef union { StgClosure *closure; + struct StgTSO_ *tso; int fd; unsigned int delay; } StgTSOBlockInfo; @@ -106,6 +108,7 @@ typedef struct StgTSO_ { StgTSOWhatNext whatNext; StgTSOBlockReason why_blocked; StgTSOBlockInfo block_info; + struct StgTSO_* blocked_exceptions; StgThreadID id; StgTSOTickyInfo ticky; StgTSOProfInfo prof; @@ -122,8 +125,6 @@ typedef struct StgTSO_ { StgWord stack[0]; } StgTSO; -extern DLL_IMPORT_RTS StgTSO *CurrentTSO; - /* ----------------------------------------------------------------------------- Invariants: @@ -140,15 +141,22 @@ extern DLL_IMPORT_RTS StgTSO *CurrentTSO; (a) smaller than a block, or (b) a multiple of BLOCK_SIZE - tso->link - == END_TSO_QUEUE , iff the thread is currently running. - == (StgTSO *) , otherwise, and it is linked onto either: + tso->block_reason tso->block_info location + ---------------------------------------------------------------------- + NotBlocked NULL runnable_queue, or running + + BlockedOnBlackHole the BLACKHOLE_BQ the BLACKHOLE_BQ's queue + + BlockedOnMVar the MVAR the MVAR's queue + + BlockedOnException the TSO TSO->blocked_exception + + BlockedOnRead NULL blocked_queue + BlockedOnWrite NULL blocked_queue + BlockedOnDelay NULL blocked_queue + + tso->link == END_TSO_QUEUE, if the thread is currently running. - - the runnable_queue tso->blocked_on == END_TSO_QUEUE - - the blocked_queue tso->blocked_on == END_TSO_QUEUE - - a BLACKHOLE_BQ, tso->blocked_on == the BLACKHOLE_BQ - - an MVAR, tso->blocked_on == the MVAR - A zombie thread has the following properties: tso->whatNext == ThreadComplete or ThreadKilled @@ -161,7 +169,17 @@ extern DLL_IMPORT_RTS StgTSO *CurrentTSO; (tso->sp is left pointing at the top word on the stack so that the return value or exception will be retained by a GC). - ---------------------------------------------------------------------------- */ + tso->blocked_exceptions is either: + + NULL if async exceptions are unblocked. + + END_TSO_QUEUE if async exceptions are blocked, but no threads + are currently waiting to deliver. + + (StgTSO *)tso if threads are currently awaiting delivery of + exceptions to this thread. + + ---------------------------------------------------------------------------- */ /* Workaround for a bug/quirk in gcc on certain architectures. * symptom is that (&tso->stack - &tso->header) /= sizeof(StgTSO) diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index b4a8254..abeeabf 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -34,6 +34,8 @@ __export PrelGHC forkzh yieldzh killThreadzh + blockAsyncExceptionszh + unblockAsyncExceptionszh delayzh waitReadzh waitWritezh diff --git a/ghc/rts/Exception.h b/ghc/rts/Exception.h new file mode 100644 index 0000000..07203f9 --- /dev/null +++ b/ghc/rts/Exception.h @@ -0,0 +1,11 @@ +/* ----------------------------------------------------------------------------- + * $Id: Exception.h,v 1.1 1999/12/01 14:34:38 simonmar Exp $ + * + * (c) The GHC Team, 1998-1999 + * + * Exception support + * + * ---------------------------------------------------------------------------*/ + +extern const StgInfoTable blockAsyncExceptionszh_ret_info; +extern const StgInfoTable unblockAsyncExceptionszh_ret_info; diff --git a/ghc/rts/Exception.hc b/ghc/rts/Exception.hc new file mode 100644 index 0000000..10d380e --- /dev/null +++ b/ghc/rts/Exception.hc @@ -0,0 +1,348 @@ +/* ----------------------------------------------------------------------------- + * $Id: Exception.hc,v 1.1 1999/12/01 14:34:38 simonmar Exp $ + * + * (c) The GHC Team, 1998-1999 + * + * Exception support + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "Exception.h" +#include "Schedule.h" +#include "StgRun.h" +#include "Storage.h" +#include "RtsUtils.h" + +/* ----------------------------------------------------------------------------- + Exception Primitives + + A thread can request that asynchronous exceptions not be delivered + ("blocked") for the duration of an I/O computation. The primitive + + blockAsyncExceptions# :: IO a -> IO a + + is used for this purpose. During a blocked section, asynchronous + exceptions may be unblocked again temporarily: + + unblockAsyncExceptions# :: IO a -> IO a + + Furthermore, asynchronous exceptions are blocked automatically during + the execution of an exception handler. Both of these primitives + leave a continuation on the stack which reverts to the previous + state (blocked or unblocked) on exit. + + A thread which wants to raise an exception in another thread (using + killThread#) must block until the target thread is ready to receive + it. The action of unblocking exceptions in a thread will release all + the threads waiting to deliver exceptions to that thread. + + -------------------------------------------------------------------------- */ + +FN_(blockAsyncExceptionszh_fast) +{ + FB_ + /* Args: R1 :: IO a */ + STK_CHK_GEN( 2/* worst case */, R1_PTR, blockAsyncExceptionszh_fast, ); + + if (CurrentTSO->blocked_exceptions == NULL) { + CurrentTSO->blocked_exceptions = END_TSO_QUEUE; + Sp--; + Sp[0] = (W_)&unblockAsyncExceptionszh_ret_info; + } + Sp--; + Sp[0] = ARG_TAG(0); + JMP_(GET_ENTRY(R1.cl)); + FE_ +} + +INFO_TABLE_SRT_BITMAP(unblockAsyncExceptionszh_ret_info, unblockAsyncExceptionszh_ret_entry, 0, 0, 0, 0, RET_SMALL, , EF_, 0, 0); +FN_(unblockAsyncExceptionszh_ret_entry) +{ + FB_ + ASSERT(CurrentTSO->blocked_exceptions != NULL); + awakenBlockedQueue(CurrentTSO->blocked_exceptions); + CurrentTSO->blocked_exceptions = NULL; + Sp++; + JMP_(ENTRY_CODE(Sp[0])); + FE_ +} + +FN_(unblockAsyncExceptionszh_fast) +{ + FB_ + /* Args: R1 :: IO a */ + STK_CHK_GEN(2, R1_PTR, unblockAsyncExceptionszh_fast, ); + + if (CurrentTSO->blocked_exceptions != NULL) { + awakenBlockedQueue(CurrentTSO->blocked_exceptions); + CurrentTSO->blocked_exceptions = NULL; + Sp--; + Sp[0] = (W_)&blockAsyncExceptionszh_ret_info; + } + Sp--; + Sp[0] = ARG_TAG(0); + JMP_(GET_ENTRY(R1.cl)); + FE_ +} + +INFO_TABLE_SRT_BITMAP(blockAsyncExceptionszh_ret_info, blockAsyncExceptionszh_ret_entry, 0, 0, 0, 0, RET_SMALL, , EF_, 0, 0); +FN_(blockAsyncExceptionszh_ret_entry) +{ + FB_ + ASSERT(CurrentTSO->blocked_exceptions == NULL); + CurrentTSO->blocked_exceptions = END_TSO_QUEUE; + Sp++; + JMP_(ENTRY_CODE(Sp[0])); + FE_ +} + + +FN_(killThreadzh_fast) +{ + FB_ + /* args: R1.p = TSO to kill, R2.p = Exception */ + + /* If the target thread is currently blocking async exceptions, + * we'll have to block until it's ready to accept them. + */ + if (R1.t->blocked_exceptions != NULL) { + + /* ToDo (SMP): locking if destination thread is currently + * running... + */ + CurrentTSO->link = R1.t->blocked_exceptions; + R1.t->blocked_exceptions = CurrentTSO; + + CurrentTSO->why_blocked = BlockedOnException; + CurrentTSO->block_info.tso = R1.t; + + BLOCK( R1_PTR | R2_PTR, killThreadzh_fast ); + } + + /* Killed threads turn into zombies, which might be garbage + * collected at a later date. That's why we don't have to + * explicitly remove them from any queues they might be on. + */ + + /* We might have killed ourselves. In which case, better be *very* + * careful. If the exception killed us, then return to the scheduler. + * If the exception went to a catch frame, we'll just continue from + * the handler. + */ + if (R1.t == CurrentTSO) { + SaveThreadState(); /* inline! */ + STGCALL2(raiseAsync, R1.t, R2.cl); + if (CurrentTSO->whatNext == ThreadKilled) { + R1.w = ThreadYielding; + JMP_(StgReturn); + } + LoadThreadState(); + if (CurrentTSO->whatNext == ThreadEnterGHC) { + R1.w = Sp[0]; + Sp++; + JMP_(GET_ENTRY(R1.cl)); + } else { + barf("killThreadzh_fast"); + } + } else { + STGCALL2(raiseAsync, R1.t, R2.cl); + } + + JMP_(ENTRY_CODE(Sp[0])); + FE_ +} + +/* ----------------------------------------------------------------------------- + Catch frames + -------------------------------------------------------------------------- */ + +#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \ + FN_(label); \ + FN_(label) \ + { \ + FB_ \ + Su = ((StgCatchFrame *)Sp)->link; \ + Sp += sizeofW(StgCatchFrame); \ + JMP_(ret); \ + FE_ \ + } + +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_entry,ENTRY_CODE(Sp[0])); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_0_entry,RET_VEC(Sp[0],0)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_1_entry,RET_VEC(Sp[0],1)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_2_entry,RET_VEC(Sp[0],2)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_3_entry,RET_VEC(Sp[0],3)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_4_entry,RET_VEC(Sp[0],4)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_5_entry,RET_VEC(Sp[0],5)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_6_entry,RET_VEC(Sp[0],6)); +CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_7_entry,RET_VEC(Sp[0],7)); + +#ifdef PROFILING +#define CATCH_FRAME_BITMAP 7 +#else +#define CATCH_FRAME_BITMAP 3 +#endif + +/* Catch frames are very similar to update frames, but when entering + * one we just pop the frame off the stack and perform the correct + * kind of return to the activation record underneath us on the stack. + */ + +VEC_POLY_INFO_TABLE(catch_frame, CATCH_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_); + +/* ----------------------------------------------------------------------------- + * The catch infotable + * + * This should be exactly the same as would be generated by this STG code + * + * catch = {x,h} \n {} -> catch#{x,h} + * + * It is used in deleteThread when reverting blackholes. + * -------------------------------------------------------------------------- */ + +INFO_TABLE(catch_info,catch_entry,2,0,FUN,,EF_,0,0); +STGFUN(catch_entry) +{ + FB_ + R2.cl = payloadCPtr(R1.cl,1); /* h */ + R1.cl = payloadCPtr(R1.cl,0); /* x */ + JMP_(catchzh_fast); + FE_ +} + +FN_(catchzh_fast) +{ + StgCatchFrame *fp; + FB_ + + /* args: R1 = m, R2 = handler */ + STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchzh_fast, ); + Sp -= sizeofW(StgCatchFrame); + fp = (StgCatchFrame *)Sp; + SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS); + fp -> handler = R2.cl; + fp -> exceptions_blocked = (CurrentTSO->blocked_exceptions != NULL); + fp -> link = Su; + Su = (StgUpdateFrame *)fp; + TICK_CATCHF_PUSHED(); + TICK_ENT_VIA_NODE(); + JMP_(GET_ENTRY(R1.cl)); + + FE_ +} + +/* ----------------------------------------------------------------------------- + * The raise infotable + * + * This should be exactly the same as would be generated by this STG code + * + * raise = {err} \n {} -> raise#{err} + * + * It is used in raisezh_fast to update thunks on the update list + * -------------------------------------------------------------------------- */ + +INFO_TABLE(raise_info,raise_entry,1,0,FUN,,EF_,0,0); +STGFUN(raise_entry) +{ + FB_ + R1.cl = R1.cl->payload[0]; + JMP_(raisezh_fast); + FE_ +} + +FN_(raisezh_fast) +{ + StgClosure *handler; + StgUpdateFrame *p; + StgClosure *raise_closure; + FB_ + /* args : R1 = error */ + + +#if defined(PROFILING) + + /* Debugging tool: on raising an exception, show where we are. */ + + /* ToDo: currently this is a hack. Would be much better if + * the info was only displayed for an *uncaught* exception. + */ + if (RtsFlags.ProfFlags.showCCSOnException) { + STGCALL2(print_ccs,stderr,CCCS); + } + +#endif + + p = Su; + + /* This closure represents the expression 'raise# E' where E + * is the exception raise. It is used to overwrite all the + * thunks which are currently under evaluataion. + */ + raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate, + sizeofW(StgClosure)+1); + raise_closure->header.info = &raise_info; + raise_closure->payload[0] = R1.cl; + + while (1) { + + switch (get_itbl(p)->type) { + + case UPDATE_FRAME: + UPD_IND(p->updatee,raise_closure); + p = p->link; + continue; + + case SEQ_FRAME: + p = ((StgSeqFrame *)p)->link; + continue; + + case CATCH_FRAME: + /* found it! */ + break; + + case STOP_FRAME: + barf("raisezh_fast: STOP_FRAME"); + + default: + barf("raisezh_fast: weird activation record"); + } + + break; + + } + + /* Ok, p points to the enclosing CATCH_FRAME. Pop everything down to + * and including this frame, update Su, push R1, and enter the handler. + */ + Su = ((StgCatchFrame *)p)->link; + handler = ((StgCatchFrame *)p)->handler; + + Sp = (P_)p + sizeofW(StgCatchFrame) - 1; + + /* Restore the blocked/unblocked state for asynchronous exceptions + * at the CATCH_FRAME. + * + * If exceptions were unblocked, arrange that they are unblocked + * again after executing the handler by pushing an + * unblockAsyncExceptions_ret stack frame. + */ + if (! ((StgCatchFrame *)p)->exceptions_blocked) { + *(Sp--) = (W_)&unblockAsyncExceptionszh_ret_info; + } + + /* Ensure that async excpetions are blocked when running the handler. + */ + if (CurrentTSO->blocked_exceptions == NULL) { + CurrentTSO->blocked_exceptions = END_TSO_QUEUE; + } + + /* Enter the handler, passing the exception value as an argument. + */ + *Sp = R1.w; + TICK_ENT_VIA_NODE(); + R1.cl = handler; + JMP_(GET_ENTRY(R1.cl)); + + FE_ +} diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 39b4a74..e9ed855 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.34 1999/11/09 15:46:53 simonmar Exp $ + * $Id: PrimOps.hc,v 1.35 1999/12/01 14:34:38 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -806,43 +806,6 @@ FN_(yieldzh_fast) FE_ } -FN_(killThreadzh_fast) -{ - FB_ - /* args: R1.p = TSO to kill, R2.p = Exception */ - - /* The thread is dead, but the TSO sticks around for a while. That's why - * we don't have to explicitly remove it from any queues it might be on. - */ - - /* We might have killed ourselves. In which case, better be *very* - * careful. If the exception killed us, then return to the scheduler. - * If the exception went to a catch frame, we'll just continue from - * the handler. - */ - if (R1.t == CurrentTSO) { - SaveThreadState(); /* inline! */ - STGCALL2(raiseAsync, R1.t, R2.cl); - if (CurrentTSO->whatNext == ThreadKilled) { - R1.w = ThreadYielding; - JMP_(StgReturn); - } - LoadThreadState(); - if (CurrentTSO->whatNext == ThreadEnterGHC) { - R1.w = Sp[0]; - Sp++; - JMP_(GET_ENTRY(R1.cl)); - } else { - barf("killThreadzh_fast"); - } - } else { - STGCALL2(raiseAsync, R1.t, R2.cl); - } - - JMP_(ENTRY_CODE(Sp[0])); - FE_ -} - FN_(newMVarzh_fast) { StgMVar *mvar; diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 24f07bf..4d66a9b 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Schedule.c,v 1.35 1999/11/19 12:39:49 simonmar Exp $ + * $Id: Schedule.c,v 1.36 1999/12/01 14:34:40 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -40,6 +40,7 @@ #include "StgMiscClosures.h" #include "Storage.h" #include "Evaluator.h" +#include "Exception.h" #include "Printer.h" #include "Main.h" #include "Signals.h" @@ -983,6 +984,10 @@ void printThreadBlockage(StgTSO *tso) case BlockedOnMVar: fprintf(stderr,"blocked on an MVar"); break; + case BlockedOnException: + fprintf(stderr,"blocked on delivering an exception to thread %d", + tso->block_info.tso->id); + break; case BlockedOnBlackHole: fprintf(stderr,"blocked on a black hole"); break; @@ -1259,6 +1264,25 @@ unblockThread(StgTSO *tso) barf("unblockThread (BLACKHOLE): TSO not found"); } + case BlockedOnException: + { + StgTSO *tso = tso->block_info.tso; + + ASSERT(get_itbl(tso)->type == TSO); + ASSERT(tso->blocked_exceptions != NULL); + + last = &tso->blocked_exceptions; + for (t = tso->blocked_exceptions; t != END_TSO_QUEUE; + last = &t->link, t = t->link) { + ASSERT(get_itbl(t)->type == TSO); + if (t == tso) { + *last = tso->link; + goto done; + } + } + barf("unblockThread (Exception): TSO not found"); + } + case BlockedOnDelay: case BlockedOnRead: case BlockedOnWrite: @@ -1381,13 +1405,32 @@ raiseAsync(StgTSO *tso, StgClosure *exception) ap->fun = cf->handler; ap->payload[0] = (P_)exception; - /* sp currently points to the word above the CATCH_FRAME on the - * stack. Replace the CATCH_FRAME with a pointer to the new handler - * application. + /* sp currently points to the word above the CATCH_FRAME on the stack. */ sp += sizeofW(StgCatchFrame); - sp[0] = (W_)ap; tso->su = cf->link; + + /* Restore the blocked/unblocked state for asynchronous exceptions + * at the CATCH_FRAME. + * + * If exceptions were unblocked at the catch, arrange that they + * are unblocked again after executing the handler by pushing an + * unblockAsyncExceptions_ret stack frame. + */ + if (!cf->exceptions_blocked) { + *(sp--) = (W_)&unblockAsyncExceptionszh_ret_info; + } + + /* Ensure that async exceptions are blocked when running the handler. + */ + if (tso->blocked_exceptions == NULL) { + tso->blocked_exceptions = END_TSO_QUEUE; + } + + /* Put the newly-built PAP on top of the stack, ready to execute + * when the thread restarts. + */ + sp[0] = (W_)ap; tso->sp = sp; tso->whatNext = ThreadEnterGHC; return; diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc index c10b822..53f2476 100644 --- a/ghc/rts/Updates.hc +++ b/ghc/rts/Updates.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Updates.hc,v 1.23 1999/11/29 12:02:46 keithw Exp $ + * $Id: Updates.hc,v 1.24 1999/12/01 14:34:39 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -515,181 +515,3 @@ STGFUN(seq_entry) JMP_(ENTRY_CODE(*R1.p)); FE_ } - - -/* ----------------------------------------------------------------------------- - Exception Primitives - -------------------------------------------------------------------------- */ - -FN_(catchzh_fast); -FN_(raisezh_fast); - -#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \ - FN_(label); \ - FN_(label) \ - { \ - FB_ \ - Su = ((StgCatchFrame *)Sp)->link; \ - Sp += sizeofW(StgCatchFrame); \ - JMP_(ret); \ - FE_ \ - } - -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_entry,ENTRY_CODE(Sp[0])); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_0_entry,RET_VEC(Sp[0],0)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_1_entry,RET_VEC(Sp[0],1)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_2_entry,RET_VEC(Sp[0],2)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_3_entry,RET_VEC(Sp[0],3)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_4_entry,RET_VEC(Sp[0],4)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_5_entry,RET_VEC(Sp[0],5)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_6_entry,RET_VEC(Sp[0],6)); -CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_7_entry,RET_VEC(Sp[0],7)); - -#ifdef PROFILING -#define CATCH_FRAME_BITMAP 3 -#else -#define CATCH_FRAME_BITMAP 1 -#endif - -/* Catch frames are very similar to update frames, but when entering - * one we just pop the frame off the stack and perform the correct - * kind of return to the activation record underneath us on the stack. - */ - -VEC_POLY_INFO_TABLE(catch_frame, CATCH_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_); - -/* ----------------------------------------------------------------------------- - * The catch infotable - * - * This should be exactly the same as would be generated by this STG code - * - * catch = {x,h} \n {} -> catch#{x,h} - * - * It is used in deleteThread when reverting blackholes. - * -------------------------------------------------------------------------- */ - -INFO_TABLE(catch_info,catch_entry,2,0,FUN,,EF_,0,0); -STGFUN(catch_entry) -{ - FB_ - R2.cl = payloadCPtr(R1.cl,1); /* h */ - R1.cl = payloadCPtr(R1.cl,0); /* x */ - JMP_(catchzh_fast); - FE_ -} - -FN_(catchzh_fast) -{ - StgCatchFrame *fp; - FB_ - - /* args: R1 = m, R2 = k */ - STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchzh_fast, ); - Sp -= sizeofW(StgCatchFrame); - fp = (StgCatchFrame *)Sp; - SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS); - fp -> handler = R2.cl; - fp -> link = Su; - Su = (StgUpdateFrame *)fp; - TICK_CATCHF_PUSHED(); - TICK_ENT_VIA_NODE(); - JMP_(ENTRY_CODE(*R1.p)); - - FE_ -} - -/* ----------------------------------------------------------------------------- - * The raise infotable - * - * This should be exactly the same as would be generated by this STG code - * - * raise = {err} \n {} -> raise#{err} - * - * It is used in raisezh_fast to update thunks on the update list - * -------------------------------------------------------------------------- */ - -INFO_TABLE(raise_info,raise_entry,1,0,FUN,,EF_,0,0); -STGFUN(raise_entry) -{ - FB_ - R1.cl = R1.cl->payload[0]; - JMP_(raisezh_fast); - FE_ -} - -FN_(raisezh_fast) -{ - StgClosure *handler; - StgUpdateFrame *p; - StgClosure *raise_closure; - FB_ - /* args : R1 = error */ - -#if defined(PROFILING) - - /* Debugging tool: on raising an exception, show where we are. */ - - /* ToDo: currently this is a hack. Would be much better if - * the info was only displayed for an *uncaught* exception. - */ - if (RtsFlags.ProfFlags.showCCSOnException) { - STGCALL2(print_ccs,stderr,CCCS); - } - -#endif - - p = Su; - - /* This closure represents the expression 'raise# E' where E - * is the exception raise. It is used to overwrite all the - * thunks which are currently under evaluataion. - */ - raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate, - sizeofW(StgClosure)+1); - raise_closure->header.info = &raise_info; - raise_closure->payload[0] = R1.cl; - - while (1) { - - switch (get_itbl(p)->type) { - - case UPDATE_FRAME: - UPD_IND(p->updatee,raise_closure); - p = p->link; - continue; - - case SEQ_FRAME: - p = ((StgSeqFrame *)p)->link; - continue; - - case CATCH_FRAME: - /* found it! */ - break; - - case STOP_FRAME: - barf("raisezh_fast: STOP_FRAME"); - - default: - barf("raisezh_fast: weird activation record"); - } - - break; - - } - - /* Ok, p points to the enclosing CATCH_FRAME. Pop everything down to - * and including this frame, update Su, push R1, and enter the handler. - */ - Su = ((StgCatchFrame *)p)->link; - handler = ((StgCatchFrame *)p)->handler; - - Sp = (P_)p + sizeofW(StgCatchFrame) - 1; - *Sp = R1.w; - - TICK_ENT_VIA_NODE(); - R1.cl = handler; - JMP_(ENTRY_CODE(handler->header.info)); - - FE_ -} - -- 1.7.10.4