X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FException.cmm;h=581dafdf4f3e42b302064089f0c9be30e240cdde;hp=8ca397b95e8ebf3f3e9f6ef2433c65867514135f;hb=fff1f6194c3c39de53cd645bda9865fb131b1c68;hpb=24ce1351fb121d429375f411a8a95d619de921e1

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 8ca397b..581dafd 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -13,18 +13,20 @@
 #include "Cmm.h"
 #include "RaiseAsync.h"
 
+import ghczmprim_GHCziTypes_True_closure;
+
 /* -----------------------------------------------------------------------------
    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
+	maskAsyncExceptions# :: 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
+	unmaskAsyncExceptions# :: IO a -> IO a
 
    Furthermore, asynchronous exceptions are blocked automatically during
    the execution of an exception handler.  Both of these primitives
@@ -37,99 +39,209 @@
    the threads waiting to deliver exceptions to that thread.
 
    NB. there's a bug in here.  If a thread is inside an
-   unsafePerformIO, and inside blockAsyncExceptions# (there is an
-   unblockAsyncExceptions_ret on the stack), and it is blocked in an
+   unsafePerformIO, and inside maskAsyncExceptions# (there is an
+   unmaskAsyncExceptions_ret on the stack), and it is blocked in an
    interruptible operation, and it receives an exception, then the
    unsafePerformIO thunk will be updated with a stack object
-   containing the unblockAsyncExceptions_ret frame.  Later, when
+   containing the unmaskAsyncExceptions_ret frame.  Later, when
    someone else evaluates this thunk, the blocked exception state is
-   not restored, and the result is that unblockAsyncExceptions_ret
-   will attempt to unblock exceptions in the current thread, but it'll
-   find that the CurrentTSO->blocked_exceptions is NULL.  Hence, we
-   work around this by checking for NULL in awakenBlockedQueue().
+   not restored.
 
    -------------------------------------------------------------------------- */
 
-INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
- 		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+
+INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL)
 {
-    // Not true: see comments above
-    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+    CInt r;
+
+    StgTSO_flags(CurrentTSO) = %lobits32(
+      TO_W_(StgTSO_flags(CurrentTSO)) & ~(TSO_BLOCKEX|TSO_INTERRUPTIBLE));
+
+    /* Eagerly raise a blocked exception, if there is one */
+    if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
+
+        STK_CHK_GEN( WDS(2), R1_PTR, stg_unmaskAsyncExceptionszh_ret_info);
+        /* 
+         * We have to be very careful here, as in killThread#, since
+         * we are about to raise an async exception in the current
+         * thread, which might result in the thread being killed.
+         */
+        Sp_adj(-2);
+        Sp(1) = R1;
+        Sp(0) = stg_gc_unpt_r1_info;
+        SAVE_THREAD_STATE();
+        (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
+    					              CurrentTSO "ptr") [R1];
+
+        if (r != 0::CInt) {
+            if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+                jump stg_threadFinished;
+            } else {
+                LOAD_THREAD_STATE();
+                ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+                jump %ENTRY_CODE(Sp(0));
+            }
+        }
+        else {
+            /*
+               the thread might have been removed from the
+               blocked_exception list by someone else in the meantime.
+               Just restore the stack pointer and continue.  
+            */   
+            Sp_adj(2);
+        }
+    }
 
-    foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-					    CurrentTSO "ptr") [R1];
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(0));
+}
 
-    StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
-	~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
+INFO_TABLE_RET(stg_maskAsyncExceptionszh_ret, RET_SMALL)
+{
+    StgTSO_flags(CurrentTSO) = 
+       %lobits32(
+	 TO_W_(StgTSO_flags(CurrentTSO))
+          | TSO_BLOCKEX | TSO_INTERRUPTIBLE
+      );
 
-#ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));
-#else
-    Sp(1) = Sp(0);
-    Sp_adj(1);
-    jump %ENTRY_CODE(Sp(1));
-#endif
 }
 
-INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
-  		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET(stg_maskUninterruptiblezh_ret, RET_SMALL)
 {
-    // Not true: see comments above
-    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) == NULL);
-
     StgTSO_flags(CurrentTSO) = 
-	StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
+       %lobits32(
+	(TO_W_(StgTSO_flags(CurrentTSO))
+          | TSO_BLOCKEX)
+          & ~TSO_INTERRUPTIBLE
+       );
 
-#ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));
-#else
-    Sp(1) = Sp(0);
-    Sp_adj(1);
-    jump %ENTRY_CODE(Sp(1));
-#endif
 }
 
-blockAsyncExceptionszh_fast
+stg_maskAsyncExceptionszh
 {
     /* Args: R1 :: IO a */
-    STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
+    STK_CHK_GEN( WDS(1)/* worst case */, R1_PTR, stg_maskAsyncExceptionszh);
 
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
-	
-	StgTSO_flags(CurrentTSO) = 
-	   StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
+        /* avoid growing the stack unnecessarily */
+        if (Sp(0) == stg_maskAsyncExceptionszh_ret_info) {
+            Sp_adj(1);
+        } else {
+            Sp_adj(-1);
+            Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
+        }
+    } else {
+        if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_INTERRUPTIBLE) == 0) {
+            Sp_adj(-1);
+            Sp(0) = stg_maskUninterruptiblezh_ret_info;
+        }
+    }
 
-	/* avoid growing the stack unnecessarily */
-	if (Sp(0) == stg_blockAsyncExceptionszh_ret_info) {
-	    Sp_adj(1);
-	} else {
-	    Sp_adj(-1);
-	    Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
-	}
+    StgTSO_flags(CurrentTSO) = %lobits32(
+        TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+
+    TICK_UNKNOWN_CALL();
+    TICK_SLOW_CALL_v();
+    jump stg_ap_v_fast;
+}
+
+stg_maskUninterruptiblezh
+{
+    /* Args: R1 :: IO a */
+    STK_CHK_GEN( WDS(1)/* worst case */, R1_PTR, stg_maskAsyncExceptionszh);
+
+    if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
+        /* avoid growing the stack unnecessarily */
+        if (Sp(0) == stg_maskUninterruptiblezh_ret_info) {
+            Sp_adj(1);
+        } else {
+            Sp_adj(-1);
+            Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
+        }
+    } else {
+        if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_INTERRUPTIBLE) != 0) {
+            Sp_adj(-1);
+            Sp(0) = stg_maskAsyncExceptionszh_ret_info;
+        }
     }
+
+    StgTSO_flags(CurrentTSO) = %lobits32(
+        (TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX) & ~TSO_INTERRUPTIBLE);
+
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     jump stg_ap_v_fast;
 }
 
-unblockAsyncExceptionszh_fast
+stg_unmaskAsyncExceptionszh
 {
+    CInt r;
+    W_ level;
+
     /* Args: R1 :: IO a */
-    STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
+    STK_CHK_GEN( WDS(4), R1_PTR, stg_unmaskAsyncExceptionszh);
+    /* 4 words: one for the unblock frame, 3 for setting up the
+     * stack to call maybePerformBlockedException() below.
+     */
 
+    /* If exceptions are already unblocked, there's nothing to do */
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
-	foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-						CurrentTSO "ptr") [R1];
 
 	/* avoid growing the stack unnecessarily */
-	if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
+	if (Sp(0) == stg_unmaskAsyncExceptionszh_ret_info) {
 	    Sp_adj(1);
 	} else {
 	    Sp_adj(-1);
-	    Sp(0) = stg_blockAsyncExceptionszh_ret_info;
+            if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_INTERRUPTIBLE) != 0) {
+                Sp(0) = stg_maskAsyncExceptionszh_ret_info;
+            } else {
+                Sp(0) = stg_maskUninterruptiblezh_ret_info;
+            }
 	}
