GC.c 105 KB
Newer Older
1
/* -----------------------------------------------------------------------------
2
 * $Id: GC.c,v 1.117 2001/08/08 13:45:02 simonmar Exp $
3
 *
4 5 6
 * (c) The GHC Team 1998-1999
 *
 * Generational garbage collector
7 8 9 10 11 12 13 14 15 16
 *
 * ---------------------------------------------------------------------------*/

#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
#include "Storage.h"
#include "StoragePriv.h"
#include "Stats.h"
#include "Schedule.h"
17
#include "SchedAPI.h"		// for ReverCAFs prototype
18 19
#include "Sanity.h"
#include "BlockAlloc.h"
20
#include "MBlock.h"
21
#include "Main.h"
22
#include "ProfHeap.h"
23 24
#include "SchedAPI.h"
#include "Weak.h"
25
#include "StablePriv.h"
26
#include "Prelude.h"
27 28
#include "ParTicky.h"		// ToDo: move into Rts.h
#include "GCCompact.h"
29 30 31 32 33 34 35 36 37
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"
# include "ParallelRts.h"
# include "FetchMe.h"
# if defined(DEBUG)
#  include "Printer.h"
#  include "ParallelDebug.h"
# endif
#endif
38 39
#include "HsFFI.h"
#include "Linker.h"
40 41 42
#if defined(RTS_GTK_FRONTPANEL)
#include "FrontPanel.h"
#endif
43 44 45

/* STATIC OBJECT LIST.
 *
46
 * During GC:
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
 * 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.  
68 69 70 71 72 73 74 75 76 77
 *
 * 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.
 */
78 79
StgClosure* static_objects;	      // live static objects
StgClosure* scavenged_static_objects; // static objects scavenged so far
80 81 82 83 84 85 86 87 88 89 90 91

/* 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).
92
 */
93
static nat evac_gen;
94

95
/* Weak pointers
96
 */
97 98
StgWeak *old_weak_ptr_list; // also pending finaliser list
static rtsBool weak_done;	   // all done for this pass
99

100 101 102 103 104
/* List of all threads during GC
 */
static StgTSO *old_all_threads;
static StgTSO *resurrected_threads;

105 106
/* Flag indicating failure to evacuate an object to the desired
 * generation.
107
 */
108
static rtsBool failed_to_evac;
109

110 111
/* Old to-space (used for two-space collector only)
 */
112
bdescr *old_to_blocks;
113

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

119 120 121 122 123
/* Used to avoid long recursion due to selector thunks
 */
lnat thunk_selector_depth = 0;
#define MAX_THUNK_SELECTOR_DEPTH 256

124 125 126 127
/* -----------------------------------------------------------------------------
   Static function declarations
   -------------------------------------------------------------------------- */

128
static void         mark_root               ( StgClosure **root );
129 130 131
static StgClosure * evacuate                ( StgClosure *q );
static void         zero_static_object_list ( StgClosure* first_static );
static void         zero_mutable_list       ( StgMutClosure *first );
132

133
static rtsBool      traverse_weak_ptr_list  ( void );
134
static void         mark_weak_ptr_list      ( StgWeak **list );
135

136 137
static void         scavenge                ( step * );
static void         scavenge_mark_stack     ( void );
138
static void         scavenge_stack          ( StgPtr p, StgPtr stack_end );
139
static rtsBool      scavenge_one            ( StgPtr p );
140
static void         scavenge_large          ( step * );
141 142 143
static void         scavenge_static         ( void );
static void         scavenge_mutable_list   ( generation *g );
static void         scavenge_mut_once_list  ( generation *g );
144
static void         scavengeCAFs            ( void );
145

146
#if 0 && defined(DEBUG)
147
static void         gcCAFs                  ( void );
148 149
#endif

150 151 152 153 154 155 156 157 158 159 160
/* -----------------------------------------------------------------------------
   inline functions etc. for dealing with the mark bitmap & stack.
   -------------------------------------------------------------------------- */

#define MARK_STACK_BLOCKS 4

static bdescr *mark_stack_bdescr;
static StgPtr *mark_stack;
static StgPtr *mark_sp;
static StgPtr *mark_splim;

