X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FException.cmm;h=a3f3dd0d8290aad57c8ad12b72bbbec46d0661c5;hb=9fd4d1e84e5a305e227db2ec78a46d1762907493;hp=103e0c4a5df93b54243d5f3330f361baf9a1ab67;hpb=d50e93cf95b68bf858be82025b56c9977335ed76;p=ghc-hetmet.git

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 103e0c4..a3f3dd0 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -53,15 +53,56 @@
 INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
  		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
 {
+    CInt r;
+
     // Not true: see comments above
     // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
 
-    foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-					    CurrentTSO "ptr") [R1];
-
     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
+        SAVE_THREAD_STATE();
+        r = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
+    					              CurrentTSO "ptr") [R1];
+
+        if (r != 0::CInt) {
+            if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+                R1 = ThreadFinished;
+                jump StgReturn;
+            } 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));
@@ -116,16 +157,39 @@ blockAsyncExceptionszh_fast
 
 unblockAsyncExceptionszh_fast
 {
+    CInt r;
+
     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
 
     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);
 
+        /* 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) {
+	            R1 = ThreadFinished;
+	            jump StgReturn;
+	        } 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);
@@ -338,7 +402,7 @@ raisezh_fast
 #endif
     
     /* Inform the Hpc that an exception has been thrown */
-    foreign "C" hs_hpc_throw();
+    foreign "C" hs_hpc_raise_event(CurrentTSO "ptr");
 
 retry_pop_stack:
     StgTSO_sp(CurrentTSO) = Sp;