Turn the "too many hs_exit()s" fatal error into a warning

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

diff --git a/ghc/rts/PrimOps.cmm b/ghc/rts/PrimOps.cmm
index f657a24..f1c214e 100644 (file)
--- a/ghc/rts/PrimOps.cmm
+++ b/ghc/rts/PrimOps.cmm
@@ -876,19 +876,45 @@ decodeDoublezh_fast
 forkzh_fast
 {
   /* args: R1 = closure to spark */
-  
+
   MAYBE_GC(R1_PTR, forkzh_fast);
 
-  // create it right now, return ThreadID in R1
-  "ptr" R1 = foreign "C" createIOThread( MyCapability() "ptr", 
+  W_ closure;
+  W_ threadid;
+  closure = R1;
+
+  "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr", 
+                               RtsFlags_GcFlags_initialStkSize(RtsFlags), 
+                               closure "ptr") [];
+  foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
+
+  // switch at the earliest opportunity
+  CInt[context_switch] = 1 :: CInt;
+  
+  RET_P(threadid);
+}
+
+forkOnzh_fast
+{
+  /* args: R1 = cpu, R2 = closure to spark */
+
+  MAYBE_GC(R2_PTR, forkOnzh_fast);
+
+  W_ cpu;
+  W_ closure;
+  W_ threadid;
+  cpu = R1;
+  closure = R2;
+
+  "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr", 
                                RtsFlags_GcFlags_initialStkSize(RtsFlags), 
-                               R1 "ptr") [R1];
-  foreign "C" scheduleThread(MyCapability() "ptr", R1 "ptr") [R1];
+                               closure "ptr") [];
+  foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
 
   // switch at the earliest opportunity
   CInt[context_switch] = 1 :: CInt;
   
-  RET_P(R1);
+  RET_P(threadid);
 }
 
 yieldzh_fast
@@ -996,8 +1022,7 @@ INFO_TABLE_RET(stg_catch_retry_frame,
        R1 = StgCatchRetryFrame_first_code(frame);
        StgCatchRetryFrame_first_code_trec(frame) = new_trec;
      }
-     Sp_adj(-1);
-     jump RET_LBL(stg_ap_v);
+     jump stg_ap_v_fast;
    }
 }
 
@@ -1061,8 +1086,7 @@ INFO_TABLE_RET(stg_atomically_frame,
     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
     StgTSO_trec(CurrentTSO) = trec;
     R1 = StgAtomicallyFrame_code(frame);
-    Sp_adj(-1);
-    jump RET_LBL(stg_ap_v);
+    jump stg_ap_v_fast;
   }
 }
 
@@ -1097,8 +1121,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame,
     StgTSO_trec(CurrentTSO) = trec;
     StgHeader_info(frame) = stg_atomically_frame_info;
     R1 = StgAtomicallyFrame_code(frame);
-    Sp_adj(-1);
-    jump RET_LBL(stg_ap_v);
+    jump stg_ap_v_fast;
   }
 }
 
@@ -1193,8 +1216,7 @@ atomicallyzh_fast
   StgTSO_trec(CurrentTSO) = new_trec;
 
   /* Apply R1 to the realworld token */
-  Sp_adj(-1);
-  jump RET_LBL(stg_ap_v);
+  jump stg_ap_v_fast;
 }
 
 
@@ -1214,8 +1236,7 @@ catchSTMzh_fast
   StgCatchSTMFrame_handler(frame) = R2;
 
   /* Apply R1 to the realworld token */
-  Sp_adj(-1);
-  jump RET_LBL(stg_ap_v);
+  jump stg_ap_v_fast;
 }
 
 
@@ -1248,8 +1269,7 @@ catchRetryzh_fast
   StgCatchRetryFrame_first_code_trec(frame) = new_trec;
 
   /* Apply R1 to the realworld token */
-  Sp_adj(-1);
-  jump RET_LBL(stg_ap_v);  
+  jump stg_ap_v_fast;
 }
 
 
@@ -1281,8 +1301,7 @@ retry_pop_stack:
       StgTSO_trec(CurrentTSO) = trec;
       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
       R1 = StgCatchRetryFrame_alt_code(frame);
-      Sp_adj(-1);
-      jump RET_LBL(stg_ap_v);
+      jump stg_ap_v_fast;
     } else {
       // Retry in the alternative code: propagate
       W_ other_trec;
@@ -1306,8 +1325,7 @@ retry_pop_stack:
         StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
         StgTSO_trec(CurrentTSO) = trec;
         R1 = StgCatchRetryFrame_first_code(frame);
-        Sp_adj(-1);
-        jump RET_LBL(stg_ap_v);
+        jump stg_ap_v_fast;
       }
     }
   }
@@ -1332,8 +1350,7 @@ retry_pop_stack:
     StgTSO_trec(CurrentTSO) = trec;
     R1 = StgAtomicallyFrame_code(frame);
     Sp = frame;
-    Sp_adj(-1);
-    jump RET_LBL(stg_ap_v);
+    jump stg_ap_v_fast;
   }
 }
 
@@ -1505,6 +1522,7 @@ takeMVarzh_fast
       /* actually perform the putMVar for the thread that we just woke up */
       tso = StgMVar_head(mvar);
       PerformPut(tso,StgMVar_value(mvar));
+      foreign "C" dirtyTSO(tso "ptr") [];
 
 #if defined(GRAN) || defined(PAR)
       /* ToDo: check 2nd arg (mvar) is right */
@@ -1578,6 +1596,7 @@ tryTakeMVarzh_fast
        /* actually perform the putMVar for the thread that we just woke up */
        tso = StgMVar_head(mvar);
        PerformPut(tso,StgMVar_value(mvar));
+        foreign "C" dirtyTSO(tso "ptr") [];
 
 #if defined(GRAN) || defined(PAR)
        /* ToDo: check 2nd arg (mvar) is right */
@@ -1647,6 +1666,7 @@ putMVarzh_fast
        /* actually perform the takeMVar */
        tso = StgMVar_head(mvar);
        PerformTake(tso, R2);
+        foreign "C" dirtyTSO(tso "ptr") [];
       
 #if defined(GRAN) || defined(PAR)
        /* ToDo: check 2nd arg (mvar) is right */
@@ -1712,6 +1732,7 @@ tryPutMVarzh_fast
        /* actually perform the takeMVar */
        tso = StgMVar_head(mvar);
        PerformTake(tso, R2);
+        foreign "C" dirtyTSO(tso "ptr") [];
       
 #if defined(GRAN) || defined(PAR)
        /* ToDo: check 2nd arg (mvar) is right */