don't make -ddump-if-trace imply -no-recomp

[ghc-hetmet.git] / rts / Exception.cmm

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index b5c2962..75f2c15 100644 (file)
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -11,6 +11,9 @@
  * ---------------------------------------------------------------------------*/
 
 #include "Cmm.h"
  * ---------------------------------------------------------------------------*/
 
 #include "Cmm.h"

+#include "RaiseAsync.h"
+
+import ghczmprim_GHCziBool_True_closure;

 
 /* -----------------------------------------------------------------------------
    Exception Primitives
 
 /* -----------------------------------------------------------------------------
    Exception Primitives

@@ -42,25 +45,66 @@
    unsafePerformIO thunk will be updated with a stack object
    containing the unblockAsyncExceptions_ret frame.  Later, when
    someone else evaluates this thunk, the blocked exception state is
    unsafePerformIO thunk will be updated with a stack object
    containing the unblockAsyncExceptions_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_unblockAsyncExceptionszh_ret, RET_SMALL )

 {
 {

-    // Not true: see comments above
-    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
-#if defined(GRAN) || defined(PAR)
-    foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr", 
-                                  NULL "ptr"); 
+    CInt r;
+
+    StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
+       ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
+
+    /* 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.
+         */
+
+#ifndef REG_R1
+        /*
+         * raiseAsync assumes that the stack is in ThreadRunGHC state,
+         * i.e. with a return address on the top.  In unreg mode, the
+         * return value for IO is on top of the return address, so we
+         * need to make a small adjustment here.
+         */
+        Sp_adj(1);
+#endif
+        STK_CHK_GEN( WDS(2), R1_PTR, stg_unblockAsyncExceptionszh_ret_info);
+        Sp_adj(-2);
+        Sp(1) = R1;
+#ifdef REG_R1
+        Sp(0) = stg_gc_unpt_r1_info;

 #else
 #else

-    foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr");
+        Sp(0) = stg_ut_1_0_unreg_info;

 #endif
 #endif

-    StgTSO_blocked_exceptions(CurrentTSO) = NULL;
+        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));
+            }
+        }
+#ifndef REG_R1
+        /* 
+         * Readjust stack in unregisterised mode if we didn't raise an
+         * exception, see above
+         */
+        else {
+            Sp_adj(-1);
+        }
+#endif
+    }
+

 #ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));
 #ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));

@@ -71,12 +115,11 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
 #endif
 }
 
 #endif
 }
 

-INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
-               0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, RET_SMALL )

 {
 {

-    // Not true: see comments above
-    // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) == NULL);
-    StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+    StgTSO_flags(CurrentTSO) = 
+       StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
+

 #ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));
 #ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));

@@ -92,15 +135,18 @@ blockAsyncExceptionszh_fast
     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
 
     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
 

-    if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
-      StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
-      /* 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;
-      }
+    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_blockAsyncExceptionszh_ret_info) {
+           Sp_adj(1);
+       } else {
+           Sp_adj(-1);
+           Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+       }

     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();

@@ -109,25 +155,45 @@ blockAsyncExceptionszh_fast
 
 unblockAsyncExceptionszh_fast
 {
 
 unblockAsyncExceptionszh_fast
 {

+    CInt r;
+

     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
 
     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
 

-    if (StgTSO_blocked_exceptions(CurrentTSO) != NULL) {
-#if defined(GRAN) || defined(PAR)
-      foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr", 
-                                    StgTSO_block_info(CurrentTSO) "ptr");
-#else
-      foreign "C" awakenBlockedQueue(MyCapability() "ptr", StgTSO_blocked_exceptions(CurrentTSO) "ptr");
-#endif
-      StgTSO_blocked_exceptions(CurrentTSO) = NULL;
-
-      /* avoid growing the stack unnecessarily */
-      if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
-       Sp_adj(1);
-      } else {
-       Sp_adj(-1);
-       Sp(0) = stg_blockAsyncExceptionszh_ret_info;
-      }
+    if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
+
+       StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
+          ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
+
+        /* 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.
+             */
+            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));
+               }
+            }
+        }
+
+       /* avoid growing the stack unnecessarily */
+       if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
+           Sp_adj(1);
+       } else {
+           Sp_adj(-1);
+           Sp(0) = stg_blockAsyncExceptionszh_ret_info;
+       }

     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();

@@ -135,74 +201,66 @@ unblockAsyncExceptionszh_fast
 }
 
 
 }
 
 

-#define interruptible(what_next)               \
-        (   what_next == BlockedOnMVar         \
-         || what_next == BlockedOnException    \
-         || what_next == BlockedOnRead         \
-         || what_next == BlockedOnWrite                \
-         || what_next == BlockedOnDelay                \
-         || what_next == BlockedOnDoProc)
-

 killThreadzh_fast
 {
 killThreadzh_fast
 {

-  /* args: R1 = TSO to kill, R2 = Exception */
-
-  W_ why_blocked;
-
-  /* This thread may have been relocated.
-   * (see Schedule.c:threadStackOverflow)
-   */
- while:
-  if (StgTSO_what_next(R1) == ThreadRelocated::I16) {
-    R1 = StgTSO_link(R1);
-    goto while;
-  }
-
-  /* Determine whether this thread is interruptible or not */
-
-  /* If the target thread is currently blocking async exceptions,
-   * we'll have to block until it's ready to accept them.  The
-   * exception is interruptible threads - ie. those that are blocked
-   * on some resource.
-   */
-  why_blocked = TO_W_(StgTSO_why_blocked(R1));
-  if (StgTSO_blocked_exceptions(R1) != NULL && !interruptible(why_blocked))
-  {
-      StgTSO_link(CurrentTSO) = StgTSO_blocked_exceptions(R1);
-      StgTSO_blocked_exceptions(R1) = CurrentTSO;
-      
-      StgTSO_why_blocked(CurrentTSO) = BlockedOnException::I16;
-      StgTSO_block_info(CurrentTSO) = R1;
-      
-      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 == CurrentTSO) {
+    /* args: R1 = TSO to kill, R2 = Exception */
+
+    W_ why_blocked;
+    W_ target;
+    W_ exception;
+    
+    target = R1;
+    exception = R2;
+    
+    STK_CHK_GEN( WDS(3), R1_PTR & R2_PTR, killThreadzh_fast);
+
+    /* 
+     * 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.
+     */
+  loop:
+    if (StgTSO_what_next(target) == ThreadRelocated::I16) {
+        target = StgTSO_link(target);
+        goto loop;
+    }
+    if (target == CurrentTSO) {

        SAVE_THREAD_STATE();
        SAVE_THREAD_STATE();

-       foreign "C" raiseAsync(MyCapability() "ptr", R1 "ptr", R2 "ptr");
+       /* 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) {
        if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {

-               R1 = ThreadFinished;
-               jump StgReturn;
+            jump stg_threadFinished;

        } else {
        } else {

-               LOAD_THREAD_STATE();
-               ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
-               jump %ENTRY_CODE(Sp(0));
+           LOAD_THREAD_STATE();
+           ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+           jump %ENTRY_CODE(Sp(0));
+       }
+    } 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) {
+
+       case THROWTO_SUCCESS: {
+           jump %ENTRY_CODE(Sp(0));

        }
        }

-  } else {
-       foreign "C" raiseAsync(MyCapability() "ptr", R1 "ptr", R2 "ptr");
-  }

 
 

-  jump %ENTRY_CODE(Sp(0));
+       case THROWTO_BLOCKED: {
+           R3 = W_[out];
+           // we must block, and call throwToReleaseTarget() before returning
+           jump stg_block_throwto;
+       }
+       }
+    }

 }
 
 /* -----------------------------------------------------------------------------
 }
 
 /* -----------------------------------------------------------------------------

@@ -210,68 +268,35 @@ killThreadzh_fast
    -------------------------------------------------------------------------- */
 
 #ifdef REG_R1
    -------------------------------------------------------------------------- */
 
 #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
 
 #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.
  */
 
 /* 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, "ptr" W_ unused4)
+#ifdef REG_R1
+   {
+      Sp = Sp + SIZEOF_StgCatchFrame;
+      jump %ENTRY_CODE(Sp(SP_OFF));
+   }
+#else
+   {
+      W_ rval;
+      rval = Sp(0);
+      Sp = Sp + SIZEOF_StgCatchFrame;
+      Sp(0) = rval;
+      jump %ENTRY_CODE(Sp(SP_OFF));
+   }
+#endif

 
 /* -----------------------------------------------------------------------------
  * The catch infotable
 
 /* -----------------------------------------------------------------------------
  * The catch infotable

@@ -300,15 +325,14 @@ catchzh_fast
     SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
     
     StgCatchFrame_handler(Sp) = R2;
     SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
     
     StgCatchFrame_handler(Sp) = R2;

-    StgCatchFrame_exceptions_blocked(Sp) = 
-       (StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+    StgCatchFrame_exceptions_blocked(Sp) = TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX;

     TICK_CATCHF_PUSHED();
 
     /* Apply R1 to the realworld token */
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     jump stg_ap_v_fast;
     TICK_CATCHF_PUSHED();
 
     /* Apply R1 to the realworld token */
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     jump stg_ap_v_fast;

-}      
+}

 
 /* -----------------------------------------------------------------------------
  * The raise infotable
 
 /* -----------------------------------------------------------------------------
  * The raise infotable

@@ -326,13 +350,26 @@ INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
   jump raisezh_fast;
 }
 
   jump raisezh_fast;
 }
 

+section "data" {
+  no_break_on_exception: W_[1];
+}
+
+INFO_TABLE_RET(stg_raise_ret, RET_SMALL, "ptr" W_ arg1)
+{
+  R1 = Sp(1);
+  Sp = Sp + WDS(2);
+  W_[no_break_on_exception] = 1;  
+  jump raisezh_fast;
+}
+

 raisezh_fast
 {
     W_ handler;
 raisezh_fast
 {
     W_ handler;

-    W_ raise_closure;

     W_ frame_type;
     W_ frame_type;

+    W_ exception;

     /* args : R1 :: Exception */
 
     /* args : R1 :: Exception */
 

+   exception = R1;

 
 #if defined(PROFILING)
     /* Debugging tool: on raising an  exception, show where we are. */
 
 #if defined(PROFILING)
     /* Debugging tool: on raising an  exception, show where we are. */

@@ -340,39 +377,82 @@ raisezh_fast
     /* ToDo: currently this is a hack.  Would be much better if
      * the info was only displayed for an *uncaught* exception.
      */
     /* ToDo: currently this is a hack.  Would be much better if
      * the info was only displayed for an *uncaught* exception.
      */

-    if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags)) {
-      foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
+    if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
+      foreign "C" fprintCCS_stderr(W_[CCCS] "ptr") [];

     }
 #endif
     }
 #endif

