GC.c

/* -----------------------------------------------------------------------------
 * $Id: GC.c,v 1.41 1999/02/24 17:24:07 simonm Exp $
 *
 * (c) The GHC Team 1998-1999
 *
 * Generational garbage collector
 *
 * ---------------------------------------------------------------------------*/

#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
#include "Storage.h"
#include "StoragePriv.h"
#include "Stats.h"
#include "Schedule.h"
#include "SchedAPI.h" /* for ReverCAFs prototype */
#include "Sanity.h"
#include "GC.h"
#include "BlockAlloc.h"
#include "Main.h"
#include "DebugProf.h"
#include "SchedAPI.h"
#include "Weak.h"
#include "StablePriv.h"

StgCAF* enteredCAFs;

/* STATIC OBJECT LIST.
 *
 * During GC:
 * We maintain a linked list of static objects that are still live.
 * The requirements for this list are:
 *
 *  - we need to scan the list while adding to it, in order to
 *    scavenge all the static objects (in the same way that
 *    breadth-first scavenging works for dynamic objects).
 *
 *  - we need to be able to tell whether an object is already on
 *    the list, to break loops.
 *
 * Each static object has a "static link field", which we use for
 * linking objects on to the list.  We use a stack-type list, consing
 * objects on the front as they are added (this means that the
 * scavenge phase is depth-first, not breadth-first, but that
 * shouldn't matter).  
 *
 * A separate list is kept for objects that have been scavenged
 * already - this is so that we can zero all the marks afterwards.
 *
 * An object is on the list if its static link field is non-zero; this
 * means that we have to mark the end of the list with '1', not NULL.  
 *
 * Extra notes for generational GC:
 *
 * Each generation has a static object list associated with it.  When
 * collecting generations up to N, we treat the static object lists
 * from generations > N as roots.
 *
 * We build up a static object list while collecting generations 0..N,
 * which is then appended to the static object list of generation N+1.
 */
StgClosure* static_objects;	      /* live static objects */
StgClosure* scavenged_static_objects; /* static objects scavenged so far */

/* N is the oldest generation being collected, where the generations
 * are numbered starting at 0.  A major GC (indicated by the major_gc
 * flag) is when we're collecting all generations.  We only attempt to
 * deal with static objects and GC CAFs when doing a major GC.
 */
static nat N;
static rtsBool major_gc;

/* Youngest generation that objects should be evacuated to in
 * evacuate().  (Logically an argument to evacuate, but it's static
 * a lot of the time so we optimise it into a global variable).
 */
static nat evac_gen;

/* WEAK POINTERS
 */
static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
static rtsBool weak_done;	/* all done for this pass */

/* Flag indicating failure to evacuate an object to the desired
 * generation.
 */
static rtsBool failed_to_evac;

/* Old to-space (used for two-space collector only)
 */
bdescr *old_to_space;

/* Data used for allocation area sizing.
 */
lnat new_blocks;		/* blocks allocated during this GC */
lnat g0s0_pcnt_kept = 30;	/* percentage of g0s0 live at last minor GC */

/* -----------------------------------------------------------------------------
   Static function declarations
   -------------------------------------------------------------------------- */

static StgClosure *evacuate(StgClosure *q);
static void    zeroStaticObjectList(StgClosure* first_static);
static rtsBool traverse_weak_ptr_list(void);
static void    zeroMutableList(StgMutClosure *first);
static void    revertDeadCAFs(void);

static void           scavenge_stack(StgPtr p, StgPtr stack_end);
static void           scavenge_large(step *step);
static void           scavenge(step *step);
static void           scavenge_static(void);
static void           scavenge_mutable_list(generation *g);
static void           scavenge_mut_once_list(generation *g);

#ifdef DEBUG
static void gcCAFs(void);
#endif

/* -----------------------------------------------------------------------------
   GarbageCollect

   For garbage collecting generation N (and all younger generations):

     - follow all pointers in the root set.  the root set includes all 
       mutable objects in all steps in all generations.

     - for each pointer, evacuate the object it points to into either
       + to-space in the next higher step in that generation, if one exists,
       + if the object's generation == N, then evacuate it to the next
         generation if one exists, or else to-space in the current
	 generation.
       + if the object's generation < N, then evacuate it to to-space
         in the next generation.

     - repeatedly scavenge to-space from each step in each generation
       being collected until no more objects can be evacuated.
      
     - free from-space in each step, and set from-space = to-space.

   -------------------------------------------------------------------------- */

