X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2Fsm%2FCompact.c;h=e55ae2b7c261efe0d125807b27bfa53d2542215b;hp=9f0a69d1d1258f89654ed51b0c44a5943ec20c89;hb=7effbbbbdfe7eb05c6402fa9337e358e7e9fadde;hpb=74ee9df9f9e79e7110e9d8541b84010f35c464c5

diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 9f0a69d..e55ae2b 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -13,16 +13,18 @@
 
 #include "PosixSource.h"
 #include "Rts.h"
+
+#include "Storage.h"
 #include "RtsUtils.h"
-#include "RtsFlags.h"
-#include "OSThreads.h"
 #include "BlockAlloc.h"
-#include "MBlock.h"
 #include "GC.h"
 #include "Compact.h"
 #include "Schedule.h"
 #include "Apply.h"
 #include "Trace.h"
+#include "Weak.h"
+#include "MarkWeak.h"
+#include "Stable.h"
 
 // Turn off inlining when debugging - it obfuscates things
 #ifdef DEBUG
@@ -166,7 +168,7 @@ loop:
     case 1:
     {
         StgWord r = *(StgPtr)(q-1);
-        ASSERT(LOOKS_LIKE_INFO_PTR(UNTAG_CLOSURE((StgClosure *)r)));
+        ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)UNTAG_CLOSURE((StgClosure *)r)));
         return r;
     }
     case 2:
@@ -490,6 +492,10 @@ update_fwd_large( bdescr *bd )
 
   for (; bd != NULL; bd = bd->link) {
 
+    // nothing to do in a pinned block; it might not even have an object
+    // at the beginning.
+    if (bd->flags & BF_PINNED) continue;
+
     p = bd->start;
     info  = get_itbl((StgClosure *)p);
 
@@ -505,13 +511,13 @@ update_fwd_large( bdescr *bd )
     case MUT_ARR_PTRS_FROZEN0:
       // follow everything 
       {
-	StgPtr next;
+          StgMutArrPtrs *a;
 
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
-	    thread((StgClosure **)p);
-	}
-	continue;
+          a = (StgMutArrPtrs*)p;
+          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
+              thread((StgClosure **)p);
+          }
+          continue;
       }
 
     case TSO:
@@ -621,8 +627,6 @@ thread_obj (StgInfoTable *info, StgPtr p)
     case MUT_VAR_CLEAN:
     case MUT_VAR_DIRTY:
     case CAF_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case SE_BLACKHOLE:
     case BLACKHOLE:
     {
 	StgPtr end;
@@ -638,6 +642,7 @@ thread_obj (StgInfoTable *info, StgPtr p)
     case WEAK:
     {
 	StgWeak *w = (StgWeak *)p;
+	thread(&w->cfinalizer);
 	thread(&w->key);
 	thread(&w->value);
 	thread(&w->finalizer);
@@ -687,13 +692,14 @@ thread_obj (StgInfoTable *info, StgPtr p)
     case MUT_ARR_PTRS_FROZEN0:
 	// follow everything 
     {
-	StgPtr next;
-	
-	next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
-	for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+        StgMutArrPtrs *a;
+
+        a = (StgMutArrPtrs *)p;
+	for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
 	    thread((StgClosure **)p);
 	}
-	return p;
+
+	return (StgPtr)a + mut_arr_ptrs_sizeW(a);
     }
     
     case TSO:
@@ -849,15 +855,15 @@ update_fwd_compact( bdescr *blocks )
 
 	    size = p - q;
 	    if (free + size > free_bd->start + BLOCK_SIZE_W) {
-		// unset the next bit in the bitmap to indicate that
+		// set the next bit in the bitmap to indicate that
 		// this object needs to be pushed into the next
 		// block.  This saves us having to run down the
 		// threaded info pointer list twice during the next pass.
-		unmark(q+1,bd);
+		mark(q+1,bd);
 		free_bd = free_bd->link;
 		free = free_bd->start;
 	    } else {
-		ASSERT(is_marked(q+1,bd));
+		ASSERT(!is_marked(q+1,bd));
 	    }
 
 	    unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
@@ -870,7 +876,7 @@ update_fwd_compact( bdescr *blocks )
 }
 
 static nat
-update_bkwd_compact( step *stp )
+update_bkwd_compact( generation *gen )
 {
     StgPtr p, free;
 #if 0
@@ -881,7 +887,7 @@ update_bkwd_compact( step *stp )
     nat size, free_blocks;
     StgWord iptr;
 
-    bd = free_bd = stp->old_blocks;
+    bd = free_bd = gen->old_blocks;
     free = free_bd->start;
     free_blocks = 1;
 
@@ -916,7 +922,7 @@ update_bkwd_compact( step *stp )
 	    }
 #endif
 
