X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FSchedule.c;h=0b1dec40856bed27083c24d1ba968b6d79aff5aa;hb=00a4cdf7db3ac722db2346416a1b3b891dbc9a0a;hp=456258c8851be63db0fca1f07617c7250e7ecbb4;hpb=539d3adec64f51a3fb13bb65b7a494d7eded01a0;p=ghc-hetmet.git

diff --git a/rts/Schedule.c b/rts/Schedule.c
index 456258c..0b1dec4 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -56,6 +56,9 @@
 #include <errno.h>
 #endif
 
+#ifdef TRACING
+#include "eventlog/EventLog.h"
+#endif
 /* -----------------------------------------------------------------------------
  * Global variables
  * -------------------------------------------------------------------------- */
@@ -1022,6 +1025,10 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
 	
 	blocks = (lnat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
 	
+        if (blocks > BLOCKS_PER_MBLOCK) {
+            barf("allocation of %ld bytes too large (GHC should have complained at compile-time)", (long)cap->r.rHpAlloc);
+        }
+
 	debugTrace(DEBUG_sched,
 		   "--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n", 
 		   (long)t->id, what_next_strs[t->what_next], blocks);
@@ -1031,10 +1038,8 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
 	    cap->r.rNursery->n_blocks == 1) {  // paranoia to prevent infinite loop
 	                                       // if the nursery has only one block.
 	    
-	    ACQUIRE_SM_LOCK
-	    bd = allocGroup( blocks );
-	    RELEASE_SM_LOCK
-	    cap->r.rNursery->n_blocks += blocks;
+            bd = allocGroup_lock(blocks);
+            cap->r.rNursery->n_blocks += blocks;
 	    
 	    // link the new group into the list
 	    bd->link = cap->r.rCurrentNursery;
@@ -1535,6 +1540,10 @@ forkProcess(HsStablePtr *entry
 
     stopTimer(); // See #4074
 
+#if defined(TRACING)
+    flushEventLog(); // so that child won't inherit dirty file buffers
+#endif
+
     pid = fork();
     
     if (pid) { // parent
@@ -1557,7 +1566,11 @@ forkProcess(HsStablePtr *entry
         initMutex(&cap->running_task->lock);
 #endif
 
-	// Now, all OS threads except the thread that forked are
+#ifdef TRACING
+        resetTracing();
+#endif
+
+        // Now, all OS threads except the thread that forked are
 	// stopped.  We need to stop all Haskell threads, including
 	// those involved in foreign calls.  Also we need to delete
 	// all Tasks, because they correspond to OS threads that are
@@ -1607,7 +1620,8 @@ forkProcess(HsStablePtr *entry
 	// Wipe our spare workers list, they no longer exist.  New
 	// workers will be created if necessary.
 	cap->spare_workers = NULL;
-	cap->returning_tasks_hd = NULL;
+        cap->n_spare_workers = 0;
+        cap->returning_tasks_hd = NULL;
 	cap->returning_tasks_tl = NULL;
 #endif
 
@@ -1817,6 +1831,9 @@ resumeThread (void *task_)
 
     traceEventRunThread(cap, tso);
     
+    /* Reset blocking status */
+    tso->why_blocked  = NotBlocked;
+
     if ((tso->flags & TSO_BLOCKEX) == 0) {
         // avoid locking the TSO if we don't have to
         if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
@@ -1824,9 +1841,6 @@ resumeThread (void *task_)
         }
     }
     
-    /* Reset blocking status */
-    tso->why_blocked  = NotBlocked;
-    
     cap->r.rCurrentTSO = tso;
     cap->in_haskell = rtsTrue;
     errno = saved_errno;