161 162 163 164 165 166
// Flag and pointers used for falling back to a linear scan when the
// mark stack overflows.
static rtsBool mark_stack_overflowed;
static bdescr *oldgen_scan_bd;
static StgPtr  oldgen_scan;

167 168 169 170 171 172 173 174 175 176 177 178
static inline rtsBool
mark_stack_empty(void)
{
    return mark_sp == mark_stack;
}

static inline rtsBool
mark_stack_full(void)
{
    return mark_sp >= mark_splim;
}

179 180 181 182 183 184
static inline void
reset_mark_stack(void)
{
    mark_sp = mark_stack;
}

185 186 187 188 189
static inline void
push_mark_stack(StgPtr p)
{
    *mark_sp++ = p;
}
190

191 192 193 194 195
static inline StgPtr
pop_mark_stack(void)
{
    return *--mark_sp;
}
196

197 198 199
/* -----------------------------------------------------------------------------
   GarbageCollect

200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
   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.

218 219
   -------------------------------------------------------------------------- */

220 221
void
GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
222
{
223
  bdescr *bd;
224
  step *stp;
225
  lnat live, allocated, collected = 0, copied = 0;
226
  lnat oldgen_saved_blocks = 0;
227 228
  nat g, s;

229 230 231 232
#ifdef PROFILING
  CostCentreStack *prev_CCS;
#endif

233 234
#if defined(DEBUG) && defined(GRAN)
  IF_DEBUG(gc, belch("@@ Starting garbage collection at %ld (%lx)\n", 
235
		     Now, Now));
236 237
#endif

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

241
  // Init stats and print par specific (timing) info 
242 243
  PAR_TICKY_PAR_START();

244
  // attribute any costs to CCS_GC 
245 246 247 248 249
#ifdef PROFILING
  prev_CCS = CCCS;
  CCCS = CCS_GC;
#endif

250 251 252
  /* Approximate how much we allocated.  
   * Todo: only when generating stats? 
   */
253
  allocated = calcAllocated();
254 255 256

  /* Figure out which generation to collect
   */
257 258 259 260 261 262
  if (force_major_gc) {
    N = RtsFlags.GcFlags.generations - 1;
    major_gc = rtsTrue;
  } else {
    N = 0;
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
263 264 265
      if (generations[g].steps[0].n_blocks +
	  generations[g].steps[0].n_large_blocks
	  >= generations[g].max_blocks) {
266 267
        N = g;
      }
268
    }
269
    major_gc = (N == RtsFlags.GcFlags.generations-1);
270 271
  }

272 273 274 275 276 277
#ifdef RTS_GTK_FRONTPANEL
  if (RtsFlags.GcFlags.frontpanel) {
      updateFrontPanelBeforeGC(N);
  }
#endif

278
  // check stack sanity *before* GC (ToDo: check all threads) 
279 280 281
#if defined(GRAN)
  // ToDo!: check sanity  IF_DEBUG(sanity, checkTSOsSanity());
#endif
282
  IF_DEBUG(sanity, checkFreeListSanity());
283

284 285
  /* Initialise the static object lists
   */
286 287 288
  static_objects = END_OF_STATIC_LIST;
  scavenged_static_objects = END_OF_STATIC_LIST;

289
  /* zero the mutable list for the oldest generation (see comment by
290
   * zero_mutable_list below).
291 292
   */
  if (major_gc) { 
293
    zero_mutable_list(generations[RtsFlags.GcFlags.generations-1].mut_once_list);
294 295
  }

296 297 298
  /* Save the old to-space if we're doing a two-space collection
   */
  if (RtsFlags.GcFlags.generations == 1) {
299 300
    old_to_blocks = g0s0->to_blocks;
    g0s0->to_blocks = NULL;
301 302
  }

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

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

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

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

322 323 324 325
      /* Get a free block for to-space.  Extra blocks will be chained on
       * as necessary.
       */
      bd = allocBlock();
326
      stp = &generations[g].steps[s];
327
      ASSERT(stp->gen_no == g);
328
      ASSERT(stp->hp ? Bdescr(stp->hp)->step == stp : rtsTrue);
