[project @ 2005-09-12 16:00:43 by simonmar]

[ghc-hetmet.git] / ghc / rts / Schedule.c

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index ea791e5..a496c3d 100644 (file)
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -707,12 +707,6 @@ run_thread:
     cap = myCapability();
 #endif
 
-    // We have run some Haskell code: there might be blackhole-blocked
-    // threads to wake up now.
-    if ( blackhole_queue != END_TSO_QUEUE ) {
-       blackholes_need_checking = rtsTrue;
-    }
-
     cap->r.rInHaskell = rtsFalse;
 
     // The TSO might have moved, eg. if it re-entered the RTS and a GC
@@ -731,6 +725,12 @@ run_thread:
 #endif
     
     ACQUIRE_LOCK(&sched_mutex);
+
+    // We have run some Haskell code: there might be blackhole-blocked
+    // threads to wake up now.
+    if ( blackhole_queue != END_TSO_QUEUE ) {
+       blackholes_need_checking = rtsTrue;
+    }
     
 #if defined(RTS_SUPPORTS_THREADS)
     IF_DEBUG(scheduler,debugBelch("sched (task %p): ", osThreadId()););
@@ -1930,19 +1930,28 @@ scheduleDoGC( rtsBool force_major )
      * atomically frames.  When next scheduled they will try to
      * commit, this commit will fail and they will retry.
      */
-    for (t = all_threads; t != END_TSO_QUEUE; t = t -> link) {
-       if (t -> what_next != ThreadRelocated && t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
-           if (!stmValidateNestOfTransactions (t -> trec)) {
-               IF_DEBUG(stm, sched_belch("trec %p found wasting its time", t));
-               
-               // strip the stack back to the ATOMICALLY_FRAME, aborting
-               // the (nested) transaction, and saving the stack of any
-               // partially-evaluated thunks on the heap.
-               raiseAsync_(t, NULL, rtsTrue);
-               
+    { 
+       StgTSO *next;
+
+       for (t = all_threads; t != END_TSO_QUEUE; t = next) {
+           if (t->what_next == ThreadRelocated) {
+               next = t->link;
+           } else {
+               next = t->global_link;
+               if (t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
+                   if (!stmValidateNestOfTransactions (t -> trec)) {
+                       IF_DEBUG(stm, sched_belch("trec %p found wasting its time", t));
+                       
+                       // strip the stack back to the ATOMICALLY_FRAME, aborting
+                       // the (nested) transaction, and saving the stack of any
+                       // partially-evaluated thunks on the heap.
+                       raiseAsync_(t, NULL, rtsTrue);
+                       
 #ifdef REG_R1
-               ASSERT(get_itbl((StgClosure *)t->sp)->type == ATOMICALLY_FRAME);
+                       ASSERT(get_itbl((StgClosure *)t->sp)->type == ATOMICALLY_FRAME);
 #endif
+                   }
+               }
            }
        }
     }
@@ -2306,6 +2315,8 @@ createThread(nat size)
     StgTSO *tso;
     nat stack_size;
 
+    ACQUIRE_LOCK(&sched_mutex);
+
     /* First check whether we should create a thread at all */
 #if defined(PARALLEL_HASKELL)
   /* check that no more than RtsFlags.ParFlags.maxThreads threads are created */
@@ -2313,6 +2324,7 @@ createThread(nat size)
     threadsIgnored++;
     debugBelch("{createThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)\n",
          RtsFlags.ParFlags.maxThreads, advisory_thread_count);
+    RELEASE_LOCK(&sched_mutex);
     return END_TSO_QUEUE;
   }
   threadsCreated++;
@@ -2463,6 +2475,7 @@ createThread(nat size)
   IF_DEBUG(scheduler,sched_belch("created thread %ld, stack size = %lx words", 
                                 (long)tso->id, (long)tso->stack_size));
 #endif    
+  RELEASE_LOCK(&sched_mutex);
   return tso;
 }
 
@@ -3803,7 +3816,7 @@ raiseAsync_(StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically)
            // we've got an exception to raise, so let's pass it to the
            // handler in this frame.
            //
-           raise = (StgThunk *)allocate(sizeofW(StgThunk)+1);
+           raise = (StgThunk *)allocate(sizeofW(StgThunk)+MIN_UPD_SIZE);
            TICK_ALLOC_SE_THK(1,0);
            SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
            raise->payload[0] = exception;