void GarbageCollect(void (*get_roots)(void))
{
  bdescr *bd;
  step *step;
  lnat live, allocated, collected = 0, copied = 0;
  nat g, s;

#ifdef PROFILING
  CostCentreStack *prev_CCS;
#endif

  /* tell the stats department that we've started a GC */
  stat_startGC();

  /* attribute any costs to CCS_GC */
#ifdef PROFILING
  prev_CCS = CCCS;
  CCCS = CCS_GC;
#endif

  /* We might have been called from Haskell land by _ccall_GC, in
   * which case we need to call threadPaused() because the scheduler
   * won't have done it.
   */
  if (CurrentTSO) { threadPaused(CurrentTSO); }

  /* Approximate how much we allocated: number of blocks in the
   * nursery + blocks allocated via allocate() - unused nusery blocks.
   * This leaves a little slop at the end of each block, and doesn't
   * take into account large objects (ToDo).
   */
  allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
  for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
    allocated -= BLOCK_SIZE_W;
  }

  /* Figure out which generation to collect
   */
  N = 0;
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
    if (generations[g].steps[0].n_blocks >= generations[g].max_blocks) {
      N = g;
    }
  }
  major_gc = (N == RtsFlags.GcFlags.generations-1);

  /* check stack sanity *before* GC (ToDo: check all threads) */
  /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
  IF_DEBUG(sanity, checkFreeListSanity());

  /* Initialise the static object lists
   */
  static_objects = END_OF_STATIC_LIST;
  scavenged_static_objects = END_OF_STATIC_LIST;

  /* zero the mutable list for the oldest generation (see comment by
   * zeroMutableList below).
   */
  if (major_gc) { 
    zeroMutableList(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
  }

  /* Save the old to-space if we're doing a two-space collection
   */
  if (RtsFlags.GcFlags.generations == 1) {
    old_to_space = g0s0->to_space;
    g0s0->to_space = NULL;
  }

  /* Keep a count of how many new blocks we allocated during this GC
   * (used for resizing the allocation area, later).
   */
  new_blocks = 0;

  /* Initialise to-space in all the generations/steps that we're
   * collecting.
   */
  for (g = 0; g <= N; g++) {
    generations[g].mut_once_list = END_MUT_LIST;
    generations[g].mut_list = END_MUT_LIST;

    for (s = 0; s < generations[g].n_steps; s++) {

      /* generation 0, step 0 doesn't need to-space */
      if (g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1) { 
	continue; 
      }

      /* Get a free block for to-space.  Extra blocks will be chained on
       * as necessary.
       */
      bd = allocBlock();
      step = &generations[g].steps[s];
      ASSERT(step->gen->no == g);
      ASSERT(step->hp ? Bdescr(step->hp)->step == step : rtsTrue);
      bd->gen  = &generations[g];
      bd->step = step;
      bd->link = NULL;
      bd->evacuated = 1;	/* it's a to-space block */
      step->hp        = bd->start;
      step->hpLim     = step->hp + BLOCK_SIZE_W;
      step->hp_bd     = bd;
      step->to_space  = bd;
      step->to_blocks = 1;
      step->scan      = bd->start;
      step->scan_bd   = bd;
      step->new_large_objects = NULL;
      step->scavenged_large_objects = NULL;
      new_blocks++;
      /* mark the large objects as not evacuated yet */
      for (bd = step->large_objects; bd; bd = bd->link) {
	bd->evacuated = 0;
      }
    }
  }

  /* make sure the older generations have at least one block to
   * allocate into (this makes things easier for copy(), see below.
   */
  for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
    for (s = 0; s < generations[g].n_steps; s++) {
      step = &generations[g].steps[s];
      if (step->hp_bd == NULL) {
	bd = allocBlock();
	bd->gen = &generations[g];
	bd->step = step;
	bd->link = NULL;
	bd->evacuated = 0;	/* *not* a to-space block */
	step->hp = bd->start;
	step->hpLim = step->hp + BLOCK_SIZE_W;
	step->hp_bd = bd;
	step->blocks = bd;
	step->n_blocks = 1;
	new_blocks++;
      }
      /* Set the scan pointer for older generations: remember we
       * still have to scavenge objects that have been promoted. */
      step->scan = step->hp;
      step->scan_bd = step->hp_bd;
      step->to_space = NULL;
      step->to_blocks = 0;
      step->new_large_objects = NULL;
      step->scavenged_large_objects = NULL;
    }
  }

  /* -----------------------------------------------------------------------
   * follow all the roots that we know about:
   *   - mutable lists from each generation > N
   * we want to *scavenge* these roots, not evacuate them: they're not
   * going to move in this GC.
   * Also: do them in reverse generation order.  This is because we
   * often want to promote objects that are pointed to by older
   * generations early, so we don't have to repeatedly copy them.
   * Doing the generations in reverse order ensures that we don't end
   * up in the situation where we want to evac an object to gen 3 and
   * it has already been evaced to gen 2.
   */
  { 
    int st;
    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
      generations[g].saved_mut_list = generations[g].mut_list;
      generations[g].mut_list = END_MUT_LIST;
    }

    /* Do the mut-once lists first */
    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
      scavenge_mut_once_list(&generations[g]);
      evac_gen = g;
      for (st = generations[g].n_steps-1; st >= 0; st--) {
	scavenge(&generations[g].steps[st]);
      }
    }

    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
      scavenge_mutable_list(&generations[g]);
      evac_gen = g;
      for (st = generations[g].n_steps-1; st >= 0; st--) {
	scavenge(&generations[g].steps[st]);
      }
    }
  }

  /* follow all the roots that the application knows about.
   */
  evac_gen = 0;
  get_roots();

  /* And don't forget to mark the TSO if we got here direct from
   * Haskell! */
  if (CurrentTSO) {
    CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
  }

  /* Mark the weak pointer list, and prepare to detect dead weak
   * pointers.
   */
  markWeakList();
  old_weak_ptr_list = weak_ptr_list;
  weak_ptr_list = NULL;
  weak_done = rtsFalse;

  /* Mark the stable pointer table.
   */
  markStablePtrTable(major_gc);

#ifdef INTERPRETER
  { 
      /* ToDo: To fix the caf leak, we need to make the commented out
       * parts of this code do something sensible - as described in 
       * the CAF document.
       */
      extern void markHugsObjects(void);
#if 0
      /* ToDo: This (undefined) function should contain the scavenge
       * loop immediately below this block of code - but I'm not sure
       * enough of the details to do this myself.
       */
      scavengeEverything();
      /* revert dead CAFs and update enteredCAFs list */
      revertDeadCAFs();
#endif      
      markHugsObjects();
#if 0
      /* This will keep the CAFs and the attached BCOs alive 
       * but the values will have been reverted
       */
      scavengeEverything();
#endif
  }
