fix an assertion failure in prof/threaded/debug mode

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

diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index ab20470..1c453fc 100644 (file)
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -165,7 +165,7 @@ copy_tag_nolock(StgClosure **p, const StgInfoTable *info,
  * pointer of an object, but reserve some padding after it.  This is
  * used to optimise evacuation of BLACKHOLEs.
  */
-static void
+static rtsBool
 copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, nat size_to_copy, step *stp)
 {
     StgPtr to, from;
@@ -184,7 +184,7 @@ spin:
     if (IS_FORWARDING_PTR(info)) {
        src->header.info = (const StgInfoTable *)info;
        evacuate(p); // does the failed_to_evac stuff
-       return ;
+       return rtsFalse;
     }
 #else
     info = (W_)src->header.info;
@@ -212,8 +212,10 @@ 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;
 }
 
 
@@ -624,8 +626,6 @@ loop:
       return;
 
   case CAF_BLACKHOLE:
-  case SE_CAF_BLACKHOLE:
-  case SE_BLACKHOLE:
   case BLACKHOLE:
       copyPart(p,q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
       return;
@@ -697,14 +697,18 @@ loop:
       {
          StgTSO *new_tso;
          StgPtr r, s;
-
-         copyPart(p,(StgClosure *)tso, tso_sizeW(tso), sizeofW(StgTSO), stp);
-         new_tso = (StgTSO *)*p;
-         move_TSO(tso, new_tso);
-         for (r = tso->sp, s = new_tso->sp;
-              r < tso->stack+tso->stack_size;) {
-             *s++ = *r++;
-         }
+          rtsBool mine;
+
+         mine = copyPart(p,(StgClosure *)tso, tso_sizeW(tso), 
+                          sizeofW(StgTSO), stp);
+          if (mine) {
+              new_tso = (StgTSO *)*p;
+              move_TSO(tso, new_tso);
+              for (r = tso->sp, s = new_tso->sp;
+                   r < tso->stack+tso->stack_size;) {
+                  *s++ = *r++;
+              }
+          }
          return;
       }
     }
@@ -773,14 +777,25 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val)
         prev = (StgSelector*)((StgClosure *)p)->payload[0];
 
         // Update the THUNK_SELECTOR with an indirection to the
-        // EVACUATED closure now at p.  Why do this rather than
-        // upd_evacuee(q,p)?  Because we have an invariant that an
-        // EVACUATED closure always points to an object in the
-        // same or an older generation (required by the short-cut
-        // test in the EVACUATED case, below).
-        ((StgInd *)p)->indirectee = val;
-        write_barrier();
-        SET_INFO(p, &stg_IND_info);
+        // value.  The value is still in from-space at this stage.
+        //
+        // (old note: Why not do upd_evacuee(q,p)?  Because we have an
+        // invariant that an EVACUATED closure always points to an
+        // object in the same or an older generation (required by
+        // the short-cut test in the EVACUATED case, below).
+        if ((StgClosure *)p == val) {
+            // must be a loop; just leave a BLACKHOLE in place.  This
+            // can happen when we have a chain of selectors that
+            // eventually loops back on itself.  We can't leave an
+            // indirection pointing to itself, and we want the program
+            // to deadlock if it ever enters this closure, so
+            // BLACKHOLE is correct.
+            SET_INFO(p, &stg_BLACKHOLE_info);
+        } else {
+            ((StgInd *)p)->indirectee = val;
+            write_barrier();
+            SET_INFO(p, &stg_IND_info);
+        }
 
         // For the purposes of LDV profiling, we have created an
         // indirection.
@@ -820,6 +835,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
@@ -923,8 +943,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
@@ -957,12 +981,18 @@ selector_loop:
               prev_thunk_selector = p;
 
               *q = val;
-              if (evac) evacuate(q);
-              val = *q;
+
+              // update the other selectors in the chain *before*
+              // evacuating the value.  This is necessary in the case
+              // where the value turns out to be one of the selectors
+              // in the chain (i.e. we have a loop), and evacuating it
+              // would corrupt the chain.
+              unchain_thunk_selectors(prev_thunk_selector, val);
+
               // evacuate() cannot recurse through
               // eval_thunk_selector(), because we know val is not
               // a THUNK_SELECTOR.
-              unchain_thunk_selectors(prev_thunk_selector, val);
+              if (evac) evacuate(q);
               return;
           }
 
@@ -1010,8 +1040,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;