ghc/runtime/storage/SMgen.lc

   1 ***************************************************************************
   2
   3                       GENERATIONAL GARBAGE COLLECTION
   4
   5 Global heap requirements as for 1s and 2s collectors.
   6     ++ All closures in the old generation that are updated must be
   7        updated with indirections and placed on the linked list of
   8        updated old generation closures.
   9
  10
  11 Promotion collection:
  12 ---------------------
  13
  14 Collects allocation area into 2nd semi-space and promotes new semi-space
  15 by collecting into old generation.
  16
  17 evac < AllocGen ==> Collect to old generation (see _EvacuateP)
  18
  19 Roots: Roots, Astk, Bstk, OldRoots, OldInNew, CAFlist, NewCAFlist
  20
  21 OldRoots: Newly promoted closures may reference new semi-space.
  22
  23           Discard OldInNew roots (promoted).
  24             This keeps recent new gen roots in new gen.
  25           Remember OldRoots in alloc (not promoted).
  26
  27           When evacuating to new check if Scav in OldGen, if so
  28             allocate oldgen root ind and add to OldInNew.
  29             N.B. This includes evacuating a forward reference.
  30           Set special forward ref to this OldGen root closure.
  31             if oldgen evacs return oldgen root else return new gen.
  32
  33 CAFlist:  Remember NewCAFlist in OldCAFlist (promoted).
  34           Remember CAFlist in NewCAFlist (not promoted).
  35
  36 ***************************************************************************
  37
  38 \begin{code}
  39 #if defined(GCgn)
  40
  41 #define SCAV_REG_MAP
  42 #include "SMinternal.h"
  43
  44 REGDUMP(ScavRegDump);
  45
  46 genData genInfo = {0, 0, 0, 0,
  47                    0, 0,                 /* Alloc */
  48                    0, {{0, 0}, {0, 0}},  /* New Gen */
  49                    0, 0, 0, 0, 0, 0,     /* Old Gen */
  50                    0, 0, 0, 0, 0, 0, 0,  /* OldRoots & CAfs */
  51                    0, {{0, 0}, {0, 0}}   /* 2s */
  52                   };
  53
  54 P_ heap_space = 0;              /* Address of first word of slab
  55                                    of memory allocated for heap */
  56
  57 P_ hp_start;            /* Value of Hp when reduction was resumed */
  58                                 /* Always allocbase - 1 */
  59
  60 rtsBool
  61 initHeap(smInfo * sm)
  62 {
  63     I_ heap_error = 0;
  64     I_ bit_words;
  65
  66     /* should cause link error */
  67     ADRpanic("Completely untested on SP and MP stuff... also doesn't benefit from commoning up in SMcopying and SMcompacting");
  68
  69     if (heap_space == 0) { /* allocates if it doesn't already exist */
  70
  71         /* Allocate the roots space */
  72         sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
  73
  74         /* Allocate the heap */
  75         heap_space = (P_) stgMallocWords(SM_word_heap_size + EXTRA_HEAP_WORDS,
  76                                          "initHeap (heap)");
  77
  78         if (RTSflags.GcFlags.force2s) {
  79             stat_init("TWOSPACE(GEN)",
  80                       " No of Roots  Caf   Caf    Astk   Bstk",
  81                       "Astk Bstk Reg  No  bytes  bytes  bytes");
  82         } else {
  83             stat_init("GEN",
  84                       "Promote Old    No of Roots  Caf Mut-  Old Old OldGen  Collec  Resid",
  85                       " bytes roots  Astk Bstk Reg  No able  Alc New  bytes   tion   %heap");
  86         }
  87     }
  88
  89     if (RTSflags.GcFlags.force2s) {
  90         genInfo.semi_space = RTSflags.GcFlags.heapSize / 2;
  91         genInfo.space[0].base = HEAP_FRAME_BASE(heap_space, genInfo.semi_space);
  92         genInfo.space[1].base = HEAP_FRAME_BASE(heap_space + genInfo.semi_space, genInfo.semi_space);
  93         genInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, genInfo.semi_space);
  94         genInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + genInfo.semi_space, genInfo.semi_space);
  95         genInfo.semi_space = 0;
  96         genInfo.oldlim = heap_space - 1;  /* Never in old generation */
  97
  98         sm->hp = hp_start = genInfo.space[genInfo.semi_space].base - 1;
  99
 100         if (! RTSflags.GcFlags.allocAreaSizeGiven) {
 101             sm->hplim = genInfo.space[genInfo.semi_space].lim;
 102         } else {
 103             sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
 104
 105             RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
 106
 107             if (sm->hplim > genInfo.space[genInfo.semi_space].lim) {
 108                 fprintf(stderr, "Not enough heap for requested alloc size\n");
 109                 return rtsFalse;
 110             }
 111         }
 112
 113         sm->OldLim = genInfo.oldlim;
 114         sm->CAFlist = NULL;
 115
 116 #ifndef PAR
 117         initExtensions( sm );
 118 #endif
 119
 120         if (RTSflags.GcFlags.trace) {
 121             fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n",
 122                     (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
 123             fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %ld\n",
 124                     genInfo.semi_space,
 125                     (W_) genInfo.space[genInfo.semi_space].base,
 126                     (W_) genInfo.space[genInfo.semi_space].lim,
 127                     (W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp));
 128         }
 129         return rtsTrue;
 130     }
 131
 132     genInfo.alloc_words = RTSflags.GcFlags.allocAreaSize;
 133     genInfo.new_words   = RTSflags.GcFlags.allocAreaSize;
 134
 135     genInfo.allocbase  = heap_space + RTSflags.GcFlags.heapSize - genInfo.alloc_words;
 136     genInfo.alloclim   = heap_space + RTSflags.GcFlags.heapSize - 1;
 137
 138     genInfo.newgen[0].newbase   = genInfo.allocbase - genInfo.new_words;
 139     genInfo.newgen[0].newlim    = genInfo.newgen[0].newbase - 1;
 140
 141     genInfo.newgen[1].newbase   = genInfo.allocbase - 2 * genInfo.new_words;
 142     genInfo.newgen[1].newlim    = genInfo.newgen[1].newbase - 1;
 143
 144     genInfo.oldbase = heap_space;
 145
 146     if (RTSflags.GcFlags.specifiedOldGenSize) {
 147         genInfo.old_words = RTSflags.GcFlags.specifiedOldGenSize;
 148         genInfo.oldend    = heap_space + genInfo.old_words - 1;
 149         genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
 150                                          /* ToDo: extra old ind words not accounted for ! */
 151
 152         bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 153         if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
 154             /* bit vector in allocation area */
 155             genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
 156             if (genInfo.oldend >= genInfo.newgen[1].newbase) heap_error = 1;
 157         } else {
 158             /* bit area in free area */
 159             genInfo.bit_vect   = (BitWord *) genInfo.oldend + 1;
 160             if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1;
 161         }
 162     } else {
 163         genInfo.old_words = RTSflags.GcFlags.heapSize - genInfo.alloc_words - 2 * genInfo.new_words;
 164         genInfo.oldend    = heap_space + genInfo.old_words - 1;
 165         genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
 166                                          /* ToDo: extra old ind words not accounted for ! */
 167
 168         bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 169         if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
 170             /* bit vector in allocation area */
 171             genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
 172         } else {
 173             /* bit vector in reserved space in old generation */
 174             bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 175
 176             genInfo.bit_vect   = (BitWord *) heap_space;
 177             genInfo.oldbase   += bit_words;
 178             genInfo.old_words -= bit_words;
 179         }
 180         if (genInfo.oldbase > genInfo.oldthresh) heap_error = 1;
 181     }
 182
 183     if (heap_error) {
 184         fprintf(stderr, "initHeap: Requested heap size: %ld\n", RTSflags.GcFlags.heapSize);
 185         fprintf(stderr, "          Alloc area %ld  Delay area %ld  Old area %ld  Bit area %ld\n",
 186                                    genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words,
 187                                    genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words);
 188         fprintf(stderr, "          Heap not large enough for generational gc with these specs\n");
 189         fprintf(stderr, "          +RTS -H<size> option will increase heap size and/or\n");
 190         fprintf(stderr, "               -A<size> option will decrease allocation area\n");
 191         return -1;
 192     }
 193
 194
 195     genInfo.oldlim     = genInfo.oldbase - 1;
 196     genInfo.oldwas     = genInfo.oldbase - 1;
 197
 198     genInfo.curnew     = 0;
 199     genInfo.OldInNew   = 0;
 200     genInfo.OldInNewno = 0;
 201     genInfo.NewCAFlist = NULL;
 202     genInfo.NewCAFno   = 0;
 203     genInfo.OldCAFlist = NULL;
 204     genInfo.OldCAFno   = 0;
 205
 206     genInfo.PromMutables = 0;
 207
 208     sm->hp = hp_start = genInfo.allocbase - 1;
 209     sm->hplim = genInfo.alloclim;
 210
 211     sm->OldLim = genInfo.oldlim;
 212     sm->CAFlist = NULL;
 213
 214 #ifndef PAR
 215     initExtensions( sm );
 216 #endif
 217
 218     if (RTSflags.GcFlags.trace) {
 219         fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n",
 220                 (W_) heap_space, (W_) (heap_space + RTSflags.GcFlags.heapSize - 1));
 221         fprintf(stderr, "          alloc %ld, new %ld, old %ld, bit %ld\n",
 222                 genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words);
 223         fprintf(stderr, "          allocbase 0x%lx, alloclim 0x%lx\n",
 224                 (W_) genInfo.allocbase, (W_) genInfo.alloclim);
 225         fprintf(stderr, "          newbases 0x%lx 0x%lx\n",
 226                 (W_) genInfo.newgen[0].newbase, (W_) genInfo.newgen[1].newbase);
 227         fprintf(stderr, "          oldbase 0x%lx oldthresh 0x%lx bits 0x%lx\n",
 228                 (W_) genInfo.oldbase, (W_) genInfo.oldthresh, (W_) genInfo.bit_vect);
 229         fprintf(stderr, "          hp 0x%lx, hplim 0x%lx\n",
 230                 (W_) sm->hp, (W_) sm->hplim);
 231     }
 232
 233     return 0;
 234 }
 235
 236 I_
 237 collect2s(reqsize, sm)
 238     W_ reqsize;
 239     smInfo *sm;
 240 {
 241     I_  root, bstk_roots, caf_roots, extra_caf_words;
 242     PP_ stackptr;
 243     P_  CAFptr, updateFramePtr, caf_start;
 244
 245     I_ free_space,      /* No of words of free space following GC */
 246         alloc,          /* Number of words allocated since last GC */
 247         resident;       /* Number of words remaining after GC */
 248
 249     SAVE_REGS(&ScavRegDump); /* Save registers */
 250
 251     if (RTSflags.GcFlags.trace)
 252         fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, req %lu\n",
 253                 genInfo.semi_space,
 254                 (W_) genInfo.space[genInfo.semi_space].base,
 255                 (W_) genInfo.space[genInfo.semi_space].lim,
 256                 (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
 257
 258     alloc = sm->hp - hp_start;
 259     stat_startGC(alloc);
 260
 261     genInfo.semi_space = NEXT_SEMI_SPACE(genInfo.semi_space);
 262     ToHp = genInfo.space[genInfo.semi_space].base - 1;
 263     Scav = genInfo.space[genInfo.semi_space].base;
 264     OldGen = sm->OldLim; /* always evac ! */
 265
 266     DEBUG_STRING("Setting Evac & Upd CAFs:");
 267     for (CAFptr = sm->CAFlist; CAFptr;
 268          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 269         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 270     }
 271
 272 #ifdef PAR
 273     EvacuateLocalGAs(rtsTrue);
 274 #else
 275     evacSPTable( sm );
 276 #endif /* PAR */
 277
 278     DEBUG_STRING("Evacuate Roots:");
 279     for (root = 0; root < sm->rootno; root++) {
 280         P_ evac = sm->roots[root];
 281         sm->roots[root] = EVACUATE_CLOSURE(evac);
 282     }
 283
 284 #if !defined(PAR)
 285
 286     DEBUG_STRING("Evacuate A Stack:");
 287     for (stackptr = MAIN_SpA;
 288          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
 289                 /* botA points to bottom-most word */
 290          stackptr = stackptr + AREL(1)) {
 291         P_ evac = *stackptr;
 292         *stackptr = EVACUATE_CLOSURE(evac);
 293     }
 294     DEBUG_STRING("Evacuate B Stack:");
 295     bstk_roots = 0;
 296     for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
 297          SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
 298                 /* botB points to bottom-most word */
 299          /* re-initialiser given explicitly */) {
 300
 301         P_ evac = GRAB_UPDATEE(updateFramePtr);
 302         PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
 303         bstk_roots++;
 304
 305         updateFramePtr = GRAB_SuB(updateFramePtr);
 306     }
 307 #endif  /* PAR */
 308
 309     DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
 310     while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 311     DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 312
 313     DEBUG_STRING("Evacuate & Scavenge CAFs:");
 314     caf_roots = 0;
 315     caf_start = ToHp;
 316     for (CAFptr = sm->CAFlist; CAFptr;
 317          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 318
 319         EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
 320         caf_roots++;
 321
 322         DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
 323         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 324         DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 325
 326         /* this_extra_caf_words = ToHp - this_caf_start; */
 327         /* ToDo: Report individual CAF space */
 328     }
 329     extra_caf_words = ToHp - caf_start;
 330
 331 #ifdef PAR
 332     RebuildGAtables(rtsTrue);
 333 #else
 334     reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
 335 #endif /* PAR */
 336
 337     /* TIDY UP AND RETURN */
 338
 339     sm->hp = hp_start = ToHp;  /* Last allocated word */
 340     sm->hplim = genInfo.space[genInfo.semi_space].lim;
 341
 342     resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1);
 343     /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
 344     free_space = sm->hplim - sm->hp;
 345
 346     if (RTSflags.GcFlags.giveStats) {
 347         char comment_str[BIG_STRING_LEN];
 348 #ifndef PAR
 349         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 350                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 351                 bstk_roots, sm->rootno,
 352                 caf_roots, extra_caf_words*sizeof(W_),
 353                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
 354                 (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
 355 #else
 356         /* ToDo: come up with some interesting statistics for the parallel world */
 357         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 358                 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
 359 #endif
 360         stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
 361     } else {
 362         stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
 363     }
 364
 365     if (RTSflags.GcFlags.trace)
 366         fprintf(stderr, "Done:  space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, free %lu\n",
 367                 genInfo.semi_space,
 368                 (W_) genInfo.space[genInfo.semi_space].base,
 369                 (W_) genInfo.space[genInfo.semi_space].lim,
 370                 (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
 371
 372 #ifdef DEBUG
 373     /* To help flush out bugs, we trash the part of the heap from
 374        which we're about to start allocating. */
 375     TrashMem(sm->hp+1, sm->hplim);
 376 #endif /* DEBUG */
 377
 378     RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 379
 380     if ((RTSflags.GcFlags.allocAreaSize > free_space) || (reqsize > free_space))
 381         return(-1);     /* Heap exhausted */
 382
 383     return(0);          /* Heap OK */
 384 }
 385
 386
 387 I_
 388 collectHeap(reqsize, sm)
 389     W_ reqsize;
 390     smInfo *sm;
 391 {
 392     PP_ stackptr, botA;
 393     P_    mutptr, prevmut, updateFramePtr, botB,
 394               CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp,
 395               oldscav, newscav;
 396     I_    root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs,
 397               alloc_oldroots, new_oldroots, old_words;
 398
 399     I_    bit_words;
 400     P_    oldlim;
 401     PP_ CAFlocs, CAFloc;
 402
 403        I_ alloc,        /* number of words allocated since last GC */
 404         collect,        /* number of words collected */
 405         promote,        /* number of words promoted  */
 406         resident,       /* number of words remaining */
 407         total_resident; /* total number of words remaining after major collection */
 408
 409     fflush(stdout);     /* Flush stdout at start of GC */
 410
 411     if (RTSflags.GcFlags.force2s) {
 412         return collect2s(reqsize, sm);
 413     }
 414
 415
 416     if (reqsize > genInfo.alloc_words) {
 417         fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n",
 418                 reqsize, genInfo.alloc_words);
 419         fprintf(stderr, "             Rerun using  +RTS -A<size>  to increase allocation area\n");
 420         EXIT(EXIT_FAILURE);
 421     }
 422
 423     SAVE_REGS(&ScavRegDump);        /* Save registers */
 424
 425     if (RTSflags.GcFlags.trace)
 426         fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld  Minor\n",
 427                           (W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_)));
 428
 429     alloc = sm->hp - hp_start;
 430     stat_startGC(alloc);
 431
 432     /* MINOR COLLECTION WITH PROMOTION */
 433
 434     collect = alloc + (genInfo.newgen[genInfo.curnew].newlim - genInfo.newgen[genInfo.curnew].newbase + 1);
 435     genInfo.curnew = (genInfo.curnew + 1) % 2;
 436
 437     ToHp     = genInfo.newgen[genInfo.curnew].newbase - 1;
 438     OldGen   = genInfo.oldend;     /* <= OldGen indicates in the old generation */
 439
 440     AllocGen = genInfo.allocbase;  /* < AllocGen indicates in delay bucket -> promote */
 441     OldHp    = genInfo.oldlim;
 442
 443     newscav  = genInfo.newgen[genInfo.curnew].newbase; /* Point to (info field of) first closure */
 444     oldscav  = genInfo.oldlim + 1;                     /* Point to (info field of) first closure */
 445
 446
 447     DEBUG_STRING("Setting Evac & Upd CAFs:");
 448     for (CAFptr = sm->CAFlist; CAFptr;
 449          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 450         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 451     }
 452     for (CAFptr = genInfo.NewCAFlist; CAFptr;
 453          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 454         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 455     }
 456
 457
 458     /* FIRST: Evacuate and scavenge OldMutable, Roots, AStk & BStk */
 459     /* Ensure these roots don't use old generation root indirection when evacuated */
 460     Scav = newscav;
 461
 462     DEBUG_STRING("Evacuate Roots:");
 463     for (root = 0, rootno = sm->rootno; root < rootno; root++) {
 464         P_ evac = sm->roots[root];
 465         if (evac > OldGen) {
 466             sm->roots[root] = EVACUATE_CLOSURE(evac);
 467         }
 468     }
 469
 470 #if !defined(PAR)
 471     DEBUG_STRING("Evacuate A Stack:");
 472     for (stackptr = MAIN_SpA, botA = stackInfo.botA;
 473          SUBTRACT_A_STK(stackptr, botA) >= 0;
 474          stackptr = stackptr + AREL(1)) {
 475         P_ evac = *stackptr;
 476         if (evac > OldGen) {
 477             *stackptr = EVACUATE_CLOSURE(evac);
 478         }
 479     }
 480     DEBUG_STRING("Evacuate B Stack:");
 481     bstk_roots = 0;
 482     for (updateFramePtr = MAIN_SuB, botB = stackInfo.botB;
 483          SUBTRACT_B_STK(updateFramePtr, botB) > 0;
 484          /* re-initialiser given explicitly */) {
 485
 486         /* Evacuate the thing to be updated */
 487         P_ evac = GRAB_UPDATEE(updateFramePtr);
 488         if (evac > OldGen) {
 489             PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
 490         }
 491         bstk_roots++;
 492
 493         updateFramePtr = GRAB_SuB(updateFramePtr);
 494     }
 495 #endif  /* PAR */
 496
 497     DEBUG_STRING("Evacuate Mutable Roots:");
 498     mutable = 0;
 499     mutptr = sm->OldMutables;
 500     prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
 501                                 /* See MUT_LINK */
 502     while ( mutptr ) {
 503
 504         /* Scavenge the OldMutable closure */
 505         P_ info = (P_) INFO_PTR(mutptr);
 506         StgScavPtr scav_code = SCAV_CODE(info);
 507         Scav = mutptr;
 508         (scav_code)();
 509
 510         /* Remove from OldMutables if no longer mutable */
 511         /* HACK ALERT: See comment in SMap.lc
 512             about why we do this terrible pointer comparison.
 513         */
 514         if (info == ImMutArrayOfPtrs_info) { /* ToDo: use different test? (WDP 94/11) */
 515             P_ tmp = mutptr;
 516             MUT_LINK(prevmut) = MUT_LINK(mutptr);
 517             mutptr = (P_) MUT_LINK(mutptr);
 518             MUT_LINK(tmp) = MUT_NOT_LINKED;
 519         } else {
 520             prevmut = mutptr;
 521             mutptr = (P_) MUT_LINK(mutptr);
 522         }
 523         mutable++;
 524     }
 525
 526 #ifdef PAR
 527     EvacuateLocalGAs(rtsFalse);
 528 #else
 529     evacSPTable( sm );
 530 #endif /* PAR */
 531
 532     while ((newscav <= ToHp) || (oldscav <= OldHp)) {
 533         Scav = newscav;
 534         DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
 535         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 536         newscav = Scav;
 537
 538         Scav = oldscav;
 539         DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
 540         while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
 541         oldscav = Scav;
 542     }
 543
 544
 545     /* SECOND: Evacuate & Scavenge CAFs and OldGen roots */
 546     /* Ensure these roots don't use old generation root indirection when evacuated */
 547     Scav = newscav;
 548
 549     oldstartToHp  = ToHp;
 550     oldstartOldHp = OldHp;
 551
 552
 553     DEBUG_STRING("Evacuate CAFs and old generation roots:");
 554     /* Evacuate CAFs in allocation region to New semispace */
 555     /* Evacuate CAFs in New semispace to OldGen */
 556     /* OldCAFlist = NewCAFlist ++ OldCAFlist */
 557     /* NewCAFlist = CAFlist */
 558     /* CAFlist = NULL */
 559
 560     alloc_cafs = 0;
 561     for (CAFptr = sm->CAFlist; CAFptr;
 562          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 563         EVACUATE_CLOSURE(CAFptr); /* evac & upd */
 564         alloc_cafs++;
 565     }
 566
 567     for (CAFptr = genInfo.NewCAFlist,
 568          prevCAF = ((P_)(&genInfo.NewCAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
 569          CAFptr; CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 570         EVACUATE_CLOSURE(CAFptr); /* evac & upd */
 571         prevCAF = CAFptr;
 572     }
 573     new_cafs = genInfo.NewCAFno;
 574
 575     IND_CLOSURE_LINK(prevCAF) = (W_) genInfo.OldCAFlist;
 576     genInfo.OldCAFlist = genInfo.NewCAFlist;
 577     genInfo.OldCAFno += genInfo.NewCAFno;
 578
 579     genInfo.NewCAFlist = sm->CAFlist;
 580     genInfo.NewCAFno = alloc_cafs;
 581     sm->CAFlist = NULL;
 582
 583
 584     /* Evacuate OldRoots roots to New semispace */
 585     /* Evacuate OldInNew roots to OldGen, discard these roots */
 586     /* OldInNew = OldRoots */
 587     /* OldRoots = 0 */
 588
 589     for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
 590         P_ evac = (P_) IND_CLOSURE_PTR(oldroot);
 591         if (evac > OldGen) {
 592             IND_CLOSURE_PTR(oldroot) = (W_) EVACUATE_CLOSURE(evac);
 593         }
 594     }
 595     new_oldroots = genInfo.OldInNewno;
 596
 597     DEBUG_STRING("Scavenge evacuated old generation roots:");
 598     while ((newscav <= ToHp) || (oldscav <= OldHp)) {
 599         Scav = newscav;
 600         DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
 601         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 602         newscav = Scav;
 603
 604         Scav = oldscav;
 605         DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
 606         while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
 607         oldscav = Scav;
 608     }
 609
 610     old_words = OldHp - oldstartOldHp;  /* + (ToHp - oldstartToHp) */
 611
 612
 613     /* record newly promoted mutuple roots */
 614     MUT_LINK(prevmut) = (W_) genInfo.PromMutables;
 615     genInfo.PromMutables = 0;
 616
 617
 618     promote  = OldHp - genInfo.oldlim;
 619     resident = (ToHp - genInfo.newgen[genInfo.curnew].newbase + 1) + promote;
 620
 621     genInfo.newgen[genInfo.curnew].newlim = ToHp;
 622     genInfo.oldlim = OldHp;
 623
 624     genInfo.minor_since_major++;
 625
 626 #ifdef PAR
 627     RebuildGAtables(rtsFalse);
 628 #else
 629     reportDeadMallocPtrs(sm->MallocPtrList,
 630                          sm->OldMallocPtrList,
 631                          &(sm->OldMallocPtrList));
 632     sm->MallocPtrList = NULL;   /* all (new) MallocPtrs have been promoted */
 633 #endif /* PAR */
 634
 635     if (RTSflags.GcFlags.giveStats) {
 636         char minor_str[BIG_STRING_LEN];
 637 #ifndef PAR
 638         sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
 639                 promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots,
 640                 (I_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 641                 bstk_roots, sm->rootno, alloc_cafs + new_cafs,
 642                 mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
 643 #else
 644         /* ToDo: come up with some interesting statistics for the parallel world */
 645         sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
 646                 promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, 0,
 647                 0, sm->rootno, alloc_cafs + new_cafs,
 648                 mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
 649 #endif
 650         stat_endGC(alloc, collect, resident, minor_str);
 651     } else {
 652         stat_endGC(alloc, collect, resident, "");
 653     }
 654
 655     /* ToDo: Decide to do major early ! */
 656
 657     if (genInfo.oldlim <= genInfo.oldthresh  && !do_full_collection) {
 658
 659         sm->hp = hp_start = genInfo.allocbase - 1;
 660         sm->hplim = genInfo.alloclim;
 661         sm->OldLim = genInfo.oldlim;
 662
 663         if (RTSflags.GcFlags.trace)
 664             fprintf(stderr, "GEN End: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %lu\n",
 665                     (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
 666                     (W_) genInfo.newgen[genInfo.curnew].newbase,
 667                     (W_) genInfo.newgen[genInfo.curnew].newlim,
 668                     (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
 669
 670         RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 671
 672         return GC_SUCCESS;      /* Heap OK -- Enough space to continue */
 673     }
 674
 675
 676     DEBUG_STRING("Major Collection Required");
 677     stat_startGC(0);
 678
 679     alloc = genInfo.oldlim - genInfo.oldbase + 1;
 680
 681     /* Zero bit vector for marking phase of major collection */
 682
 683     bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 684     { BitWord *ptr = genInfo.bit_vect,
 685               *end = genInfo.bit_vect + bit_words;
 686       while (ptr < end) { *(ptr++) = 0; };
 687     }
 688
 689     /* Set are for old gen CAFs to be linked */
 690
 691     CAFlocs = (PP_) genInfo.newgen[(genInfo.curnew + 1) % 2].newbase;
 692     if (genInfo.new_words < genInfo.OldCAFno) {
 693         fprintf(stderr, "colectHeap: Too many CAFs %ld to link in new semi-space %ld\n",
 694                 genInfo.OldCAFno, genInfo.alloc_words);
 695         fprintf(stderr, "            Rerun using  +RTS -A<size>  to increase allocation area\n");
 696         EXIT(EXIT_FAILURE);
 697     }
 698
 699     /* Change old generation root indirections to special OldRoot indirections */
 700     /* These will be marked and not short circuted (like SPEC 2,1 closure)     */
 701
 702     for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
 703         INFO_PTR(oldroot) = (W_) OldRoot_info;
 704     }
 705
 706     /* Discard OldInNew roots: Scanning OldRoots will reconstruct live OldInNew root list */
 707     genInfo.OldInNew = 0;
 708     genInfo.OldInNewno = 0;
 709
 710     /* Discard OldMutable roots: Scanning Mutables will reconstruct live OldMutables root list */
 711     sm->OldMutables = 0;
 712
 713     /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
 714     RESTORE_REGS(&ScavRegDump);
 715
 716     markHeapRoots(sm, genInfo.NewCAFlist, genInfo.OldCAFlist,
 717                   genInfo.oldbase, genInfo.oldlim, genInfo.bit_vect);
 718
 719     SAVE_REGS(&ScavRegDump);
 720     /* end of bracket */
 721
 722 #ifndef PAR
 723     sweepUpDeadMallocPtrs(sm->OldMallocPtrList,
 724                           appelInfo.oldbase,
 725                           appelInfo.bits
 726                           );
 727 #endif /* !PAR */
 728
 729     oldlim = genInfo.oldlim;
 730
 731     DEBUG_STRING("Linking Dummy CAF Ptr Locations:");
 732     CAFloc = CAFlocs;
 733     for (CAFptr = genInfo.OldCAFlist; CAFptr;
 734          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 735         DEBUG_LINK_CAF(CAFptr, CAFloc);
 736         *CAFloc = (P_) IND_CLOSURE_PTR(CAFptr);
 737         LINK_LOCATION_TO_CLOSURE(CAFloc, oldlim);
 738         CAFloc++;
 739     }
 740
 741     DEBUG_STRING("Linking Roots:");
 742     for (root = 0; root < sm->rootno; root++) {
 743         LINK_LOCATION_TO_CLOSURE(sm->roots+root, oldlim);
 744     }
 745
 746 #ifdef PAR
 747     fall over here until we figure out how to link GAs
 748 #else
 749     DEBUG_STRING("Linking Stable Pointer Table:");
 750     LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim);
 751     DEBUG_STRING("Linking A Stack:");
 752     for (stackptr = MAIN_SpA;
 753          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
 754          stackptr = stackptr + AREL(1)) {
 755         LINK_LOCATION_TO_CLOSURE(stackptr, oldlim);
 756     }
 757     DEBUG_STRING("Linking B Stack:");
 758     for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
 759          SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
 760          /* re-initialiser given explicitly */) {
 761
 762         P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
 763         LINK_LOCATION_TO_CLOSURE(updateClosurePtr, oldlim);
 764
 765         updateFramePtr = GRAB_SuB(updateFramePtr);
 766     }
 767 #endif  /* PAR */
 768
 769     /* Do Inplace Compaction */
 770     /* Returns start of next closure, -1 gives last allocated word */
 771
 772     genInfo.oldlim = Inplace_Compaction(genInfo.oldbase,
 773                                         genInfo.oldlim,
 774                                         genInfo.newgen[genInfo.curnew].newbase,
 775                                         genInfo.newgen[genInfo.curnew].newlim,
 776                                         genInfo.bit_vect, bit_words) - 1;
 777
 778     resident = (genInfo.oldlim - genInfo.oldbase) + 1;
 779     total_resident = genInfo.newgen[genInfo.curnew].newlim -
 780                      genInfo.newgen[genInfo.curnew].newbase + 1 + resident;
 781
 782     sm->hp = hp_start = genInfo.allocbase - 1;
 783     sm->hplim = genInfo.alloclim;
 784     sm->OldLim = genInfo.oldlim;
 785
 786     genInfo.oldwas = genInfo.oldlim;
 787     genInfo.minor_since_major = 0;
 788
 789     if (RTSflags.GcFlags.giveStats) {
 790         char major_str[BIG_STRING_LEN];
 791 #ifndef PAR
 792         sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
 793                 0, genInfo.OldInNewno,
 794                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 795                 bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
 796                 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
 797 #else
 798         sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
 799                 0, genInfo.OldInNewno,
 800                 0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
 801                 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
 802 #endif
 803         stat_endGC(0, alloc, resident, major_str);
 804     } else {
 805         stat_endGC(0, alloc, resident, "");
 806     }
 807
 808     if (RTSflags.GcFlags.trace)
 809         fprintf(stderr, "GEN Major: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n           hp 0x%lx, hplim 0x%lx, free %lu\n",
 810                 (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
 811                 (W_) genInfo.newgen[genInfo.curnew].newbase,
 812                 (W_) genInfo.newgen[genInfo.curnew].newlim,
 813                 (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
 814
 815 #ifdef DEBUG
 816     /* To help flush out bugs, we trash the part of the heap from
 817        which we're about to start allocating. */
 818     TrashMem(sm->hp+1, sm->hplim);
 819 #endif /* DEBUG */
 820
 821     RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 822
 823     if (genInfo.oldlim > genInfo.oldthresh)
 824         return GC_HARD_LIMIT_EXCEEDED;  /* Heap exhausted */
 825     else
 826         return GC_SUCCESS;              /* Heap OK */
 827 }
 828
 829 #endif /* GCgn */
 830
 831 \end{code}
 832