#endif

  /* -------------------------------------------------------------------------
   * Repeatedly scavenge all the areas we know about until there's no
   * more scavenging to be done.
   */
  { 
    rtsBool flag;
  loop:
    flag = rtsFalse;

    /* scavenge static objects */
    if (major_gc && static_objects != END_OF_STATIC_LIST) {
      scavenge_static();
    }

    /* When scavenging the older generations:  Objects may have been
     * evacuated from generations <= N into older generations, and we
     * need to scavenge these objects.  We're going to try to ensure that
     * any evacuations that occur move the objects into at least the
     * same generation as the object being scavenged, otherwise we
     * have to create new entries on the mutable list for the older
     * generation.
     */

    /* scavenge each step in generations 0..maxgen */
    { 
      int gen, st; 
    loop2:
      for (gen = RtsFlags.GcFlags.generations-1; gen >= 0; gen--) {
	for (st = generations[gen].n_steps-1; st >= 0 ; st--) {
	  if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) { 
	    continue; 
	  }
	  step = &generations[gen].steps[st];
	  evac_gen = gen;
	  if (step->hp_bd != step->scan_bd || step->scan < step->hp) {
	    scavenge(step);
	    flag = rtsTrue;
	    goto loop2;
	  }
	  if (step->new_large_objects != NULL) {
	    scavenge_large(step);
	    flag = rtsTrue;
	    goto loop2;
	  }
	}
      }
    }
    if (flag) { goto loop; }

    /* must be last... */
    if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
      goto loop;
    }
  }

  /* Now see which stable names are still alive
   */
  gcStablePtrTable(major_gc);

  /* Set the maximum blocks for the oldest generation, based on twice
   * the amount of live data now, adjusted to fit the maximum heap
   * size if necessary.  
   *
   * This is an approximation, since in the worst case we'll need
   * twice the amount of live data plus whatever space the other
   * generations need.
   */
  if (RtsFlags.GcFlags.generations > 1) {
    if (major_gc) {
      oldest_gen->max_blocks = 
	stg_max(oldest_gen->steps[0].to_blocks * RtsFlags.GcFlags.oldGenFactor,
		RtsFlags.GcFlags.minOldGenSize);
      if (oldest_gen->max_blocks > RtsFlags.GcFlags.maxHeapSize / 2) {
	oldest_gen->max_blocks = RtsFlags.GcFlags.maxHeapSize / 2;
	if (((int)oldest_gen->max_blocks - 
	     (int)oldest_gen->steps[0].to_blocks) < 
	    (RtsFlags.GcFlags.pcFreeHeap *
	     RtsFlags.GcFlags.maxHeapSize / 200)) {
	  heapOverflow();
	}
      }
    }
  }

  /* run through all the generations/steps and tidy up 
   */
  copied = new_blocks * BLOCK_SIZE_W;
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {

    if (g <= N) {
      generations[g].collections++; /* for stats */
    }

    for (s = 0; s < generations[g].n_steps; s++) {
      bdescr *next;
      step = &generations[g].steps[s];

      if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
	/* Tidy the end of the to-space chains */
	step->hp_bd->free = step->hp;
	step->hp_bd->link = NULL;
	/* stats information: how much we copied */
	if (g <= N) {
	  copied -= step->hp_bd->start + BLOCK_SIZE_W -
	    step->hp_bd->free;
	}
      }

      /* for generations we collected... */
      if (g <= N) {

	collected += step->n_blocks * BLOCK_SIZE_W; /* for stats */

	/* free old memory and shift to-space into from-space for all
	 * the collected steps (except the allocation area).  These
	 * freed blocks will probaby be quickly recycled.
	 */
	if (!(g == 0 && s == 0)) {
	  freeChain(step->blocks);
	  step->blocks = step->to_space;
	  step->n_blocks = step->to_blocks;
	  step->to_space = NULL;
	  step->to_blocks = 0;
	  for (bd = step->blocks; bd != NULL; bd = bd->link) {
	    bd->evacuated = 0;	/* now from-space */
	  }
	}

	/* LARGE OBJECTS.  The current live large objects are chained on
	 * scavenged_large, having been moved during garbage
	 * collection from large_objects.  Any objects left on
	 * large_objects list are therefore dead, so we free them here.
	 */
	for (bd = step->large_objects; bd != NULL; bd = next) {
	  next = bd->link;
	  freeGroup(bd);
	  bd = next;
	}
	for (bd = step->scavenged_large_objects; bd != NULL; bd = bd->link) {
	  bd->evacuated = 0;
	}
	step->large_objects = step->scavenged_large_objects;

	/* Set the maximum blocks for this generation, interpolating
	 * between the maximum size of the oldest and youngest
	 * generations.
	 *
	 * max_blocks =    oldgen_max_blocks * G
	 *                 ----------------------
	 *                      oldest_gen
	 */
	if (g != 0) {
#if 0
	  generations[g].max_blocks = (oldest_gen->max_blocks * g)
	       / (RtsFlags.GcFlags.generations-1);
#endif
	  generations[g].max_blocks = oldest_gen->max_blocks;
	}

      /* for older generations... */
      } else {
	
	/* For older generations, we need to append the
	 * scavenged_large_object list (i.e. large objects that have been
	 * promoted during this GC) to the large_object list for that step.
	 */
	for (bd = step->scavenged_large_objects; bd; bd = next) {
	  next = bd->link;
	  bd->evacuated = 0;
	  dbl_link_onto(bd, &step->large_objects);
	}

	/* add the new blocks we promoted during this GC */
	step->n_blocks += step->to_blocks;
      }
    }
  }
  
  /* Guess the amount of live data for stats. */
  live = calcLive();

  /* Free the small objects allocated via allocate(), since this will
   * all have been copied into G0S1 now.  
   */
  if (small_alloc_list != NULL) {
    freeChain(small_alloc_list);
  }
  small_alloc_list = NULL;
  alloc_blocks = 0;
  alloc_Hp = NULL;
  alloc_HpLim = NULL;
  alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;

  /* Two-space collector:
   * Free the old to-space, and estimate the amount of live data.
   */
  if (RtsFlags.GcFlags.generations == 1) {
    nat blocks;
    
    if (old_to_space != NULL) {
      freeChain(old_to_space);
    }
    for (bd = g0s0->to_space; bd != NULL; bd = bd->link) {
      bd->evacuated = 0;	/* now from-space */
    }

    /* For a two-space collector, we need to resize the nursery. */
    
    /* set up a new nursery.  Allocate a nursery size based on a
     * function of the amount of live data (currently a factor of 2,
     * should be configurable (ToDo)).  Use the blocks from the old
     * nursery if possible, freeing up any left over blocks.
     *
     * If we get near the maximum heap size, then adjust our nursery
     * size accordingly.  If the nursery is the same size as the live
     * data (L), then we need 3L bytes.  We can reduce the size of the
     * nursery to bring the required memory down near 2L bytes.
     * 
     * A normal 2-space collector would need 4L bytes to give the same
     * performance we get from 3L bytes, reducing to the same
     * performance at 2L bytes.  
     */
    blocks = g0s0->to_blocks;

    if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 > 
	 RtsFlags.GcFlags.maxHeapSize ) {
      int adjusted_blocks;  /* signed on purpose */
      int pc_free; 
      
      adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
      IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
      pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
      if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
	heapOverflow();
      }
      blocks = adjusted_blocks;
      
    } else {
      blocks *= RtsFlags.GcFlags.oldGenFactor;
      if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
	blocks = RtsFlags.GcFlags.minAllocAreaSize;
      }
    }
    resizeNursery(blocks);
    
  } else {
    /* Generational collector:
     * If the user has given us a suggested heap size, adjust our
     * allocation area to make best use of the memory available.
     */

    if (RtsFlags.GcFlags.heapSizeSuggestion) {
      int blocks;
      nat needed = calcNeeded(); 	/* approx blocks needed at next GC */

      /* Guess how much will be live in generation 0 step 0 next time.
       * A good approximation is the obtained by finding the
       * percentage of g0s0 that was live at the last minor GC.
       */
      if (N == 0) {
	g0s0_pcnt_kept = (new_blocks * 100) / g0s0->n_blocks;
      }

      /* Estimate a size for the allocation area based on the
       * information available.  We might end up going slightly under
       * or over the suggested heap size, but we should be pretty
       * close on average.
       *
       * Formula:            suggested - needed
       *                ----------------------------
       *                    1 + g0s0_pcnt_kept/100
       *
       * where 'needed' is the amount of memory needed at the next
       * collection for collecting all steps except g0s0.
       */
      blocks = 
	(((int)RtsFlags.GcFlags.heapSizeSuggestion - (int)needed) * 100) /
	(100 + (int)g0s0_pcnt_kept);
      
      if (blocks < (int)RtsFlags.GcFlags.minAllocAreaSize) {
	blocks = RtsFlags.GcFlags.minAllocAreaSize;
      }
      
      resizeNursery((nat)blocks);
    }
  }

  /* revert dead CAFs and update enteredCAFs list */
  revertDeadCAFs();
  
  /* mark the garbage collected CAFs as dead */
