X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=rts%2Fsm%2FStorage.c;h=f8a9e559bf6ea86e6dae3d5692e1eaced21c0cbe;hb=bba816223372c52fb586cda2e3f041d7791110a5;hp=6c1106567029305ee38b889a4e33c2beca27a29a;hpb=18896fa2b06844407fd1e0d3f85cd3db97a96ff4;p=ghc-hetmet.git

diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index 6c11065..f8a9e55 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -657,17 +657,32 @@ allocatePinned (Capability *cap, lnat n)
     // If we don't have a block of pinned objects yet, or the current
     // one isn't large enough to hold the new object, allocate a new one.
     if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
+        // The pinned_object_block remains attached to the capability
+        // until it is full, even if a GC occurs.  We want this
+        // behaviour because otherwise the unallocated portion of the
+        // block would be forever slop, and under certain workloads
+        // (allocating a few ByteStrings per GC) we accumulate a lot
+        // of slop.
+        //
+        // So, the pinned_object_block is initially marked
+        // BF_EVACUATED so the GC won't touch it.  When it is full,
+        // we place it on the large_objects list, and at the start of
+        // the next GC the BF_EVACUATED flag will be cleared, and the
+        // block will be promoted as usual (if anything in it is
+        // live).
         ACQUIRE_SM_LOCK;
-	cap->pinned_object_block = bd = allocBlock();
-	dbl_link_onto(bd, &g0->large_objects);
-	g0->n_large_blocks++;
+        if (bd != NULL) {
+            dbl_link_onto(bd, &g0->large_objects);
+            g0->n_large_blocks++;
+            g0->n_new_large_words += bd->free - bd->start;
+        }
+        cap->pinned_object_block = bd = allocBlock();
         RELEASE_SM_LOCK;
         initBdescr(bd, g0, g0);
-	bd->flags  = BF_PINNED | BF_LARGE;
+        bd->flags  = BF_PINNED | BF_LARGE | BF_EVACUATED;
 	bd->free   = bd->start;
     }
 
-    g0->n_new_large_words += n;
     p = bd->free;
     bd->free += n;
     return p;
@@ -835,8 +850,7 @@ lnat calcLiveWords (void)
 {
     nat g;
     lnat live;
-    generation *gen;
-    
+
     live = 0;
     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
         live += genLiveWords(&generations[g]);