X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FException.cmm;h=a3f3dd0d8290aad57c8ad12b72bbbec46d0661c5;hb=f47590d7b38a43c8518669dcb8499b42a7e8f9cf;hp=62d544c350eacfeec56f35448b3c056306854328;hpb=178837a730c65349b32b29bd22356bacde110e18;p=ghc-hetmet.git

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 62d544c..a3f3dd0 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -68,6 +68,16 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
          * 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];
@@ -82,6 +92,15 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
                 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
@@ -383,7 +402,7 @@ raisezh_fast
 #endif
     
     /* Inform the Hpc that an exception has been thrown */
-    foreign "C" hs_hpc_event("Raise",CurrentTSO);
+    foreign "C" hs_hpc_raise_event(CurrentTSO "ptr");
 
 retry_pop_stack:
     StgTSO_sp(CurrentTSO) = Sp;