#ifdef DEBUG
  if (major_gc) { gcCAFs(); }
#endif
  
  /* zero the scavenged static object list */
  if (major_gc) {
    zeroStaticObjectList(scavenged_static_objects);
  }

  /* Reset the nursery
   */
  for (bd = g0s0->blocks; bd; bd = bd->link) {
    bd->free = bd->start;
    ASSERT(bd->gen == g0);
    ASSERT(bd->step == g0s0);
    IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
  }
  current_nursery = g0s0->blocks;

  /* start any pending finalizers */
  scheduleFinalizers(old_weak_ptr_list);
  
  /* check sanity after GC */
  IF_DEBUG(sanity, checkSanity(N));

  /* extra GC trace info */
  IF_DEBUG(gc, stat_describe_gens());

#ifdef DEBUG
  /* symbol-table based profiling */
  /*  heapCensus(to_space); */ /* ToDo */
#endif

  /* restore enclosing cost centre */
#ifdef PROFILING
  CCCS = prev_CCS;
#endif

  /* check for memory leaks if sanity checking is on */
  IF_DEBUG(sanity, memInventory());

  /* ok, GC over: tell the stats department what happened. */
  stat_endGC(allocated, collected, live, copied, N);
}

/* -----------------------------------------------------------------------------
   Weak Pointers

   traverse_weak_ptr_list is called possibly many times during garbage
   collection.  It returns a flag indicating whether it did any work
   (i.e. called evacuate on any live pointers).

   Invariant: traverse_weak_ptr_list is called when the heap is in an
   idempotent state.  That means that there are no pending
   evacuate/scavenge operations.  This invariant helps the weak
   pointer code decide which weak pointers are dead - if there are no
   new live weak pointers, then all the currently unreachable ones are
   dead.

   For generational GC: we just don't try to finalize weak pointers in
   older generations than the one we're collecting.  This could
   probably be optimised by keeping per-generation lists of weak
   pointers, but for a few weak pointers this scheme will work.
   -------------------------------------------------------------------------- */