-
+    

 retry_pop_stack:
     StgTSO_sp(CurrentTSO) = Sp;
 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
     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);
       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") [];
+      ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+      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;
       StgTSO_trec(CurrentTSO) = NO_TREC;

-      if (r) {
+      if (r != 0) {

         // Transaction was valid: continue searching for a catch frame
         Sp = Sp + SIZEOF_StgAtomicallyFrame;
         goto retry_pop_stack;
       } else {
         // Transaction was not valid: we retry the exception (otherwise continue
         // with a further call to raiseExceptionHelper)
         // Transaction was valid: continue searching for a catch frame
         Sp = Sp + SIZEOF_StgAtomicallyFrame;
         goto 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;
       }          
     }
 
         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.
+            W_[rts_stop_on_exception] = 0;
+            ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
+            Sp = Sp - WDS(7);
+            Sp(6) = exception;
+            Sp(5) = stg_raise_ret_info;
+            Sp(4) = stg_noforceIO_info;    // required for unregisterised
+            Sp(3) = exception;             // the AP_STACK
+            Sp(2) = ghczmprim_GHCziBool_True_closure; // dummy breakpoint info
+            Sp(1) = ghczmprim_GHCziBool_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.
     if (frame_type == STOP_FRAME) {
        /*
         * We've stripped the entire stack, the thread is now dead.

@@ -381,16 +461,12 @@ retry_pop_stack:
         */
        Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
                + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
         */
        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! */
 
        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
     }
 
     /* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME.  Pop everything

@@ -408,6 +484,9 @@ retry_pop_stack:
      * If exceptions were unblocked, arrange that they are unblocked
      * again after executing the handler by pushing an
      * unblockAsyncExceptions_ret stack frame.
      * If exceptions were unblocked, arrange that they are unblocked
      * again after executing the handler by pushing an
      * unblockAsyncExceptions_ret stack frame.

+     *
+     * If we've reached an STM catch frame then roll back the nested
+     * transaction we were using.

      */
     W_ frame;
     frame = Sp;
      */
     W_ frame;
     frame = Sp;

@@ -418,20 +497,25 @@ retry_pop_stack:
         Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
       }
     } else {
         Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
       }
     } else {

+      W_ trec, outer;
+      trec = StgTSO_trec(CurrentTSO);
+      ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+      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.
     */
       Sp = Sp + SIZEOF_StgCatchSTMFrame;
     }
 
     /* Ensure that async excpetions are blocked when running the handler.
     */

-    if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
-      StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
-    }
+    StgTSO_flags(CurrentTSO) = 
+       StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;

 
     /* Call the handler, passing the exception value and a realworld
      * token as arguments.
      */
     Sp_adj(-1);
 
     /* 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();
     R1 = handler;
     Sp_adj(-1);
     TICK_UNKNOWN_CALL();