329
      bd->gen_no = g;
330
      bd->step = stp;
331
      bd->link = NULL;
332 333 334 335 336 337 338 339
      bd->flags        = BF_EVACUATED;	// it's a to-space block 
      stp->hp          = bd->start;
      stp->hpLim       = stp->hp + BLOCK_SIZE_W;
      stp->hp_bd       = bd;
      stp->to_blocks   = bd;
      stp->n_to_blocks = 1;
      stp->scan        = bd->start;
      stp->scan_bd     = bd;
340 341
      stp->new_large_objects = NULL;
      stp->scavenged_large_objects = NULL;
342
      stp->n_scavenged_large_blocks = 0;
343
      new_blocks++;
344
      // mark the large objects as not evacuated yet 
345
      for (bd = stp->large_objects; bd; bd = bd->link) {
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
	bd->flags = BF_LARGE;
      }

      // for a compacted step, we need to allocate the bitmap
      if (stp->is_compacted) {
	  nat bitmap_size; // in bytes
	  bdescr *bitmap_bdescr;
	  StgWord *bitmap;

	  bitmap_size = stp->n_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE);

	  if (bitmap_size > 0) {
	      bitmap_bdescr = allocGroup((nat)BLOCK_ROUND_UP(bitmap_size) 
					 / BLOCK_SIZE);
	      stp->bitmap = bitmap_bdescr;
	      bitmap = bitmap_bdescr->start;
	      
363
	      IF_DEBUG(gc, belch("bitmap_size: %d, bitmap: %p",
364 365 366 367 368 369 370 371 372 373 374 375
				   bitmap_size, bitmap););
	      
	      // 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
	      // block descriptor.
	      for (bd=stp->blocks; bd != NULL; bd = bd->link) {
		  bd->u.bitmap = bitmap;
		  bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE);
	      }
	  }
376 377 378 379 380 381 382 383 384
      }
    }
  }

  /* 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++) {
385 386
      stp = &generations[g].steps[s];
      if (stp->hp_bd == NULL) {
387 388 389 390 391 392 393 394 395 396 397 398
	  ASSERT(stp->blocks == NULL);
	  bd = allocBlock();
	  bd->gen_no = g;
	  bd->step = stp;
	  bd->link = NULL;
	  bd->flags = 0;	// *not* a to-space block or a large object
	  stp->hp = bd->start;
	  stp->hpLim = stp->hp + BLOCK_SIZE_W;
	  stp->hp_bd = bd;
	  stp->blocks = bd;
	  stp->n_blocks = 1;
	  new_blocks++;
399 400 401
      }
      /* Set the scan pointer for older generations: remember we
       * still have to scavenge objects that have been promoted. */
402 403
      stp->scan = stp->hp;
      stp->scan_bd = stp->hp_bd;
404 405
      stp->to_blocks = NULL;
      stp->n_to_blocks = 0;
406 407
      stp->new_large_objects = NULL;
      stp->scavenged_large_objects = NULL;
408
      stp->n_scavenged_large_blocks = 0;
409 410
    }
  }
411

412 413 414 415 416 417 418 419 420 421 422
  /* Allocate a mark stack if we're doing a major collection.
   */
  if (major_gc) {
      mark_stack_bdescr = allocGroup(MARK_STACK_BLOCKS);
      mark_stack = (StgPtr *)mark_stack_bdescr->start;
      mark_sp    = mark_stack;
      mark_splim = mark_stack + (MARK_STACK_BLOCKS * BLOCK_SIZE_W);
  } else {
      mark_stack_bdescr = NULL;
  }

423
  /* -----------------------------------------------------------------------
424
   * follow all the roots that we know about:
425 426 427 428 429 430 431 432 433 434 435
   *   - 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.
   */
  { 
436 437
    int st;
    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
438
      generations[g].saved_mut_list = generations[g].mut_list;
439
      generations[g].mut_list = END_MUT_LIST;
440
    }
441

442
    // Do the mut-once lists first 
443
    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
444 445
      IF_PAR_DEBUG(verbose,
		   printMutOnceList(&generations[g]));