static rtsBool 
traverse_weak_ptr_list(void)
{
  StgWeak *w, **last_w, *next_w;
  StgClosure *new;
  rtsBool flag = rtsFalse;

  if (weak_done) { return rtsFalse; }

  /* doesn't matter where we evacuate values/finalizers to, since
   * these pointers are treated as roots (iff the keys are alive).
   */
  evac_gen = 0;

  last_w = &old_weak_ptr_list;
  for (w = old_weak_ptr_list; w; w = next_w) {

    if ((new = isAlive(w->key))) {
      w->key = new;
      /* evacuate the value and finalizer */
      w->value = evacuate(w->value);
      w->finalizer = evacuate(w->finalizer);
      /* remove this weak ptr from the old_weak_ptr list */
      *last_w = w->link;
      /* and put it on the new weak ptr list */
      next_w  = w->link;
      w->link = weak_ptr_list;
      weak_ptr_list = w;
      flag = rtsTrue;
      IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
      continue;
    }
    else {
      last_w = &(w->link);
      next_w = w->link;
      continue;
    }
  }
  
  /* If we didn't make any changes, then we can go round and kill all
   * the dead weak pointers.  The old_weak_ptr list is used as a list
   * of pending finalizers later on.
   */
  if (flag == rtsFalse) {
    for (w = old_weak_ptr_list; w; w = w->link) {
      w->value = evacuate(w->value);
      w->finalizer = evacuate(w->finalizer);
    }
    weak_done = rtsTrue;
  }

  return rtsTrue;
}

/* -----------------------------------------------------------------------------
   isAlive determines whether the given closure is still alive (after
   a garbage collection) or not.  It returns the new address of the
   closure if it is alive, or NULL otherwise.
   -------------------------------------------------------------------------- */

StgClosure *
isAlive(StgClosure *p)
{
  StgInfoTable *info;

  while (1) {

    info = get_itbl(p);

    /* ToDo: for static closures, check the static link field.
     * Problem here is that we sometimes don't set the link field, eg.
     * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
     */

    /* ignore closures in generations that we're not collecting. */
    if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
      return p;
    }
    
    switch (info->type) {
      
    case IND:
    case IND_STATIC:
    case IND_PERM:
    case IND_OLDGEN:		/* rely on compatible layout with StgInd */
    case IND_OLDGEN_PERM:
      /* follow indirections */
      p = ((StgInd *)p)->indirectee;
      continue;
      
    case EVACUATED:
      /* alive! */
      return ((StgEvacuated *)p)->evacuee;

    default:
      /* dead. */
      return NULL;
    }
  }
}

StgClosure *
MarkRoot(StgClosure *root)
{
  return evacuate(root);
}

static void addBlock(step *step)
{
  bdescr *bd = allocBlock();
  bd->gen = step->gen;
  bd->step = step;

  if (step->gen->no <= N) {
    bd->evacuated = 1;
  } else {
    bd->evacuated = 0;
  }

  step->hp_bd->free = step->hp;
  step->hp_bd->link = bd;
  step->hp = bd->start;
  step->hpLim = step->hp + BLOCK_SIZE_W;
  step->hp_bd = bd;
  step->to_blocks++;
  new_blocks++;
}

static __inline__ StgClosure *
copy(StgClosure *src, nat size, step *step)
{
  P_ to, from, dest;

  TICK_GC_WORDS_COPIED(size);
  /* Find out where we're going, using the handy "to" pointer in 
   * the step of the source object.  If it turns out we need to
   * evacuate to an older generation, adjust it here (see comment
   * by evacuate()).
   */
  if (step->gen->no < evac_gen) {
#ifdef NO_EAGER_PROMOTION    
    failed_to_evac = rtsTrue;
#else
    step = &generations[evac_gen].steps[0];
#endif
  }

  /* chain a new block onto the to-space for the destination step if
   * necessary.
   */
  if (step->hp + size >= step->hpLim) {
    addBlock(step);
  }

  for(to = step->hp, from = (P_)src; size>0; --size) {
    *to++ = *from++;
  }

  dest = step->hp;
  step->hp = to;
  return (StgClosure *)dest;
}

/* Special version of copy() for when we only want to copy the info
 * pointer of an object, but reserve some padding after it.  This is
 * used to optimise evacuation of BLACKHOLEs.
 */

static __inline__ StgClosure *
copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
{
  P_ dest, to, from;

  TICK_GC_WORDS_COPIED(size_to_copy);
  if (step->gen->no < evac_gen) {
#ifdef NO_EAGER_PROMOTION    
    failed_to_evac = rtsTrue;
#else
    step = &generations[evac_gen].steps[0];
#endif
  }

  if (step->hp + size_to_reserve >= step->hpLim) {
    addBlock(step);
  }

  for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
    *to++ = *from++;
  }
  
  dest = step->hp;
  step->hp += size_to_reserve;
  return (StgClosure *)dest;
}

static __inline__ void 
upd_evacuee(StgClosure *p, StgClosure *dest)
{
  StgEvacuated *q = (StgEvacuated *)p;

  SET_INFO(q,&EVACUATED_info);
  q->evacuee = dest;
}

