Fix linker_unload now that we are running constructors in the linker (#8291)
[ghc.git] / rts / Threads.c
index e86630e..14fb7e8 100644 (file)
@@ -57,7 +57,7 @@ static StgThreadID next_thread_id = 1;
    currently pri (priority) is only used in a GRAN setup -- HWL
    ------------------------------------------------------------------------ */
 StgTSO *
-createThread(Capability *cap, nat size)
+createThread(Capability *cap, W_ size)
 {
     StgTSO *tso;
     StgStack *stack;
@@ -66,8 +66,8 @@ createThread(Capability *cap, nat size)
     /* sched_mutex is *not* required */
 
     /* catch ridiculously small stack sizes */
-    if (size < MIN_STACK_WORDS + sizeofW(StgStack)) {
-        size = MIN_STACK_WORDS + sizeofW(StgStack);
+    if (size < MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO)) {
+        size = MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO);
     }
 
     /* The size argument we are given includes all the per-thread
@@ -84,7 +84,7 @@ createThread(Capability *cap, nat size)
     stack_size = round_to_mblocks(size - sizeofW(StgTSO));
     stack = (StgStack *)allocate(cap, stack_size);
     TICK_ALLOC_STACK(stack_size);
-    SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM);
+    SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS);
     stack->stack_size   = stack_size - sizeofW(StgStack);
     stack->sp           = stack->stack + stack->stack_size;
     stack->dirty        = 1;
@@ -113,7 +113,7 @@ createThread(Capability *cap, nat size)
     tso->trec = NO_TREC;
 
 #ifdef PROFILING
-    tso->prof.CCCS = CCS_MAIN;
+    tso->prof.cccs = CCS_MAIN;
 #endif
     
     // put a stop frame on the stack
@@ -247,7 +247,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
         msg->tso = tso;
         sendMessage(cap, tso->cap, (Message*)msg);
         debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d",
-                      (lnat)tso->id, tso->cap->no);
+                      (W_)tso->id, tso->cap->no);
         return;
     }
 #endif
@@ -255,6 +255,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
     switch (tso->why_blocked)
     {
     case BlockedOnMVar:
+    case BlockedOnMVarRead:
     {
         if (tso->_link == END_TSO_QUEUE) {
             tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
@@ -272,7 +273,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
         unlockClosure(tso->block_info.closure, i);
         if (i != &stg_MSG_NULL_info) {
             debugTraceCap(DEBUG_sched, cap, "thread %ld still blocked on throwto (%p)",
-                          (lnat)tso->id, tso->block_info.throwto->header.info);
+                          (W_)tso->id, tso->block_info.throwto->header.info);
             return;
         }
 
@@ -375,7 +376,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso)
 
     debugTraceCap(DEBUG_sched, cap,
                   "collision occurred; checking blocking queues for thread %ld",
-                  (lnat)tso->id);
+                  (W_)tso->id);
     
     for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) {
         next = bq->link;
@@ -424,12 +425,16 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val)
 
     updateWithIndirection(cap, thunk, val);
 
+    // sometimes the TSO is locked when we reach here, so its header
+    // might be WHITEHOLE.  Hence check for the correct owner using
+    // pointer equality first.
+    if ((StgTSO*)v == tso) {
+        return;
+    }
+
     i = v->header.info;
     if (i == &stg_TSO_info) {
-        owner = (StgTSO*)v;
-        if (owner != tso) {
-            checkBlockingQueues(cap, tso);
-        }
+        checkBlockingQueues(cap, tso);
         return;
     }
 
@@ -490,7 +495,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
 {
     StgStack *new_stack, *old_stack;
     StgUnderflowFrame *frame;
-    lnat chunk_size;
+    W_ chunk_size;
 
     IF_DEBUG(sanity,checkTSO(tso));
 
@@ -558,7 +563,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
     //
     if (old_stack->sp > old_stack->stack + old_stack->stack_size / 2)
     {
-        chunk_size = 2 * (old_stack->stack_size + sizeofW(StgStack));
+        chunk_size = stg_max(2 * (old_stack->stack_size + sizeofW(StgStack)),
+                             RtsFlags.GcFlags.stkChunkSize);
     }
     else
     {
@@ -570,7 +576,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
                   chunk_size * sizeof(W_));
 
     new_stack = (StgStack*) allocate(cap, chunk_size);
-    SET_HDR(new_stack, &stg_STACK_info, CCS_SYSTEM);
+    SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs);
     TICK_ALLOC_STACK(chunk_size);
 
     new_stack->dirty = 0; // begin clean, we'll mark it dirty below
@@ -579,14 +585,9 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
 
     tso->tot_stack_size += new_stack->stack_size;
 
-    new_stack->sp -= sizeofW(StgUnderflowFrame);
-    frame = (StgUnderflowFrame*)new_stack->sp;
-    frame->info = &stg_stack_underflow_frame_info;
-    frame->next_chunk  = old_stack;
-
     {
         StgWord *sp;
-        nat chunk_words, size;
+        W_ chunk_words, size;
 
         // find the boundary of the chunk of old stack we're going to
         // copy to the new stack.  We skip over stack frames until we
@@ -611,6 +612,28 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
             sp += size;
         }
 
+        if (sp == old_stack->stack + old_stack->stack_size) {
+            //
+            // the old stack chunk is now empty, so we do *not* insert
+            // an underflow frame pointing back to it.  There are two
+            // cases: either the old stack chunk was the last one, in
+            // which case it ends with a STOP_FRAME, or it is not the
+            // last one, and it already ends with an UNDERFLOW_FRAME
+            // pointing to the previous chunk.  In the latter case, we
+            // will copy the UNDERFLOW_FRAME into the new stack chunk.
+            // In both cases, the old chunk will be subsequently GC'd.
+            //
+            // With the default settings, -ki1k -kb1k, this means the
+            // first stack chunk will be discarded after the first
+            // overflow, being replaced by a non-moving 32k chunk.
+            //
+        } else {
+            new_stack->sp -= sizeofW(StgUnderflowFrame);
+            frame = (StgUnderflowFrame*)new_stack->sp;
+            frame->info = &stg_stack_underflow_frame_info;
+            frame->next_chunk  = old_stack;
+        }
+
         // copy the stack chunk between tso->sp and sp to
         //   new_tso->sp + (tso->sp - sp)
         chunk_words = sp - old_stack->sp;
@@ -623,14 +646,6 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
         new_stack->sp -= chunk_words;
     }
 
-    // if the old stack chunk is now empty, discard it.  With the
-    // default settings, -ki1k -kb1k, this means the first stack chunk
-    // will be discarded after the first overflow, being replaced by a
-    // non-moving 32k chunk.
-    if (old_stack->sp == old_stack->stack + old_stack->stack_size) {
-        frame->next_chunk = new_stack;
-    }
-
     tso->stackobj = new_stack;
 
     // we're about to run it, better mark it dirty
@@ -645,7 +660,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
    Stack underflow - called from the stg_stack_underflow_info frame
    ------------------------------------------------------------------------ */
 
-nat // returns offset to the return address
+W_ // returns offset to the return address
 threadStackUnderflow (Capability *cap, StgTSO *tso)
 {
     StgStack *new_stack, *old_stack;
@@ -667,7 +682,7 @@ threadStackUnderflow (Capability *cap, StgTSO *tso)
     if (retvals != 0)
     {
         // we have some return values to copy to the old stack
-        if ((new_stack->sp - new_stack->stack) < retvals)
+        if ((W_)(new_stack->sp - new_stack->stack) < retvals)
         {
             barf("threadStackUnderflow: not enough space for return values");
         }
@@ -701,23 +716,28 @@ void
 printThreadBlockage(StgTSO *tso)
 {
   switch (tso->why_blocked) {
+#if defined(mingw32_HOST_OS)
+    case BlockedOnDoProc:
+    debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
+    break;
+#endif
+#if !defined(THREADED_RTS)
   case BlockedOnRead:
     debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
     break;
   case BlockedOnWrite:
     debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
     break;
-#if defined(mingw32_HOST_OS)
-    case BlockedOnDoProc:
-    debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
-    break;
-#endif
   case BlockedOnDelay:
     debugBelch("is blocked until %ld", (long)(tso->block_info.target));
     break;
+#endif
   case BlockedOnMVar:
     debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
     break;
+  case BlockedOnMVarRead:
+    debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
+    break;
   case BlockedOnBlackHole:
       debugBelch("is blocked on a black hole %p", 
                  ((StgBlockingQueue*)tso->block_info.bh->bh));
@@ -781,7 +801,7 @@ printAllThreads(void)
   debugBelch("all threads:\n");
 
   for (i = 0; i < n_capabilities; i++) {
-      cap = &capabilities[i];
+      cap = capabilities[i];
       debugBelch("threads on capability %d:\n", cap->no);
       for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
          printThreadStatus(t);