446 447 448 449 450
      scavenge_mut_once_list(&generations[g]);
      evac_gen = g;
      for (st = generations[g].n_steps-1; st >= 0; st--) {
	scavenge(&generations[g].steps[st]);
      }
451 452
    }

453
    for (g = RtsFlags.GcFlags.generations-1; g > N; g--) {
454 455
      IF_PAR_DEBUG(verbose,
		   printMutableList(&generations[g]));
456 457 458 459
      scavenge_mutable_list(&generations[g]);
      evac_gen = g;
      for (st = generations[g].n_steps-1; st >= 0; st--) {
	scavenge(&generations[g].steps[st]);
460 461
      }
    }
462 463
  }

464 465
  scavengeCAFs();

466 467 468
  /* follow all the roots that the application knows about.
   */
  evac_gen = 0;
469
  get_roots(mark_root);
470

471 472 473 474 475 476 477 478 479
#if defined(PAR)
  /* And don't forget to mark the TSO if we got here direct from
   * Haskell! */
  /* Not needed in a seq version?
  if (CurrentTSO) {
    CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
  }
  */

480
  // Mark the entries in the GALA table of the parallel system 
481
  markLocalGAs(major_gc);
482
  // Mark all entries on the list of pending fetches 
483
  markPendingFetches(major_gc);
484 485
#endif

486 487 488
  /* Mark the weak pointer list, and prepare to detect dead weak
   * pointers.
   */
489
  mark_weak_ptr_list(&weak_ptr_list);
490 491 492 493
  old_weak_ptr_list = weak_ptr_list;
  weak_ptr_list = NULL;
  weak_done = rtsFalse;

494 495 496 497 498 499 500
  /* The all_threads list is like the weak_ptr_list.  
   * See traverse_weak_ptr_list() for the details.
   */
  old_all_threads = all_threads;
  all_threads = END_TSO_QUEUE;
  resurrected_threads = END_TSO_QUEUE;

501 502
  /* Mark the stable pointer table.
   */
503
  markStablePtrTable(mark_root);
504

505 506 507 508 509 510 511 512 513 514 515
#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);
      markHugsObjects();
  }
#endif

516 517 518
  /* -------------------------------------------------------------------------
   * Repeatedly scavenge all the areas we know about until there's no
   * more scavenging to be done.
519 520
   */
  { 
521
    rtsBool flag;
522
  loop:
523 524
    flag = rtsFalse;

525
    // scavenge static objects 
526
    if (major_gc && static_objects != END_OF_STATIC_LIST) {
527 528 529 530
	IF_DEBUG(sanity, checkStaticObjects(static_objects));
	scavenge_static();
    }

531 532 533 534 535 536 537 538 539
    /* 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.
     */

540
    // scavenge each step in generations 0..maxgen 
541
    { 
ken's avatar
ken committed
542 543
      long gen;
      int st; 
544

545
    loop2:
546
      // scavenge objects in compacted generation
547 548
      if (mark_stack_overflowed || oldgen_scan_bd != NULL ||
	  (mark_stack_bdescr != NULL && !mark_stack_empty())) {
549 550 551 552
	  scavenge_mark_stack();
	  flag = rtsTrue;
      }

ken's avatar
ken committed
553 554
      for (gen = RtsFlags.GcFlags.generations; --gen >= 0; ) {
	for (st = generations[gen].n_steps; --st >= 0; ) {
555
	  if (gen == 0 && st == 0 && RtsFlags.GcFlags.generations > 1) { 
556 557
	    continue; 
	  }
558
	  stp = &generations[gen].steps[st];
559
	  evac_gen = gen;
560 561
	  if (stp->hp_bd != stp->scan_bd || stp->scan < stp->hp) {
	    scavenge(stp);
562
	    flag = rtsTrue;
563
	    goto loop2;
564
	  }
565 566
	  if (stp->new_large_objects != NULL) {
	    scavenge_large(stp);
567
	    flag = rtsTrue;
568
	    goto loop2;
569 570 571
	  }
	}
      }
572
    }
573

574 575
    if (flag) { goto loop; }

576 577
    // must be last... 
    if (traverse_weak_ptr_list()) { // returns rtsTrue if evaced something 
578 579 580 581
      goto loop;
    }
  }