/* -----------------------------------------------------------------------------
   Evacuate a large object

   This just consists of removing the object from the (doubly-linked)
   large_alloc_list, and linking it on to the (singly-linked)
   new_large_objects list, from where it will be scavenged later.

   Convention: bd->evacuated is /= 0 for a large object that has been
   evacuated, or 0 otherwise.
   -------------------------------------------------------------------------- */

static inline void
evacuate_large(StgPtr p, rtsBool mutable)
{
  bdescr *bd = Bdescr(p);
  step *step;

  /* should point to the beginning of the block */
  ASSERT(((W_)p & BLOCK_MASK) == 0);
  
  /* already evacuated? */
  if (bd->evacuated) { 
    /* Don't forget to set the failed_to_evac flag if we didn't get
     * the desired destination (see comments in evacuate()).
     */
    if (bd->gen->no < evac_gen) {
      failed_to_evac = rtsTrue;
      TICK_GC_FAILED_PROMOTION();
    }
    return;
  }

  step = bd->step;
  /* remove from large_object list */
  if (bd->back) {
    bd->back->link = bd->link;
  } else { /* first object in the list */
    step->large_objects = bd->link;
  }
  if (bd->link) {
    bd->link->back = bd->back;
  }
  
  /* link it on to the evacuated large object list of the destination step
   */
  step = bd->step->to;
  if (step->gen->no < evac_gen) {
#ifdef NO_EAGER_PROMOTION    
    failed_to_evac = rtsTrue;
#else
    step = &generations[evac_gen].steps[0];
#endif
  }

  bd->step = step;
  bd->gen = step->gen;
  bd->link = step->new_large_objects;
  step->new_large_objects = bd;
  bd->evacuated = 1;

  if (mutable) {
    recordMutable((StgMutClosure *)p);
  }
}

/* -----------------------------------------------------------------------------
   Adding a MUT_CONS to an older generation.

   This is necessary from time to time when we end up with an
   old-to-new generation pointer in a non-mutable object.  We defer
   the promotion until the next GC.
   -------------------------------------------------------------------------- */

static StgClosure *
mkMutCons(StgClosure *ptr, generation *gen)
{
  StgMutVar *q;
  step *step;

  step = &gen->steps[0];

  /* chain a new block onto the to-space for the destination step if
   * necessary.
   */
  if (step->hp + sizeofW(StgIndOldGen) >= step->hpLim) {
    addBlock(step);
  }

  q = (StgMutVar *)step->hp;
  step->hp += sizeofW(StgMutVar);

  SET_HDR(q,&MUT_CONS_info,CCS_GC);
  q->var = ptr;
  recordOldToNewPtrs((StgMutClosure *)q);

  return (StgClosure *)q;
}

/* -----------------------------------------------------------------------------
   Evacuate

   This is called (eventually) for every live object in the system.

   The caller to evacuate specifies a desired generation in the
   evac_gen global variable.  The following conditions apply to
   evacuating an object which resides in generation M when we're
   collecting up to generation N

   if  M >= evac_gen 
           if  M > N     do nothing
	   else          evac to step->to

   if  M < evac_gen      evac to evac_gen, step 0

   if the object is already evacuated, then we check which generation
   it now resides in.

   if  M >= evac_gen     do nothing
   if  M <  evac_gen     set failed_to_evac flag to indicate that we
                         didn't manage to evacuate this object into evac_gen.

   -------------------------------------------------------------------------- */