-	    if (!is_marked(p+1,bd)) {
+	    if (is_marked(p+1,bd)) {
 		// don't forget to update the free ptr in the block desc.
 		free_bd->free = free;
 		free_bd = free_bd->link;
@@ -926,7 +932,7 @@ update_bkwd_compact( step *stp )
 
             iptr = get_threaded_info(p);
 	    unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr));
-	    ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
+	    ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info));
 	    info = get_itbl((StgClosure *)p);
 	    size = closure_sizeW_((StgClosure *)p,info);
 
@@ -960,15 +966,12 @@ update_bkwd_compact( step *stp )
 void
 compact(StgClosure *static_objects)
 {
-    nat g, s, blocks;
-    step *stp;
+    nat g, blocks;
+    generation *gen;
 
     // 1. thread the roots
     markCapabilities((evac_fn)thread_root, NULL);
 
-    // spark queues
-    traverseSparkQueues((evac_fn)thread_root, NULL);
-
     // the weak pointer lists...
     if (weak_ptr_list != NULL) {
 	thread((void *)&weak_ptr_list);
@@ -981,28 +984,44 @@ compact(StgClosure *static_objects)
     for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
 	bdescr *bd;
 	StgPtr p;
+        nat n;
 	for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
 	    for (p = bd->start; p < bd->free; p++) {
 		thread((StgClosure **)p);
 	    }
 	}
+        for (n = 0; n < n_capabilities; n++) {
+            for (bd = capabilities[n].mut_lists[g]; 
+                 bd != NULL; bd = bd->link) {
+                for (p = bd->start; p < bd->free; p++) {
+                    thread((StgClosure **)p);
+                }
+            }
+        }
     }
 
     // the global thread list
-    for (s = 0; s < total_steps; s++) {
-        thread((void *)&all_steps[s].threads);
+    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+        thread((void *)&generations[g].threads);
     }
 
     // any threads resurrected during this GC
     thread((void *)&resurrected_threads);
 
+    // the blackhole queue
+    thread((void *)&blackhole_queue);
+
     // the task list
     {
 	Task *task;
+        InCall *incall;
 	for (task = all_tasks; task != NULL; task = task->all_link) {
-	    if (task->tso) {
-		thread_(&task->tso);
-	    }
+            for (incall = task->incall; incall != NULL; 
+                 incall = incall->prev_stack) {
+                if (incall->tso) {
+                    thread_(&incall->tso);
+                }
+            }
 	}
     }
 
@@ -1017,30 +1036,24 @@ compact(StgClosure *static_objects)
 
     // 2. update forward ptrs
     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-	for (s = 0; s < generations[g].n_steps; s++) {
-	    if (g==0 && s ==0) continue;
-	    stp = &generations[g].steps[s];
-	    debugTrace(DEBUG_gc, "update_fwd:  %d.%d", 
-		       stp->gen->no, stp->no);
-
-	    update_fwd(stp->blocks);
-	    update_fwd_large(stp->scavenged_large_objects);
-	    if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) {
-		debugTrace(DEBUG_gc, "update_fwd:  %d.%d (compact)",
-			   stp->gen->no, stp->no);
-		update_fwd_compact(stp->old_blocks);
-	    }
+        gen = &generations[g];
+        debugTrace(DEBUG_gc, "update_fwd:  %d", g);
+
+        update_fwd(gen->blocks);
+        update_fwd_large(gen->scavenged_large_objects);
+        if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) {
+            debugTrace(DEBUG_gc, "update_fwd:  %d (compact)", g);
+            update_fwd_compact(gen->old_blocks);
 	}
     }
 
     // 3. update backward ptrs
-    stp = &oldest_gen->steps[0];
-    if (stp->old_blocks != NULL) {
-	blocks = update_bkwd_compact(stp);
+    gen = oldest_gen;
+    if (gen->old_blocks != NULL) {
+	blocks = update_bkwd_compact(gen);
 	debugTrace(DEBUG_gc, 
-		   "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)",
-		   stp->gen->no, stp->no,
-		   stp->n_old_blocks, blocks);
-	stp->n_old_blocks = blocks;
+		   "update_bkwd: %d (compact, old: %d blocks, now %d blocks)",
+		   gen->no, gen->n_old_blocks, blocks);
+	gen->n_old_blocks = blocks;
     }
 }