582
#if defined(PAR)
583
  // Reconstruct the Global Address tables used in GUM 
584 585 586 587
  rebuildGAtables(major_gc);
  IF_DEBUG(sanity, checkLAGAtable(rtsTrue/*check closures, too*/));
#endif

588 589 590 591 592 593 594 595 596 597 598
  // Now see which stable names are still alive.
  gcStablePtrTable();

  // Tidy the end of the to-space chains 
  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
      for (s = 0; s < generations[g].n_steps; s++) {
	  stp = &generations[g].steps[s];
	  if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
	      stp->hp_bd->free = stp->hp;
	      stp->hp_bd->link = NULL;
	  }
599
      }
600
  }
601

602 603
  // NO MORE EVACUATION AFTER THIS POINT!
  // Finally: compaction of the oldest generation.
604
  if (major_gc && oldest_gen->steps[0].is_compacted) {
605 606
      // save number of blocks for stats
      oldgen_saved_blocks = oldest_gen->steps[0].n_blocks;
607 608 609 610 611
      compact(get_roots);
  }

  IF_DEBUG(sanity, checkGlobalTSOList(rtsFalse));

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

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

621 622
    for (s = 0; s < generations[g].n_steps; s++) {
      bdescr *next;
623
      stp = &generations[g].steps[s];
624

625
      if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
626
	// stats information: how much we copied 
627
	if (g <= N) {
628 629
	  copied -= stp->hp_bd->start + BLOCK_SIZE_W -
	    stp->hp_bd->free;
630
	}
631 632
      }

633
      // for generations we collected... 
634 635
      if (g <= N) {

636 637 638 639 640 641
	  // rough calculation of garbage collected, for stats output
	  if (stp->is_compacted) {
	      collected += (oldgen_saved_blocks - stp->n_blocks) * BLOCK_SIZE_W;
	  } else {
	      collected += stp->n_blocks * BLOCK_SIZE_W;
	  }
642 643 644 645 646 647

	/* 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)) {
648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676
	    if (stp->is_compacted) {
		// 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 
		}
		// tack the new blocks on the end of the existing blocks
		if (stp->blocks == NULL) {
		    stp->blocks = stp->to_blocks;
		} else {
		    for (bd = stp->blocks; bd != NULL; bd = next) {
			next = bd->link;
			if (next == NULL) {
			    bd->link = stp->to_blocks;
			}
		    }
		}
		// add the new blocks to the block tally
		stp->n_blocks += stp->n_to_blocks;
	    } else {
		freeChain(stp->blocks);
		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 
		}
	    }
	    stp->to_blocks = NULL;
	    stp->n_to_blocks = 0;
677 678 679 680 681 682 683
	}

	/* 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.
	 */
684
	for (bd = stp->large_objects; bd != NULL; bd = next) {
685 686 687 688
	  next = bd->link;
	  freeGroup(bd);
	  bd = next;
	}
689 690

	// update the count of blocks used by large objects
691
	for (bd = stp->scavenged_large_objects; bd != NULL; bd = bd->link) {
692
	  bd->flags &= ~BF_EVACUATED;
693
	}
694 695
	stp->large_objects  = stp->scavenged_large_objects;
	stp->n_large_blocks = stp->n_scavenged_large_blocks;
696 697

      } else {
698
	// for older generations... 
699 700 701 702 703
	
	/* 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.
	 */
704
	for (bd = stp->scavenged_large_objects; bd; bd = next) {
705
	  next = bd->link;
706
	  bd->flags &= ~BF_EVACUATED;
707
	  dbl_link_onto(bd, &stp->large_objects);
708 709
	}

710 711
	// add the new blocks we promoted during this GC 
	stp->n_blocks += stp->n_to_blocks;
712
	stp->n_large_blocks += stp->n_scavenged_large_blocks;
713 714 715
      }
    }
  }
716