static StgClosure *
evacuate(StgClosure *q)
{
  StgClosure *to;
  bdescr *bd = NULL;
  step *step;
  const StgInfoTable *info;

loop:
  if (!LOOKS_LIKE_STATIC(q)) {
    bd = Bdescr((P_)q);
    if (bd->gen->no > N) {
      /* Can't evacuate this object, because it's in a generation
       * older than the ones we're collecting.  Let's hope that it's
       * in evac_gen or older, or we will have to make an IND_OLDGEN object.
       */
      if (bd->gen->no < evac_gen) {
	/* nope */
	failed_to_evac = rtsTrue;
	TICK_GC_FAILED_PROMOTION();
      }
      return q;
    }
    step = bd->step->to;
  }

  /* make sure the info pointer is into text space */
  ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
	       || IS_HUGS_CONSTR_INFO(GET_INFO(q))));

  info = get_itbl(q);
  switch (info -> type) {

  case BCO:
    to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
    upd_evacuee(q,to);
    return to;

  case MUT_VAR:
    ASSERT(q->header.info != &MUT_CONS_info);
  case MVAR:
    to = copy(q,sizeW_fromITBL(info),step);
    upd_evacuee(q,to);
    recordMutable((StgMutClosure *)to);
    return to;

  case STABLE_NAME:
    stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
    to = copy(q,sizeofW(StgStableName),step);
    upd_evacuee(q,to);
    return to;

  case FUN_1_0:
  case FUN_0_1:
  case CONSTR_1_0:
  case CONSTR_0_1:
    to = copy(q,sizeofW(StgHeader)+1,step);
    upd_evacuee(q,to);
    return to;

  case THUNK_1_0:		/* here because of MIN_UPD_SIZE */
  case THUNK_0_1:
  case FUN_1_1:
  case FUN_0_2:
  case FUN_2_0:
  case THUNK_1_1:
  case THUNK_0_2:
  case THUNK_2_0:
  case CONSTR_1_1:
  case CONSTR_0_2:
  case CONSTR_2_0:
    to = copy(q,sizeofW(StgHeader)+2,step);
    upd_evacuee(q,to);
    return to;

  case FUN:
  case THUNK:
  case CONSTR:
  case IND_PERM:
  case IND_OLDGEN_PERM:
  case CAF_UNENTERED:
  case CAF_ENTERED:
  case WEAK:
  case FOREIGN:
    to = copy(q,sizeW_fromITBL(info),step);
    upd_evacuee(q,to);
    return to;

  case CAF_BLACKHOLE:
  case BLACKHOLE:
    to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
    upd_evacuee(q,to);
    return to;

  case BLACKHOLE_BQ:
    to = copy(q,BLACKHOLE_sizeW(),step); 
    upd_evacuee(q,to);
    recordMutable((StgMutClosure *)to);
    return to;

  case THUNK_SELECTOR:
    {
      const StgInfoTable* selectee_info;
      StgClosure* selectee = ((StgSelector*)q)->selectee;

    selector_loop:
      selectee_info = get_itbl(selectee);
      switch (selectee_info->type) {
      case CONSTR:
      case CONSTR_1_0:
      case CONSTR_0_1:
      case CONSTR_2_0:
      case CONSTR_1_1:
      case CONSTR_0_2:
      case CONSTR_STATIC:
	{ 
	  StgNat32 offset = info->layout.selector_offset;

	  /* check that the size is in range */
	  ASSERT(offset < 
		 (StgNat32)(selectee_info->layout.payload.ptrs + 
		            selectee_info->layout.payload.nptrs));

	  /* perform the selection! */
	  q = selectee->payload[offset];

	  /* if we're already in to-space, there's no need to continue
	   * with the evacuation, just update the source address with
	   * a pointer to the (evacuated) constructor field.
	   */
	  if (IS_USER_PTR(q)) {
	    bdescr *bd = Bdescr((P_)q);
	    if (bd->evacuated) {
	      if (bd->gen->no < evac_gen) {
		failed_to_evac = rtsTrue;
		TICK_GC_FAILED_PROMOTION();
	      }
	      return q;
	    }
	  }

	  /* otherwise, carry on and evacuate this constructor field,
	   * (but not the constructor itself)
	   */
	  goto loop;
	}

      case IND:
      case IND_STATIC:
      case IND_PERM:
      case IND_OLDGEN:
      case IND_OLDGEN_PERM:
	selectee = stgCast(StgInd *,selectee)->indirectee;
	goto selector_loop;

      case CAF_ENTERED:
	selectee = stgCast(StgCAF *,selectee)->value;
	goto selector_loop;

      case EVACUATED:
	selectee = stgCast(StgEvacuated*,selectee)->evacuee;
	goto selector_loop;

      case THUNK:
      case THUNK_1_0:
      case THUNK_0_1:
      case THUNK_2_0:
      case THUNK_1_1:
      case THUNK_0_2:
      case THUNK_STATIC:
      case THUNK_SELECTOR:
	/* aargh - do recursively???? */
      case CAF_UNENTERED:
      case CAF_BLACKHOLE:
      case BLACKHOLE:
      case BLACKHOLE_BQ:
	/* not evaluated yet */
	break;

      default:
	barf("evacuate: THUNK_SELECTOR: strange selectee");
      }
    }
    to = copy(q,THUNK_SELECTOR_sizeW(),step);
    upd_evacuee(q,to);
    return to;

  case IND:
  case IND_OLDGEN:
    /* follow chains of indirections, don't evacuate them */
    q = ((StgInd*)q)->indirectee;
    goto loop;

    /* ToDo: optimise STATIC_LINK for known cases.
       - FUN_STATIC       : payload[0]
       - THUNK_STATIC     : payload[1]
       - IND_STATIC       : payload[1]
    */
  case THUNK_STATIC:
  case FUN_STATIC:
    if (info->srt_len == 0) {	/* small optimisation */
      return q;
    }
    /* fall through */
  case CONSTR_STATIC:
  case IND_STATIC:
    /* don't want to evacuate these, but we do want to follow pointers
     * from SRTs  - see scavenge_static.
     */

    /* put the object on the static list, if necessary.
     */
    if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
      STATIC_LINK(info,(StgClosure *)q) = static_objects;
      static_objects = (StgClosure *)q;
    }
    /* fall through */

  case CONSTR_INTLIKE:
  case CONSTR_CHARLIKE:
  case CONSTR_NOCAF_STATIC:
    /* no need to put these on the static linked list, they don't need
     * to be scavenged.
     */
    return q;

  case RET_BCO:
  case RET_SMALL:
  case RET_VEC_SMALL:
  case RET_BIG:
  case RET_VEC_BIG:
  case RET_DYN:
  case UPDATE_FRAME:
  case STOP_FRAME:
  case CATCH_FRAME:
  case SEQ_FRAME:
    /* shouldn't see these */
    barf("evacuate: stack frame\n");

  case AP_UPD:
  case PAP:
    /* these are special - the payload is a copy of a chunk of stack,
       tagging and all. */
    to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
    upd_evacuee(q,to);
    return to;

  case EVACUATED:
    /* Already evacuated, just return the forwarding address.
     * HOWEVER: if the requested destination generation (evac_gen) is
     * older than the actual generation (because the object was
     * already evacuated to a younger generation) then we have to
     * set the failed_to_evac flag to indicate that we couldn't 
     * manage to promote the object to the desired generation.
     */
    if (evac_gen > 0) {		/* optimisation */
      StgClosure *p = ((StgEvacuated*)q)->evacuee;
      if (Bdescr((P_)p)->gen->no < evac_gen) {
	/*	fprintf(stderr,"evac failed!\n");*/
	failed_to_evac = rtsTrue;
	TICK_GC_FAILED_PROMOTION();
      }
    }
    return ((StgEvacuated*)q)->evacuee;

  case ARR_WORDS:
    {
      nat size = arr_words_sizeW(stgCast(StgArrWords*,q)); 

      if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	evacuate_large((P_)q, rtsFalse);
	return q;
      } else {
	/* just copy the block */
	to = copy(q,size,step);
	upd_evacuee(q,to);
	return to;
      }
    }

  case MUT_ARR_PTRS:
  case MUT_ARR_PTRS_FROZEN:
    {
      nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q)); 

      if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
	to = q;
      } else {
	/* just copy the block */
	to = copy(q,size,step);
	upd_evacuee(q,to);
	if (info->type == MUT_ARR_PTRS) {
	  recordMutable((StgMutClosure *)to);
	}
      }
      return to;
    }

  case TSO:
    {
      StgTSO *tso = stgCast(StgTSO *,q);
      nat size = tso_sizeW(tso);
      int diff;

      /* Large TSOs don't get moved, so no relocation is required.
       */
      if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
	evacuate_large((P_)q, rtsTrue);
	return q;

      /* To evacuate a small TSO, we need to relocate the update frame
       * list it contains.  
       */
      } else {
	StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);

	diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */

	/* relocate the stack pointers... */
	new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
	new_tso->sp = (StgPtr)new_tso->sp + diff;
	new_tso->splim = (StgPtr)new_tso->splim + diff;
	
	relocate_TSO(tso, new_tso);
	upd_evacuee(q,(StgClosure *)new_tso);

	recordMutable((StgMutClosure *)new_tso);
	return (StgClosure *)new_tso;
      }
    }

  case BLOCKED_FETCH:
  case FETCH_ME:
    fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
    return q;

  default:
    barf("evacuate: strange closure type");
  }

  barf("evacuate");
}

