X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2Fsm%2FEvac.c;h=bbb7fe579596f4ba4e567e6deb0d2628ad759b43;hb=6bc92166180824bf046d31e378359e3c386150f9;hp=6bf0c56843c8032e5c7f150135f9bd540550fbec;hpb=890f5a1a6e70ff4021cd58463f5152f10c47b395;p=ghc-hetmet.git

diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 6bf0c56..bbb7fe5 100644
--- 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;
       }
     }
@@ -831,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
@@ -1027,8 +1036,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;