717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771
  /* Reset the sizes of the older generations when we do a major
   * collection.
   *
   * CURRENT STRATEGY: make all generations except zero the same size.
   * We have to stay within the maximum heap size, and leave a certain
   * percentage of the maximum heap size available to allocate into.
   */
  if (major_gc && RtsFlags.GcFlags.generations > 1) {
      nat live, size, min_alloc;
      nat max  = RtsFlags.GcFlags.maxHeapSize;
      nat gens = RtsFlags.GcFlags.generations;

      // live in the oldest generations
      live = oldest_gen->steps[0].n_blocks +
	     oldest_gen->steps[0].n_large_blocks;

      // default max size for all generations except zero
      size = stg_max(live * RtsFlags.GcFlags.oldGenFactor,
		     RtsFlags.GcFlags.minOldGenSize);

      // minimum size for generation zero
      min_alloc = (RtsFlags.GcFlags.pcFreeHeap * max) / 200;

      // if we're going to go over the maximum heap size, reduce the
      // size of the generations accordingly.  The calculation is
      // different if compaction is turned on, because we don't need
      // to double the space required to collect the old generation.
      if (max != 0) {
	  if (RtsFlags.GcFlags.compact) {
	      if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) {
		  size = (max - min_alloc) / ((gens - 1) * 2 - 1);
	      }
	  } else {
	      if ( (size * (gens - 1) * 2) + min_alloc > max ) {
		  size = (max - min_alloc) / ((gens - 1) * 2);
	      }
	  }

	  if (size < live) {
	      heapOverflow();
	  }
      }

#if 0
      fprintf(stderr,"live: %d, min_alloc: %d, size : %d, max = %d\n", live,
	      min_alloc, size, max);
#endif

      for (g = 0; g < gens; g++) {
	  generations[g].max_blocks = size;
      }

      // Auto-enable compaction when the residency reaches a
      // certain percentage of the maximum heap size (default: 30%).
      if (RtsFlags.GcFlags.compact &&
772
	  max > 0 && 
773 774 775 776 777 778 779 780 781 782 783
	  oldest_gen->steps[0].n_blocks > 
	    (RtsFlags.GcFlags.compactThreshold * max) / 100) {
	  oldest_gen->steps[0].is_compacted = 1;
//	  fprintf(stderr,"compaction: on\n", live);
      } else {
	  oldest_gen->steps[0].is_compacted = 0;
//	  fprintf(stderr,"compaction: off\n", live);
      }
  }

  // Guess the amount of live data for stats.
784 785
  live = calcLive();

786 787 788 789 790 791 792 793
  /* 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;
794 795
  alloc_Hp = NULL;
  alloc_HpLim = NULL;
796 797
  alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;

798 799 800
  // Start a new pinned_object_block
  pinned_object_block = NULL;

801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817
  /* Free the mark stack.
   */
  if (mark_stack_bdescr != NULL) {
      freeGroup(mark_stack_bdescr);
  }

  /* Free any bitmaps.
   */
  for (g = 0; g <= N; g++) {
      for (s = 0; s < generations[g].n_steps; s++) {
	  stp = &generations[g].steps[s];
	  if (stp->is_compacted && stp->bitmap != NULL) {
	      freeGroup(stp->bitmap);
	  }
      }
  }

