X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FHeapStackCheck.cmm;h=4e5dd2459636f177961d4f9934e87206b20a9236;hb=76c0086f090327eecaf510de8bc4efc4dee996dc;hp=e9236f19dc4b40a87572fda854f82440682c61e6;hpb=1621421619df6f19dce3b8cb29471e5d3c731acb;p=ghc-hetmet.git

diff --git a/ghc/rts/HeapStackCheck.cmm b/ghc/rts/HeapStackCheck.cmm
index e9236f1..4e5dd24 100644
--- a/ghc/rts/HeapStackCheck.cmm
+++ b/ghc/rts/HeapStackCheck.cmm
@@ -42,6 +42,11 @@
  * at all, it won't yield.  Hopefully this won't be a problem in practice.
  */
  
+#define PRE_RETURN(why,what_next)			\
+  StgTSO_what_next(CurrentTSO) = what_next::I16;	\
+  StgRegTable_rRet(BaseReg) = why;           	        \
+  R1 = BaseReg;
+
 /* Remember that the return address is *removed* when returning to a
  * ThreadRunGHC thread.
  */
@@ -69,20 +74,29 @@
         R1 = StackOverflow;					\
     }								\
   sched:							\
-    SAVE_THREAD_STATE();					\
-    StgTSO_what_next(CurrentTSO) = ThreadRunGHC::I16;		\
-    jump StgReturn;
+    PRE_RETURN(R1,ThreadRunGHC);				\
+    jump stg_returnToSched;
 
-#define RETURN_TO_SCHED(why,what_next)			\
-  SAVE_THREAD_STATE();					\
-  StgTSO_what_next(CurrentTSO) = what_next::I16;	\
-  R1 = why;						\
-  jump StgReturn;
+#define HP_GENERIC				\
+   PRE_RETURN(HeapOverflow, ThreadRunGHC)	\
+  jump stg_returnToSched;
+
+#define BLOCK_GENERIC				\
+   PRE_RETURN(ThreadBlocked,  ThreadRunGHC)	\
+  jump stg_returnToSched;
 
-#define HP_GENERIC           RETURN_TO_SCHED(HeapOverflow,   ThreadRunGHC)
-#define YIELD_GENERIC        RETURN_TO_SCHED(ThreadYielding, ThreadRunGHC)
-#define YIELD_TO_INTERPRETER RETURN_TO_SCHED(ThreadYielding, ThreadInterpret)
-#define BLOCK_GENERIC        RETURN_TO_SCHED(ThreadBlocked,  ThreadRunGHC)
+#define YIELD_GENERIC				\
+  PRE_RETURN(ThreadYielding, ThreadRunGHC)	\
+  jump stg_returnToSched;
+
+#define BLOCK_BUT_FIRST(c)			\
+  PRE_RETURN(ThreadBlocked, ThreadRunGHC)	\
+  R2 = c;					\
+  jump stg_returnToSchedButFirst;
+
+#define YIELD_TO_INTERPRETER			\
+  PRE_RETURN(ThreadYielding, ThreadInterpret)	\
+  jump stg_returnToSchedNotPaused;
 
 /* -----------------------------------------------------------------------------
    Heap checks in thunks/functions.
@@ -611,7 +625,7 @@ __stg_gc_fun
         Sp(2) = R1;
         Sp(1) = size;
         Sp(0) = stg_gc_fun_info;
-        // DEBUG_ONLY(foreign "C" fprintf(stderr, "stg_fun_gc_gen(ARG_GEN)"););
+        // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
         GC_GENERIC
     } else { 
 	jump W_[stg_stack_save_entries + WDS(type)];
@@ -711,7 +725,7 @@ INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN )
     Sp(5) = R3;					\
     Sp(4) = R2;					\
     Sp(3) = R1;					\
-    Sp(2) = R10.w;    /* return address */	\
+    Sp(2) = R10;    /* return address */	\
     Sp(1) = R9;     /* liveness mask  */	\
     Sp(0) = stg_gc_gen_info;
 
@@ -823,12 +837,22 @@ INFO_TABLE_RET( stg_block_takemvar, 1/*framesize*/, 0/*bitmap*/, RET_SMALL )
     jump takeMVarzh_fast;
 }
 
+// code fragment executed just before we return to the scheduler
+stg_block_takemvar_finally
+{
+#ifdef THREADED_RTS
+    foreign "C" unlockClosure(R3 "ptr", stg_EMPTY_MVAR_info);
+#endif
+    jump StgReturn;
+}
+
 stg_block_takemvar
 {
     Sp_adj(-2);
     Sp(1) = R1;
     Sp(0) = stg_block_takemvar_info;
-    BLOCK_GENERIC;
+    R3 = R1;
+    BLOCK_BUT_FIRST(stg_block_takemvar_finally);
 }
 
 INFO_TABLE_RET( stg_block_putmvar, 2/*framesize*/, 0/*bitmap*/, RET_SMALL )
@@ -839,13 +863,43 @@ INFO_TABLE_RET( stg_block_putmvar, 2/*framesize*/, 0/*bitmap*/, RET_SMALL )
     jump putMVarzh_fast;
 }
 
+// code fragment executed just before we return to the scheduler
+stg_block_putmvar_finally
+{
+#ifdef THREADED_RTS
+    foreign "C" unlockClosure(R3 "ptr", stg_FULL_MVAR_info);
+#endif
+    jump StgReturn;
+}
+
 stg_block_putmvar
 {
     Sp_adj(-3);
     Sp(2) = R2;
     Sp(1) = R1;
     Sp(0) = stg_block_putmvar_info;
-    BLOCK_GENERIC;
+    R3 = R1;
+    BLOCK_BUT_FIRST(stg_block_putmvar_finally);
+}
+
+// code fragment executed just before we return to the scheduler
+stg_block_blackhole_finally
+{
+#if defined(THREADED_RTS)
+    // The last thing we do is release sched_lock, which is
+    // preventing other threads from accessing blackhole_queue and
+    // picking up this thread before we are finished with it.
+    foreign "C" RELEASE_LOCK(sched_mutex "ptr");
+#endif
+    jump StgReturn;
+}
+
+stg_block_blackhole
+{
+    Sp_adj(-2);
+    Sp(1) = R1;
+    Sp(0) = stg_enter_info;
+    BLOCK_BUT_FIRST(stg_block_blackhole_finally);
 }
 
 #ifdef mingw32_HOST_OS
@@ -893,3 +947,18 @@ stg_block_async_void
 }
 
 #endif
+
+/* -----------------------------------------------------------------------------
+   STM-specific waiting
+   -------------------------------------------------------------------------- */
+
+stg_block_stmwait_finally
+{
+    foreign "C" stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
+    jump StgReturn;
+}
+
+stg_block_stmwait
+{
+    BLOCK_BUT_FIRST(stg_block_stmwait_finally);
+}