[project @ 2003-03-24 15:33:25 by simonmar]

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

diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 89a709d..a0f119f 100644 (file)
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,7 +1,7 @@
 /* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.146 2002/12/11 15:36:42 simonmar Exp $
+ * $Id: GC.c,v 1.150 2003/03/24 15:33:25 simonmar Exp $
  *
- * (c) The GHC Team 1998-2002
+ * (c) The GHC Team 1998-2003
  *
  * Generational garbage collector
  *
@@ -20,7 +20,6 @@
 #include "Sanity.h"
 #include "BlockAlloc.h"
 #include "MBlock.h"
-#include "Main.h"
 #include "ProfHeap.h"
 #include "SchedAPI.h"
 #include "Weak.h"
@@ -1753,9 +1752,11 @@ loop:
   case WEAK:
   case FOREIGN:
   case STABLE_NAME:
-  case BCO:
     return copy(q,sizeW_fromITBL(info),stp);
 
+  case BCO:
+      return copy(q,bco_sizeW((StgBCO *)q),stp);
+
   case CAF_BLACKHOLE:
   case SE_CAF_BLACKHOLE:
   case SE_BLACKHOLE:
@@ -2001,6 +2002,24 @@ eval_thunk_selector( nat field, StgSelector * p )
 
 selector_loop:
 
+    // We don't want to end up in to-space, because this causes
+    // problems when the GC later tries to evacuate the result of
+    // eval_thunk_selector().  There are various ways this could
+    // happen:
+    //
+    // - following an IND_STATIC
+    //
+    // - when the old generation is compacted, the mark phase updates
+    //   from-space pointers to be to-space pointers, and we can't
+    //   reliably tell which we're following (eg. from an IND_STATIC).
+    // 
+    // So we use the block-descriptor test to find out if we're in
+    // to-space.
+    //
+    if (Bdescr((StgPtr)selectee)->flags & BF_EVACUATED) {
+       goto bale_out;
+    }
+
     info = get_itbl(selectee);
     switch (info->type) {
       case CONSTR:
@@ -2015,12 +2034,15 @@ 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];
 
       case IND:
       case IND_PERM:
       case IND_OLDGEN:
       case IND_OLDGEN_PERM:
+      case IND_STATIC:
          selectee = ((StgInd *)selectee)->indirectee;
          goto selector_loop;
 
@@ -2030,11 +2052,6 @@ selector_loop:
          // leaks by evaluating this selector thunk anyhow.
          break;
 
-      case IND_STATIC:
-         // We can't easily tell whether the indirectee is into 
-         // from or to-space, so just bail out here.
-         break;
-
       case THUNK_SELECTOR:
       {
          StgClosure *val;
@@ -2059,8 +2076,19 @@ selector_loop:
              // because we are guaranteed that p is in a generation
              // that we are collecting, and we never want to put the
              // indirection on a mutable list.
+#ifdef PROFILING
+             // For the purposes of LDV profiling, we have destroyed
+             // the original selector thunk.
+             SET_INFO(p, info_ptr);
+             LDV_recordDead_FILL_SLOP_DYNAMIC(selectee);
+#endif
              ((StgInd *)selectee)->indirectee = val;
              SET_INFO(selectee,&stg_IND_info);
+#ifdef PROFILING
+             // For the purposes of LDV profiling, we have created an
+             // indirection.
+             LDV_recordCreate(selectee);
+#endif
              selectee = val;
              goto selector_loop;
          }
@@ -2096,6 +2124,7 @@ selector_loop:
             (int)(info->type));
     }
 
+bale_out:
     // We didn't manage to evaluate this thunk; restore the old info pointer
     SET_INFO(p, info_ptr);
     return NULL;
@@ -2428,7 +2457,6 @@ scavenge(step *stp)
     case WEAK:
     case FOREIGN:
     case STABLE_NAME:
-    case BCO:
     {
        StgPtr end;
 
@@ -2440,6 +2468,16 @@ scavenge(step *stp)
        break;
     }
 
+    case BCO: {
+       StgBCO *bco = (StgBCO *)p;
+       (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+       (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+       (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+       (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+       p += bco_sizeW(bco);
+       break;
+    }
+
     case IND_PERM:
       if (stp->gen->no != 0) {
 #ifdef PROFILING
@@ -2757,7 +2795,6 @@ linear_scan:
        case WEAK:
        case FOREIGN:
        case STABLE_NAME:
-       case BCO:
        {
            StgPtr end;
            
@@ -2768,6 +2805,15 @@ linear_scan:
            break;
        }
 
+       case BCO: {
+           StgBCO *bco = (StgBCO *)p;
+           (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+           (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+           (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+           (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+           break;
+       }
+
        case IND_PERM:
            // don't need to do anything here: the only possible case
            // is that we're in a 1-space compacting collector, with