+
+	StgTSO_flags(CurrentTSO) = %lobits32(
+            TO_W_(StgTSO_flags(CurrentTSO)) & ~(TSO_BLOCKEX|TSO_INTERRUPTIBLE));
+
+        /* Eagerly raise a blocked exception, if there is one */
+        if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
+            /* 
+             * We have to be very careful here, as in killThread#, since
+             * we are about to raise an async exception in the current
+             * thread, which might result in the thread being killed.
+             *
+             * Now, if we are to raise an exception in the current
+             * thread, there might be an update frame above us on the
+             * stack due to unsafePerformIO.  Hence, the stack must
+             * make sense, because it is about to be snapshotted into
+             * an AP_STACK.
+             */
+            Sp_adj(-3);
+            Sp(2) = stg_ap_v_info;
+            Sp(1) = R1;
+            Sp(0) = stg_enter_info;
+
+            SAVE_THREAD_STATE();
+            (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
+						      CurrentTSO "ptr") [R1];
+
+            if (r != 0::CInt) {
+                if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+                    jump stg_threadFinished;
+	        } else {
+	            LOAD_THREAD_STATE();
+	            ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+	            jump %ENTRY_CODE(Sp(0));
+	        }
+            } else {
+                /* we'll just call R1 directly, below */
+                Sp_adj(3);
+            }
+        }
+
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
@@ -137,7 +249,19 @@ unblockAsyncExceptionszh_fast
 }
 
 
-killThreadzh_fast
+stg_getMaskingStatezh
+{
+    /* args: none */
+    /* 
+       returns: 0 == unmasked,
+                1 == masked, non-interruptible,
+                2 == masked, interruptible
+    */
+    RET_N(((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) +
+          ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_INTERRUPTIBLE) != 0));
+}
+
+stg_killThreadzh
 {
     /* args: R1 = TSO to kill, R2 = Exception */
 
@@ -148,7 +272,10 @@ killThreadzh_fast
     target = R1;
     exception = R2;
     
-    STK_CHK_GEN( WDS(3), R1_PTR & R2_PTR, killThreadzh_fast);
+    /* Needs 3 words because throwToSingleThreaded uses some stack */
+    STK_CHK_GEN( WDS(3), R1_PTR & R2_PTR, stg_killThreadzh);
+    /* We call allocate in throwTo(), so better check for GC */
+    MAYBE_GC(R1_PTR & R2_PTR, stg_killThreadzh);
 
     /* 
      * We might have killed ourselves.  In which case, better be *very*
@@ -156,14 +283,26 @@ killThreadzh_fast
      * If the exception went to a catch frame, we'll just continue from
      * the handler.
      */
+  loop:
+    if (StgTSO_what_next(target) == ThreadRelocated::I16) {
+        target = StgTSO__link(target);
+        goto loop;
+    }
     if (target == CurrentTSO) {
+        /*
+         * So what should happen if a thread calls "throwTo self" inside
+         * unsafePerformIO, and later the closure is evaluated by another
+         * thread?  Presumably it should behave as if throwTo just returned,
+         * and then continue from there.  See #3279, #3288.  This is what
+         * happens: on resumption, we will just jump to the next frame on
+         * the stack, which is the return point for stg_killThreadzh.
+         */
 	SAVE_THREAD_STATE();
 	/* ToDo: what if the current thread is blocking exceptions? */
 	foreign "C" throwToSingleThreaded(MyCapability() "ptr", 
 					  target "ptr", exception "ptr")[R1,R2];
 	if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
-	    R1 = ThreadFinished;
-	    jump StgReturn;
+            jump stg_threadFinished;
 	} else {
 	    LOAD_THREAD_STATE();
 	    ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
@@ -171,27 +310,22 @@ killThreadzh_fast
 	}
     } else {
 	W_ out;
-	W_ retcode;
-	out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w;
-	
-	retcode = foreign "C" throwTo(MyCapability() "ptr",
-				      CurrentTSO "ptr",
-				      target "ptr",
-				      exception "ptr",
-				      out "ptr") [R1,R2];
-	
-	switch [THROWTO_SUCCESS .. THROWTO_BLOCKED] (retcode) {
+	W_ msg;
+	out = Sp - WDS(1); /* ok to re-use stack space here */
 
-	case THROWTO_SUCCESS: {
+	(msg) = foreign "C" throwTo(MyCapability() "ptr",
+                                    CurrentTSO "ptr",
+                                    target "ptr",
+                                    exception "ptr") [R1,R2];
+	
+        if (msg == NULL) {
 	    jump %ENTRY_CODE(Sp(0));
-	}
-
-	case THROWTO_BLOCKED: {
-	    R3 = W_[out];
-	    // we must block, and call throwToReleaseTarget() before returning
+	} else {
+            StgTSO_why_blocked(CurrentTSO) = BlockedOnMsgThrowTo;
+            StgTSO_block_info(CurrentTSO) = msg;
+	    // we must block, and unlock the message before returning
 	    jump stg_block_throwto;
 	}
-	}
     }
 }
 
@@ -199,69 +333,22 @@ killThreadzh_fast
    Catch frames
    -------------------------------------------------------------------------- */
 
-#ifdef REG_R1
-#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) 	\
-   label					\
-   {						\
-      Sp = Sp + SIZEOF_StgCatchFrame; 		\
-      jump ret;					\
-   }
-#else
-#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) 	\
-   label					\
-   {						\
-      W_ rval;					\
-      rval = Sp(0);				\
-      Sp = Sp + SIZEOF_StgCatchFrame;		\
-      Sp(0) = rval;				\
-      jump ret;					\
-   }
-#endif
-
-#ifdef REG_R1
 #define SP_OFF 0
-#else
-#define SP_OFF 1
-#endif
-
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
-
-#if MAX_VECTORED_RTN > 8
-#error MAX_VECTORED_RTN has changed: please modify stg_catch_frame too.
-#endif
-
-#if defined(PROFILING)
-#define CATCH_FRAME_BITMAP 7
-#define CATCH_FRAME_WORDS  4
-#else
-#define CATCH_FRAME_BITMAP 1
-#define CATCH_FRAME_WORDS  2
-#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.
  */
 
-INFO_TABLE_RET(stg_catch_frame,
-	       CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
-	       CATCH_FRAME,
-	       stg_catch_frame_0_ret,
-	       stg_catch_frame_1_ret,
-	       stg_catch_frame_2_ret,
-	       stg_catch_frame_3_ret,
-	       stg_catch_frame_4_ret,
-	       stg_catch_frame_5_ret,
-	       stg_catch_frame_6_ret,
-	       stg_catch_frame_7_ret)
-CATCH_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
+INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
+#if defined(PROFILING)
+  W_ unused1, W_ unused2,
+#endif
+  W_ unused3, P_ unused4)
+   {
+      Sp = Sp + SIZEOF_StgCatchFrame;
+      jump %ENTRY_CODE(Sp(SP_OFF));
+   }
 
 /* -----------------------------------------------------------------------------
  * The catch infotable
@@ -277,20 +364,21 @@ INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
 {
   R2 = StgClosure_payload(R1,1); /* h */
   R1 = StgClosure_payload(R1,0); /* x */
-  jump catchzh_fast;
+  jump stg_catchzh;
 }
 
-catchzh_fast
+stg_catchzh
 {
     /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
-    STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, catchzh_fast);
+    STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, stg_catchzh);
   
     /* Set up the catch frame */
     Sp = Sp - SIZEOF_StgCatchFrame;
     SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
     
     StgCatchFrame_handler(Sp) = R2;