/* -----------------------------------------------------------------------------
   relocate_TSO is called just after a TSO has been copied from src to
   dest.  It adjusts the update frame list for the new location.
   -------------------------------------------------------------------------- */

StgTSO *
relocate_TSO(StgTSO *src, StgTSO *dest)
{
  StgUpdateFrame *su;
  StgCatchFrame  *cf;
  StgSeqFrame    *sf;
  int diff;

  diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */

  su = dest->su;

  while ((P_)su < dest->stack + dest->stack_size) {
    switch (get_itbl(su)->type) {
   
      /* GCC actually manages to common up these three cases! */

    case UPDATE_FRAME:
      su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
      su = su->link;
      continue;

    case CATCH_FRAME:
      cf = (StgCatchFrame *)su;
      cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
      su = cf->link;
      continue;

    case SEQ_FRAME:
      sf = (StgSeqFrame *)su;
      sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
      su = sf->link;
      continue;

    case STOP_FRAME:
      /* all done! */
      break;

    default:
      barf("relocate_TSO");
    }
    break;
  }

  return dest;
}

static inline void
scavenge_srt(const StgInfoTable *info)
{
  StgClosure **srt, **srt_end;

  /* evacuate the SRT.  If srt_len is zero, then there isn't an
   * srt field in the info table.  That's ok, because we'll
   * never dereference it.
   */
  srt = stgCast(StgClosure **,info->srt);
  srt_end = srt + info->srt_len;
  for (; srt < srt_end; srt++) {
    evacuate(*srt);
  }
}

/* -----------------------------------------------------------------------------
   Scavenge a given step until there are no more objects in this step
   to scavenge.

   evac_gen is set by the caller to be either zero (for a step in a
   generation < N) or G where G is the generation of the step being
   scavenged.  

   We sometimes temporarily change evac_gen back to zero if we're
   scavenging a mutable object where early promotion isn't such a good
   idea.  
   -------------------------------------------------------------------------- */
   

static void
scavenge(step *step)
{
  StgPtr p, q;
  const StgInfoTable *info;
  bdescr *bd;
  nat saved_evac_gen = evac_gen; /* used for temporarily changing evac_gen */

  p = step->scan;
  bd = step->scan_bd;

  failed_to_evac = rtsFalse;

  /* scavenge phase - standard breadth-first scavenging of the
   * evacuated objects 
   */

  while (bd != step->hp_bd || p < step->hp) {

    /* If we're at the end of this block, move on to the next block */
    if (bd != step->hp_bd && p == bd->free) {
      bd = bd->link;
      p = bd->start;
      continue;
    }

    q = p;			/* save ptr to object */

    ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
		 || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));

    info = get_itbl((StgClosure *)p);
    switch (info -> type) {

    case BCO:
      {
	StgBCO* bco = stgCast(StgBCO*,p);
	nat i;
	for (i = 0; i < bco->n_ptrs; i++) {
	  bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
	}
	p += bco_sizeW(bco);
	break;
      }

    case MVAR:
      /* treat MVars specially, because we don't want to evacuate the
       * mut_link field in the middle of the closure.
       */
      { 
	StgMVar *mvar = ((StgMVar *)p);
	evac_gen = 0;
	(StgClosure *)mvar->head = evacuate((StgClosure *)mvar->head);
	(StgClosure *)mvar->tail = evacuate((StgClosure *)mvar->tail);
	(StgClosure *)mvar->value = evacuate((StgClosure *)mvar->value);
	p += sizeofW(StgMVar);
	evac_gen = saved_evac_gen;
	break;
      }