update submodules for GHC.HetMet.GArrow -> Control.GArrow renaming

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

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 1104706..24da1c6 100644 (file)
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -13,18 +13,20 @@
 #include "Cmm.h"
 #include "RaiseAsync.h"
 
 #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
    
 /* -----------------------------------------------------------------------------
    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:
 
 
    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
 
    Furthermore, asynchronous exceptions are blocked automatically during
    the execution of an exception handler.  Both of these primitives

@@ -37,102 +39,209 @@
    the threads waiting to deliver exceptions to that thread.
 
    NB. there's a bug in here.  If a thread is inside an
    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
    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
    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));
     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) = 

-       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));
     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 */
 {
     /* 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) {
 
     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;
 }
 
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
     jump stg_ap_v_fast;
 }
 

-unblockAsyncExceptionszh_fast
+stg_unmaskAsyncExceptionszh

 {
 {

+    CInt r;
+    W_ level;
+

     /* Args: R1 :: IO a */
     /* 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) {
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {

-       foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-                                               CurrentTSO "ptr") [R1];
-
-       StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
-          ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);

 
        /* avoid growing the stack unnecessarily */
 
        /* 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_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();
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();

@@ -140,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 */
 
 {
     /* args: R1 = TSO to kill, R2 = Exception */
 

@@ -151,7 +272,10 @@ killThreadzh_fast
     target = R1;
     exception = R2;
     
     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*
 
     /* 
      * We might have killed ourselves.  In which case, better be *very*

@@ -160,13 +284,20 @@ killThreadzh_fast
      * the handler.
      */
     if (target == CurrentTSO) {
      * the handler.
      */
     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) {
        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);
        } else {
            LOAD_THREAD_STATE();
            ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);

@@ -174,27 +305,22 @@ killThreadzh_fast
        }
     } else {
        W_ out;
        }
     } 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));
            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;
        }
            jump stg_block_throwto;
        }

-       }

     }
 }
 
     }
 }
 

@@ -202,69 +328,22 @@ killThreadzh_fast
    Catch frames
    -------------------------------------------------------------------------- */
 
    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
 #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, P_ unused4)
+   {
+      Sp = Sp + SIZEOF_StgCatchFrame;
+      jump %ENTRY_CODE(Sp(SP_OFF));
+   }

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

@@ -280,20 +359,21 @@ INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
 {
   R2 = StgClosure_payload(R1,1); /* h */
   R1 = StgClosure_payload(R1,0); /* x */
 {
   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 */
 {
     /* 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;
   
     /* 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 */
     TICK_CATCHF_PUSHED();
 
     /* Apply R1 to the realworld token */

@@ -309,22 +389,35 @@ catchzh_fast
  *
  *   raise = {err} \n {} -> raise#{err}
  *
  *
  *   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);
  * -------------------------------------------------------------------------- */
 
 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_ 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. */

@@ -333,14 +426,14 @@ raisezh_fast
      * the info was only displayed for an *uncaught* exception.
      */
     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
      * 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
     }
 #endif

-
+    

 retry_pop_stack:
 retry_pop_stack:

-    StgTSO_sp(CurrentTSO) = Sp;
-    frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", R1 "ptr");
-    Sp = StgTSO_sp(CurrentTSO);
+    SAVE_THREAD_STATE();
+    (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
+    LOAD_THREAD_STATE();

     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
     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

@@ -353,14 +446,14 @@ retry_pop_stack:
       W_ trec, outer;
       W_ r;
       trec = StgTSO_trec(CurrentTSO);
       W_ trec, outer;
       W_ r;
       trec = StgTSO_trec(CurrentTSO);

-      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");
+      (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) {
 
       if (outer != NO_TREC) {

-        foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr");
-        foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr");
+        foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr") [];
+        foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr") [];

       }
 
       StgTSO_trec(CurrentTSO) = NO_TREC;
       }
 
       StgTSO_trec(CurrentTSO) = NO_TREC;

@@ -371,31 +464,58 @@ retry_pop_stack:
       } else {
         // Transaction was not valid: we retry the exception (otherwise continue
         // with a further call to raiseExceptionHelper)
       } 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.
+            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.
         * We will leave the stack in a GC'able state, see the stg_stop_thread
         * entry code in StgStartup.cmm.
         */
     if (frame_type == STOP_FRAME) {
        /*
         * We've stripped the entire stack, the thread is now dead.
         * We will leave the stack in a GC'able state, see the stg_stop_thread
         * entry code in StgStartup.cmm.
         */

-       Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
-               + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
-       Sp(1) = R1;             /* save the exception */
+        W_ stack;
+        stack = StgTSO_stackobj(CurrentTSO);
+        Sp = stack + OFFSET_StgStack_stack
+                + WDS(TO_W_(StgStack_stack_size(stack))) - WDS(2);
+       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

@@ -412,7 +532,7 @@ retry_pop_stack:
      *
      * If exceptions were unblocked, arrange that they are unblocked
      * again after executing the handler by pushing an
      *
      * 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.
      *
      * If we've reached an STM catch frame then roll back the nested
      * transaction we were using.

@@ -421,14 +541,14 @@ retry_pop_stack:
     frame = Sp;
     if (frame_type == CATCH_FRAME) {
       Sp = Sp + SIZEOF_StgCatchFrame;
     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);
       }
     } else {
       W_ trec, outer;
       trec = StgTSO_trec(CurrentTSO);

-      "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+      outer  = StgTRecHeader_enclosing_trec(trec);

       foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
       foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
       StgTSO_trec(CurrentTSO) = outer;
       foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
       foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
       StgTSO_trec(CurrentTSO) = outer;

@@ -436,15 +556,24 @@ retry_pop_stack:
     }
 
     /* Ensure that async excpetions are blocked when running the handler.
     }
 
     /* 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);
 
     /* 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();

@@ -452,8 +581,8 @@ retry_pop_stack:
     jump RET_LBL(stg_ap_pv);
 }
 
     jump RET_LBL(stg_ap_pv);
 }
 

-raiseIOzh_fast
+stg_raiseIOzh

 {
   /* Args :: R1 :: Exception */
 {
   /* Args :: R1 :: Exception */

-  jump raisezh_fast;
+  jump stg_raisezh;

 }
 }