-    StgCatchFrame_exceptions_blocked(Sp) = TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX;
+    StgCatchFrame_exceptions_blocked(Sp) = 
+        TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE);
     TICK_CATCHF_PUSHED();
 
     /* Apply R1 to the realworld token */
@@ -306,22 +394,35 @@ catchzh_fast
  *
  *   raise = {err} \n {} -> raise#{err}
  *
- * It is used in raisezh_fast to update thunks on the update list
+ * It is used in stg_raisezh to update thunks on the update list
  * -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
 {
   R1 = StgThunk_payload(R1,0);
-  jump raisezh_fast;
+  jump stg_raisezh;
+}
+
+section "data" {
+  no_break_on_exception: W_[1];
 }
 
-raisezh_fast
+INFO_TABLE_RET(stg_raise_ret, RET_SMALL, P_ arg1)
+{
+  R1 = Sp(1);
+  Sp = Sp + WDS(2);
+  W_[no_break_on_exception] = 1;  
+  jump stg_raisezh;
+}
+
+stg_raisezh
 {
     W_ handler;
-    W_ raise_closure;
     W_ frame_type;
+    W_ exception;
     /* args : R1 :: Exception */
 
+   exception = R1;
 
 #if defined(PROFILING)
     /* Debugging tool: on raising an  exception, show where we are. */
@@ -330,23 +431,36 @@ raisezh_fast
      * the info was only displayed for an *uncaught* exception.
      */
     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
-      foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
+      foreign "C" fprintCCS_stderr(W_[CCCS] "ptr") [];
     }
 #endif
-
+    
 retry_pop_stack:
     StgTSO_sp(CurrentTSO) = Sp;
