[project @ 2004-08-13 10:42:34 by simonmar]

[ghc-hetmet.git] / ghc / rts / GC.c

diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 210f15c..98624b6 100644 (file)
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.165 2004/05/07 21:19:21 panne Exp $
+ * $Id: GC.c,v 1.167 2004/05/21 13:28:59 simonmar Exp $
  *
  * (c) The GHC Team 1998-2003
  *
@@ -447,11 +447,18 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
              // don't forget to fill it with zeros!
              memset(bitmap, 0, bitmap_size);
              
-             // for each block in this step, point to its bitmap from the
+             // For each block in this step, point to its bitmap from the
              // block descriptor.
              for (bd=stp->blocks; bd != NULL; bd = bd->link) {
                  bd->u.bitmap = bitmap;
                  bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
+
+                 // Also at this point we set the BF_COMPACTED flag
+                 // for this block.  The invariant is that
+                 // BF_COMPACTED is always unset, except during GC
+                 // when it is set on those blocks which will be
+                 // compacted.
+                 bd->flags |= BF_COMPACTED;
              }
          }
       }
@@ -753,8 +760,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
                // for a compacted step, just shift the new to-space
                // onto the front of the now-compacted existing blocks.
                for (bd = stp->to_blocks; bd != NULL; bd = bd->link) {
-                   bd->flags &= ~BF_EVACUATED; // now from-space 
-                   bd->flags |= BF_COMPACTED;  // compacted next time
+                   bd->flags &= ~BF_EVACUATED;  // now from-space 
                }
                // tack the new blocks on the end of the existing blocks
                if (stp->blocks == NULL) {
@@ -765,6 +771,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
                        if (next == NULL) {
                            bd->link = stp->to_blocks;
                        }
+                       // NB. this step might not be compacted next
+                       // time, so reset the BF_COMPACTED flags.
+                       // They are set before GC if we're going to
+                       // compact.  (search for BF_COMPACTED above).
+                       bd->flags &= ~BF_COMPACTED;
                    }
                }
                // add the new blocks to the block tally
@@ -774,7 +785,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
                stp->blocks = stp->to_blocks;
                stp->n_blocks = stp->n_to_blocks;
                for (bd = stp->blocks; bd != NULL; bd = bd->link) {
-                   bd->flags &= ~BF_EVACUATED; // now from-space 
+                   bd->flags &= ~BF_EVACUATED;  // now from-space 
                }
            }
            stp->to_blocks = NULL;
@@ -2014,13 +2025,28 @@ loop:
    thunk is unchanged.
    -------------------------------------------------------------------------- */
 
+static inline rtsBool
+is_to_space ( StgClosure *p )
+{
+    bdescr *bd;
+
+    bd = Bdescr((StgPtr)p);
+    if (HEAP_ALLOCED(p) &&
+       ((bd->flags & BF_EVACUATED) 
+        || ((bd->flags & BF_COMPACTED) &&
+            is_marked((P_)p,bd)))) {
+       return rtsTrue;
+    } else {
+       return rtsFalse;
+    }
+}    
+
 static StgClosure *
 eval_thunk_selector( nat field, StgSelector * p )
 {
     StgInfoTable *info;
     const StgInfoTable *info_ptr;
     StgClosure *selectee;
-    bdescr *bd;
     
     selectee = p->selectee;
 
@@ -2067,12 +2093,10 @@ selector_loop:
     //  point to to-space objects, because that happens when
     //  scavenging.
     //
-    bd = Bdescr((StgPtr)selectee);
-    if (HEAP_ALLOCED(selectee) &&
-       ((bd->flags & BF_EVACUATED) 
-        || ((bd->flags & BF_COMPACTED) &&
-            bd->gen_no <= N &&
-            is_marked((P_)selectee,bd)))) {
+    //  The to-space test is now embodied in the in_to_space() inline
+    //  function, as it is re-used below.
+    //
+    if (is_to_space(selectee)) {
        goto bale_out;
     }
 
@@ -2090,9 +2114,21 @@ selector_loop:
          ASSERT(field <  (StgWord32)(info->layout.payload.ptrs + 
                                      info->layout.payload.nptrs));
          
-         // ToDo: shouldn't we test whether this pointer is in
-         // to-space?
-         return selectee->payload[field];
+         // Select the right field from the constructor, and check
+         // that the result isn't in to-space.  It might be in
+         // to-space if, for example, this constructor contains
+         // pointers to younger-gen objects (and is on the mut-once
+         // list).
+         //
+         { 
+             StgClosure *q;
+             q = selectee->payload[field];
+             if (is_to_space(q)) {
+                 goto bale_out;
+             } else {
+                 return q;
+             }
+         }
 
       case IND:
       case IND_PERM: