RTS tidyup sweep, first phase

[ghc-hetmet.git] / rts / sm / Evac.c

diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index f537e2b..9e6d0f1 100644 (file)
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -11,16 +11,16 @@
  *
  * ---------------------------------------------------------------------------*/
 
+#include "PosixSource.h"
 #include "Rts.h"
-#include "Storage.h"
-#include "MBlock.h"
+
 #include "Evac.h"
+#include "Storage.h"
 #include "GC.h"
 #include "GCThread.h"
 #include "GCUtils.h"
 #include "Compact.h"
 #include "Prelude.h"
-#include "LdvProfile.h"
 #include "Trace.h"
 
 #if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC)
@@ -29,6 +29,7 @@ StgWord64 whitehole_spin = 0;
 
 #if defined(THREADED_RTS) && !defined(PARALLEL_GC)
 #define evacuate(p) evacuate1(p)
+#define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p)
 #endif
 
 #if !defined(PARALLEL_GC)
@@ -73,10 +74,10 @@ alloc_for_copy (nat size, step *stp)
      * necessary.
      */
     to = ws->todo_free;
-    if (to + size > ws->todo_lim) {
+    ws->todo_free += size;
+    if (ws->todo_free > ws->todo_lim) {
        to = todo_block_full(size, ws);
     }
-    ws->todo_free = to + size;
     ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim);
 
     return to;
@@ -212,7 +213,7 @@ spin:
     SET_EVACUAEE_FOR_LDV(from, size_to_reserve);
     // fill the slop
     if (size_to_reserve - size_to_copy > 0)
-       LDV_FILL_SLOP(to + size_to_copy - 1, (int)(size_to_reserve - size_to_copy)); 
+       LDV_FILL_SLOP(to + size_to_copy, (int)(size_to_reserve - size_to_copy));
 #endif
 
     return rtsTrue;
@@ -248,10 +249,6 @@ evacuate_large(StgPtr p)
   stp = bd->step;
   ACQUIRE_SPIN_LOCK(&stp->sync_large_objects);
 
-  // object must be at the beginning of the block (or be a ByteArray)
-  ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
-        (((W_)p & BLOCK_MASK) == 0));
-
   // already evacuated? 
   if (bd->flags & BF_EVACUATED) { 
     /* Don't forget to set the gct->failed_to_evac flag if we didn't get
@@ -287,11 +284,25 @@ evacuate_large(StgPtr p)
   }
 
   ws = &gct->steps[new_stp->abs_no];
+
   bd->flags |= BF_EVACUATED;
   bd->step = new_stp;
   bd->gen_no = new_stp->gen_no;
-  bd->link = ws->todo_large_objects;
-  ws->todo_large_objects = bd;
+
+  // If this is a block of pinned objects, we don't have to scan
+  // these objects, because they aren't allowed to contain any
+  // pointers.  For these blocks, we skip the scavenge stage and put
+  // them straight on the scavenged_large_objects list.
+  if (bd->flags & BF_PINNED) {
+      ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS);
+      if (new_stp != stp) { ACQUIRE_SPIN_LOCK(&new_stp->sync_large_objects); }
+      dbl_link_onto(bd, &new_stp->scavenged_large_objects);
+      new_stp->n_scavenged_large_blocks += bd->blocks;
+      if (new_stp != stp) { RELEASE_SPIN_LOCK(&new_stp->sync_large_objects); }
+  } else {
+      bd->link = ws->todo_large_objects;
+      ws->todo_large_objects = bd;
+  }
 
   RELEASE_SPIN_LOCK(&stp->sync_large_objects);
 }
@@ -356,7 +367,7 @@ loop:
 
   ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
 
-  if (!HEAP_ALLOCED(q)) {
+  if (!HEAP_ALLOCED_GC(q)) {
 
       if (!major_gc) return;
 
@@ -626,8 +637,6 @@ loop:
       return;
 
   case CAF_BLACKHOLE:
-  case SE_CAF_BLACKHOLE:
-  case SE_BLACKHOLE:
   case BLACKHOLE:
       copyPart(p,q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
       return;
@@ -774,7 +783,7 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val)
         // invoke eval_thunk_selector(), the recursive calls will not 
         // evacuate the value (because we want to select on the value,
         // not evacuate it), so in this case val is in from-space.
-        // ASSERT(!HEAP_ALLOCED(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
+        // ASSERT(!HEAP_ALLOCED_GC(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
 
         prev = (StgSelector*)((StgClosure *)p)->payload[0];
 
@@ -828,7 +837,7 @@ eval_thunk_selector (StgClosure **q, StgSelector * p, rtsBool evac)
 selector_chain:
 
     bd = Bdescr((StgPtr)p);
-    if (HEAP_ALLOCED(p)) {
+    if (HEAP_ALLOCED_GC(p)) {
         // If the THUNK_SELECTOR is in to-space or in a generation that we
         // are not collecting, then bale out early.  We won't be able to
         // save any space in any case, and updating with an indirection is
@@ -837,6 +846,11 @@ selector_chain:
         if (bd->flags & BF_EVACUATED) {
             unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
             *q = (StgClosure *)p;
+            // shortcut, behave as for:  if (evac) evacuate(q);
+            if (evac && bd->step < gct->evac_step) {
+                gct->failed_to_evac = rtsTrue;
+                TICK_GC_FAILED_PROMOTION();
+            }
             return;
         }
         // we don't update THUNK_SELECTORS in the compacted
@@ -940,8 +954,12 @@ selector_loop:
               // the original selector thunk, p.
               SET_INFO(p, (StgInfoTable *)info_ptr);
               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p);
+#if defined(THREADED_RTS)
+              SET_INFO(p, &stg_WHITEHOLE_info);
+#else
               SET_INFO(p, &stg_BLACKHOLE_info);
 #endif
+#endif
 
               // the closure in val is now the "value" of the
               // THUNK_SELECTOR in p.  However, val may itself be a
@@ -1033,8 +1051,6 @@ selector_loop:
       case THUNK_0_2:
       case THUNK_STATIC:
       case CAF_BLACKHOLE:
-      case SE_CAF_BLACKHOLE:
-      case SE_BLACKHOLE:
       case BLACKHOLE:
          // not evaluated yet 
          goto bale_out;