-    frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", R1 "ptr");
+    (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
     Sp = StgTSO_sp(CurrentTSO);
     if (frame_type == ATOMICALLY_FRAME) {
       /* The exception has reached the edge of a memory transaction.  Check that 
        * the transaction is valid.  If not then perhaps the exception should
-       * not have been thrown: re-run the transaction */
-      W_ trec;
+       * not have been thrown: re-run the transaction.  "trec" will either be
+       * a top-level transaction running the atomic block, or a nested 
+       * transaction running an invariant check.  In the latter case we
+       * abort and de-allocate the top-level transaction that encloses it
+       * as well (we could just abandon its transaction record, but this makes
+       * sure it's marked as aborted and available for re-use). */
+      W_ trec, outer;
       W_ r;
       trec = StgTSO_trec(CurrentTSO);
-      r = foreign "C" stmValidateNestOfTransactions(trec "ptr");
-      foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+      (r) = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
+      outer  = StgTRecHeader_enclosing_trec(trec);
+      foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
+      foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
+
+      if (outer != NO_TREC) {
+        foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr") [];
+        foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr") [];
+      }
+
       StgTSO_trec(CurrentTSO) = NO_TREC;
       if (r != 0) {
         // Transaction was valid: continue searching for a catch frame
@@ -355,13 +469,42 @@ retry_pop_stack:
       } else {
         // Transaction was not valid: we retry the exception (otherwise continue
         // with a further call to raiseExceptionHelper)
-        "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
+        ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
         StgTSO_trec(CurrentTSO) = trec;
         R1 = StgAtomicallyFrame_code(Sp);
         jump stg_ap_v_fast;
       }          
     }
 
+    // After stripping the stack, see whether we should break here for
+    // GHCi (c.f. the -fbreak-on-exception flag).  We do this after
+    // stripping the stack for a reason: we'll be inspecting values in
+    // GHCi, and it helps if all the thunks under evaluation have
+    // already been updated with the exception, rather than being left
+    // as blackholes.
+    if (W_[no_break_on_exception] != 0) {
+        W_[no_break_on_exception] = 0;
+    } else {
+        if (TO_W_(CInt[rts_stop_on_exception]) != 0) {
+            W_ ioAction;
+            // we don't want any further exceptions to be caught,
+            // until GHCi is ready to handle them.  This prevents
+            // deadlock if an exception is raised in InteractiveUI,
+            // for exmplae.  Perhaps the stop_on_exception flag should
+            // be per-thread.
+            CInt[rts_stop_on_exception] = 0;
+            ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
+            Sp = Sp - WDS(6);
+            Sp(5) = exception;
+            Sp(4) = stg_raise_ret_info;
+            Sp(3) = exception;             // the AP_STACK
+            Sp(2) = ghczmprim_GHCziTypes_True_closure; // dummy breakpoint info
+            Sp(1) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint
+            R1 = ioAction;
+            jump RET_LBL(stg_ap_pppv);
+        }
+    }
+
     if (frame_type == STOP_FRAME) {
 	/*
 	 * We've stripped the entire stack, the thread is now dead.
@@ -370,16 +513,12 @@ retry_pop_stack:
 	 */
 	Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
 		+ WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
-	Sp(1) = R1;		/* save the exception */
+	Sp(1) = exception;	/* save the exception */
 	Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
 	StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
 	SAVE_THREAD_STATE();	/* inline! */
 
-	/* The return code goes in BaseReg->rRet, and BaseReg is returned in R1 */
-	StgRegTable_rRet(BaseReg) = ThreadFinished;
-	R1 = BaseReg;
-
-	jump StgReturn;
+        jump stg_threadFinished;
     }
 
     /* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME.  Pop everything
@@ -396,30 +535,48 @@ retry_pop_stack:
      *
      * If exceptions were unblocked, arrange that they are unblocked
      * again after executing the handler by pushing an
-     * unblockAsyncExceptions_ret stack frame.
+     * unmaskAsyncExceptions_ret stack frame.
+     *
+     * If we've reached an STM catch frame then roll back the nested
+     * transaction we were using.
      */
     W_ frame;
     frame = Sp;
     if (frame_type == CATCH_FRAME) {
       Sp = Sp + SIZEOF_StgCatchFrame;
-      if (StgCatchFrame_exceptions_blocked(frame) == 0) {
-        Sp_adj(-1);
-        Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+      if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) {
+          Sp_adj(-1);
+          Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
       }
     } else {
+      W_ trec, outer;
+      trec = StgTSO_trec(CurrentTSO);
+      outer  = StgTRecHeader_enclosing_trec(trec);
+      foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
+      foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
+      StgTSO_trec(CurrentTSO) = outer;
       Sp = Sp + SIZEOF_StgCatchSTMFrame;
     }
 
     /* Ensure that async excpetions are blocked when running the handler.
+     * The interruptible state is inherited from the context of the
+     * catch frame.
     */
-    StgTSO_flags(CurrentTSO) = 
-	StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
+    StgTSO_flags(CurrentTSO) = %lobits32(
+	TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX);
+    if ((StgCatchFrame_exceptions_blocked(frame) & TSO_INTERRUPTIBLE) == 0) {
+        StgTSO_flags(CurrentTSO) = %lobits32(
+            TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE);
+    } else {
+        StgTSO_flags(CurrentTSO) = %lobits32(
+            TO_W_(StgTSO_flags(CurrentTSO)) | TSO_INTERRUPTIBLE);
+    }
 
     /* Call the handler, passing the exception value and a realworld
      * token as arguments.
      */
     Sp_adj(-1);
-    Sp(0) = R1;
+    Sp(0) = exception;
     R1 = handler;
     Sp_adj(-1);
     TICK_UNKNOWN_CALL();
@@ -427,8 +584,8 @@ retry_pop_stack:
     jump RET_LBL(stg_ap_pv);
 }
 
-raiseIOzh_fast
+stg_raiseIOzh
 {
   /* Args :: R1 :: Exception */
-  jump raisezh_fast;
+  jump stg_raisezh;
 }