818 819 820 821
  /* Two-space collector:
   * Free the old to-space, and estimate the amount of live data.
   */
  if (RtsFlags.GcFlags.generations == 1) {
822 823
    nat blocks;
    
824 825
    if (old_to_blocks != NULL) {
      freeChain(old_to_blocks);
826
    }
827 828
    for (bd = g0s0->to_blocks; bd != NULL; bd = bd->link) {
      bd->flags = 0;	// now from-space 
829
    }
830

831 832 833
    /* For a two-space collector, we need to resize the nursery. */
    
    /* set up a new nursery.  Allocate a nursery size based on a
834 835 836
     * function of the amount of live data (by default a factor of 2)
     * Use the blocks from the old nursery if possible, freeing up any
     * left over blocks.
837 838 839 840 841 842 843 844
     *
     * 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
845
     * performance at 2L bytes.
846
     */
847
    blocks = g0s0->n_to_blocks;
848 849 850

    if ( blocks * RtsFlags.GcFlags.oldGenFactor * 2 > 
	 RtsFlags.GcFlags.maxHeapSize ) {
ken's avatar
ken committed
851
      long adjusted_blocks;  // signed on purpose 
852 853 854
      int pc_free; 
      
      adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
855
      IF_DEBUG(gc, belch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
856 857 858 859 860 861 862 863 864 865 866 867
      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;
      }
    }
868
    resizeNursery(blocks);
869
    
870
  } else {
871
    /* Generational collector:
872 873
     * If the user has given us a suggested heap size, adjust our
     * allocation area to make best use of the memory available.
874 875 876
     */

    if (RtsFlags.GcFlags.heapSizeSuggestion) {
ken's avatar
ken committed
877
      long blocks;
878
      nat needed = calcNeeded(); 	// approx blocks needed at next GC 
879 880

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

888 889 890 891 892 893 894 895 896 897 898
      /* 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.
899
       */
900
      blocks = 
ken's avatar
ken committed
901 902
	(((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) /
	(100 + (long)g0s0_pcnt_kept);
903
      
ken's avatar
ken committed
904
      if (blocks < (long)RtsFlags.GcFlags.minAllocAreaSize) {
905
	blocks = RtsFlags.GcFlags.minAllocAreaSize;
906
      }
907 908
      
      resizeNursery((nat)blocks);
909
    }
910 911
  }

912 913
 // mark the garbage collected CAFs as dead 
#if 0 && defined(DEBUG) // doesn't work at the moment 
914
  if (major_gc) { gcCAFs(); }
915 916
#endif
  
917
  // zero the scavenged static object list 
918
  if (major_gc) {
919
    zero_static_object_list(scavenged_static_objects);
920
  }
921

922
  // Reset the nursery
923
  resetNurseries();
924

925
  // start any pending finalizers 
926
  scheduleFinalizers(old_weak_ptr_list);
927
  
928
  // send exceptions to any threads which were about to die 
929 930
  resurrectThreads(resurrected_threads);

931 932
  // Update the stable pointer hash table.
  updateStablePtrTable(major_gc);
933

934 935 936 937 938
  // check sanity after GC 
  IF_DEBUG(sanity, checkSanity());

  // extra GC trace info 
  IF_DEBUG(gc, statDescribeGens());
939 940

#ifdef DEBUG
941 942
  // symbol-table based profiling 
  /*  heapCensus(to_blocks); */ /* ToDo */
943 944
#endif

945
  // restore enclosing cost centre 
946
#ifdef PROFILING
947
  heapCensus();
948 949 950
  CCCS = prev_CCS;
#endif

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

954 955
#ifdef RTS_GTK_FRONTPANEL
  if (RtsFlags.GcFlags.frontpanel) {
956 957 958 959
      updateFrontPanelAfterGC( N, live );
  }
#endif

960
  // ok, GC over: tell the stats department what happened. 
961
  stat_endGC(allocated, collected, live, copied, N);
962 963

  //PAR_TICKY_TP();
964 965
}

966

967 968 969 970 971 972 973 974 975 976 977 978 979
/* -----------------------------------------------------------------------------
   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.
980

981
   For generational GC: we just don't try to finalize weak pointers in
982 983 984
   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.
985 986 987 988 989 990
   -------------------------------------------------------------------------- */

static rtsBool 
traverse_weak_ptr_list(void)
{
  StgWeak *w, **last_w, *next_w;
991
  StgClosure *new;
992 993 994 995
  rtsBool flag = rtsFalse;

  if (weak_done) { return rtsFalse; }

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

1001
  last_w = &old_weak_ptr_list;
1002
  for (w = old_weak_ptr_list; w != NULL; w = next_w) {
1003

1004 1005 1006
    /* There might be a DEAD_WEAK on the list if finalizeWeak# was
     * called on a live weak pointer object.  Just remove it.
     */
1007
    if (w->header.info == &stg_DEAD_WEAK_info) {
1008 1009 1010 1011 1012
      next_w = ((StgDeadWeak *)w)->link;
      *last_w = next_w;
      continue;
    }

1013 1014 1015 1016
    ASSERT(get_itbl(w)->type == WEAK);