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 ); stable pointers now reachable via sm->roots */
 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(GRAN)
 285     /* ToDo: Add evacuation of events and sparks here */
 286 #if defined(KLINGON_ERROR_MESSAGES)
 287     fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
 288     EXIT(EXIT_FAILURE);
 289 #else
 290     fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
 291     EXIT(EXIT_FAILURE);
 292 #endif
 293 #endif
 294
 295 #if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
 296
 297     DEBUG_STRING("Evacuate A Stack:");
 298     for (stackptr = MAIN_SpA;
 299          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
 300                 /* botA points to bottom-most word */
 301          stackptr = stackptr + AREL(1)) {
 302         P_ evac = *stackptr;
 303         *stackptr = EVACUATE_CLOSURE(evac);
 304     }
 305     DEBUG_STRING("Evacuate B Stack:");
 306     bstk_roots = 0;
 307     for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
 308          SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
 309                 /* botB points to bottom-most word */
 310          /* re-initialiser given explicitly */) {
 311
 312         P_ evac = GRAB_UPDATEE(updateFramePtr);
 313         PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
 314         bstk_roots++;
 315
 316         updateFramePtr = GRAB_SuB(updateFramePtr);
 317     }
 318 #endif  /* PAR */
 319
 320     DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
 321     while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 322     DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 323
 324     DEBUG_STRING("Evacuate & Scavenge CAFs:");
 325     caf_roots = 0;
 326     caf_start = ToHp;
 327     for (CAFptr = sm->CAFlist; CAFptr;
 328          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 329
 330         EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
 331         caf_roots++;
 332
 333         DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
 334         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 335         DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 336
 337         /* this_extra_caf_words = ToHp - this_caf_start; */
 338         /* ToDo: Report individual CAF space */
 339     }
 340     extra_caf_words = ToHp - caf_start;
 341
 342 #ifdef PAR
 343     RebuildGAtables(rtsTrue);
 344 #else
 345     reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
 346 #endif /* PAR */
 347
 348     /* TIDY UP AND RETURN */
 349
 350     sm->hp = hp_start = ToHp;  /* Last allocated word */
 351     sm->hplim = genInfo.space[genInfo.semi_space].lim;
 352
 353     resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1);
 354     /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
 355     free_space = sm->hplim - sm->hp;
 356
 357     if (RTSflags.GcFlags.giveStats) {
 358         char comment_str[BIG_STRING_LEN];
 359 #ifndef PAR
 360         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 361                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 362                 bstk_roots, sm->rootno,
 363                 caf_roots, extra_caf_words*sizeof(W_),
 364                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
 365                 (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
 366 #else
 367         /* ToDo: come up with some interesting statistics for the parallel world */
 368         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 369                 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
 370 #endif
 371         stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
 372     } else {
 373         stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
 374     }
 375
 376     if (RTSflags.GcFlags.trace)
 377         fprintf(stderr, "Done:  space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, free %lu\n",
 378                 genInfo.semi_space,
 379                 (W_) genInfo.space[genInfo.semi_space].base,
 380                 (W_) genInfo.space[genInfo.semi_space].lim,
 381                 (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
 382
 383 #ifdef DEBUG
 384     /* To help flush out bugs, we trash the part of the heap from
 385        which we're about to start allocating. */
 386     TrashMem(sm->hp+1, sm->hplim);
 387 #endif /* DEBUG */
 388
 389     RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 390
 391     if ((RTSflags.GcFlags.allocAreaSize > free_space) || (reqsize > free_space))
 392         return(-1);     /* Heap exhausted */
 393
 394     return(0);          /* Heap OK */
 395 }
 396
 397
 398 I_
 399 collectHeap(reqsize, sm)
 400     W_ reqsize;
 401     smInfo *sm;
 402 {
 403     PP_ stackptr, botA;
 404     P_    mutptr, prevmut, updateFramePtr, botB,
 405               CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp,
 406               oldscav, newscav;
 407     I_    root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs,
 408               alloc_oldroots, new_oldroots, old_words;
 409
 410     I_    bit_words;
 411     P_    oldlim;
 412     PP_ CAFlocs, CAFloc;
 413
 414        I_ alloc,        /* number of words allocated since last GC */
 415         collect,        /* number of words collected */
 416         promote,        /* number of words promoted  */
 417         resident,       /* number of words remaining */
 418         total_resident; /* total number of words remaining after major collection */
 419
 420     fflush(stdout);     /* Flush stdout at start of GC */
 421
 422     if (RTSflags.GcFlags.force2s) {
 423         return collect2s(reqsize, sm);
 424     }
 425
 426
 427     if (reqsize > genInfo.alloc_words) {
 428         fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n",
 429                 reqsize, genInfo.alloc_words);
 430         fprintf(stderr, "             Rerun using  +RTS -A<size>  to increase allocation area\n");
 431         EXIT(EXIT_FAILURE);
 432     }
 433
 434     SAVE_REGS(&ScavRegDump);        /* Save registers */
 435
 436     if (RTSflags.GcFlags.trace)
 437         fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld  Minor\n",
 438                           (W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_)));
 439
 440     alloc = sm->hp - hp_start;
 441     stat_startGC(alloc);
 442
 443     /* MINOR COLLECTION WITH PROMOTION */
 444
 445     collect = alloc + (genInfo.newgen[genInfo.curnew].newlim - genInfo.newgen[genInfo.curnew].newbase + 1);
 446     genInfo.curnew = (genInfo.curnew + 1) % 2;
 447
 448     ToHp     = genInfo.newgen[genInfo.curnew].newbase - 1;
 449     OldGen   = genInfo.oldend;     /* <= OldGen indicates in the old generation */
 450
 451     AllocGen = genInfo.allocbase;  /* < AllocGen indicates in delay bucket -> promote */
 452     OldHp    = genInfo.oldlim;
 453
 454     newscav  = genInfo.newgen[genInfo.curnew].newbase; /* Point to (info field of) first closure */
 455     oldscav  = genInfo.oldlim + 1;                     /* Point to (info field of) first closure */
 456
 457
 458     DEBUG_STRING("Setting Evac & Upd CAFs:");
 459     for (CAFptr = sm->CAFlist; CAFptr;
 460          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 461         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 462     }
 463     for (CAFptr = genInfo.NewCAFlist; CAFptr;
 464          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 465         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 466     }
 467
 468
 469     /* FIRST: Evacuate and scavenge OldMutable, Roots, AStk & BStk */
 470     /* Ensure these roots don't use old generation root indirection when evacuated */
 471     Scav = newscav;
 472
 473     DEBUG_STRING("Evacuate Roots:");
 474     for (root = 0, rootno = sm->rootno; root < rootno; root++) {
 475         P_ evac = sm->roots[root];
 476         if (evac > OldGen) {
 477             sm->roots[root] = EVACUATE_CLOSURE(evac);
 478         }
 479     }
 480
 481 #if defined(GRAN)
 482     /* ToDo: Add evacuation of events and sparks here */
 483 #if defined(KLINGON_ERROR_MESSAGES)
 484     fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
 485     EXIT(EXIT_FAILURE);
 486 #else
 487     fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
 488     EXIT(EXIT_FAILURE);
 489 #endif
 490 #endif
 491
 492 #if !defined(PAR)
 493     DEBUG_STRING("Evacuate A Stack:");
 494     for (stackptr = MAIN_SpA, botA = stackInfo.botA;
 495          SUBTRACT_A_STK(stackptr, botA) >= 0;
 496          stackptr = stackptr + AREL(1)) {
 497         P_ evac = *stackptr;
 498         if (evac > OldGen) {
 499             *stackptr = EVACUATE_CLOSURE(evac);
 500         }
 501     }
 502     DEBUG_STRING("Evacuate B Stack:");
 503     bstk_roots = 0;
 504     for (updateFramePtr = MAIN_SuB, botB = stackInfo.botB;
 505          SUBTRACT_B_STK(updateFramePtr, botB) > 0;
 506          /* re-initialiser given explicitly */) {
 507
 508         /* Evacuate the thing to be updated */
 509         P_ evac = GRAB_UPDATEE(updateFramePtr);
 510         if (evac > OldGen) {
 511             PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
 512         }
 513         bstk_roots++;
 514
 515         updateFramePtr = GRAB_SuB(updateFramePtr);
 516     }
 517 #endif  /* PAR */
 518
 519     DEBUG_STRING("Evacuate Mutable Roots:");
 520     mutable = 0;
 521     mutptr = sm->OldMutables;
 522     prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
 523                                 /* See MUT_LINK */
 524     while ( mutptr ) {
 525
 526         /* Scavenge the OldMutable closure */
 527         P_ info = (P_) INFO_PTR(mutptr);
 528         StgScavPtr scav_code = SCAV_CODE(info);
 529         Scav = mutptr;
 530         (scav_code)();
 531
 532         /* Remove from OldMutables if no longer mutable */
 533         /* HACK ALERT: See comment in SMap.lc
 534             about why we do this terrible pointer comparison.
 535         */
 536         if (info == ImMutArrayOfPtrs_info) { /* ToDo: use different test? (WDP 94/11) */
 537             P_ tmp = mutptr;
 538             MUT_LINK(prevmut) = MUT_LINK(mutptr);
 539             mutptr = (P_) MUT_LINK(mutptr);
 540             MUT_LINK(tmp) = MUT_NOT_LINKED;
 541         } else {
 542             prevmut = mutptr;
 543             mutptr = (P_) MUT_LINK(mutptr);
 544         }
 545         mutable++;
 546     }
 547
 548 #ifdef PAR
 549     EvacuateLocalGAs(rtsFalse);
 550 #else
 551     /* evacSPTable( sm ); stable pointers now reachable via sm->roots
 552        (see above)
 553     */
 554 #endif /* PAR */
 555
 556     while ((newscav <= ToHp) || (oldscav <= OldHp)) {
 557         Scav = newscav;
 558         DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
 559         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 560         newscav = Scav;
 561
 562         Scav = oldscav;
 563         DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
 564         while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
 565         oldscav = Scav;
 566     }
 567
 568
 569     /* SECOND: Evacuate & Scavenge CAFs and OldGen roots */
 570     /* Ensure these roots don't use old generation root indirection when evacuated */
 571     Scav = newscav;
 572
 573     oldstartToHp  = ToHp;
 574     oldstartOldHp = OldHp;
 575
 576
 577     DEBUG_STRING("Evacuate CAFs and old generation roots:");
 578     /* Evacuate CAFs in allocation region to New semispace */
 579     /* Evacuate CAFs in New semispace to OldGen */
 580     /* OldCAFlist = NewCAFlist ++ OldCAFlist */
 581     /* NewCAFlist = CAFlist */
 582     /* CAFlist = NULL */
 583
 584     alloc_cafs = 0;
 585     for (CAFptr = sm->CAFlist; CAFptr;
 586          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 587         EVACUATE_CLOSURE(CAFptr); /* evac & upd */
 588         alloc_cafs++;
 589     }
 590
 591     for (CAFptr = genInfo.NewCAFlist,
 592          prevCAF = ((P_)(&genInfo.NewCAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
 593          CAFptr; CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 594         EVACUATE_CLOSURE(CAFptr); /* evac & upd */
 595         prevCAF = CAFptr;
 596     }
 597     new_cafs = genInfo.NewCAFno;
 598
 599     IND_CLOSURE_LINK(prevCAF) = (W_) genInfo.OldCAFlist;
 600     genInfo.OldCAFlist = genInfo.NewCAFlist;
 601     genInfo.OldCAFno += genInfo.NewCAFno;
 602
 603     genInfo.NewCAFlist = sm->CAFlist;
 604     genInfo.NewCAFno = alloc_cafs;
 605     sm->CAFlist = NULL;
 606
 607
 608     /* Evacuate OldRoots roots to New semispace */
 609     /* Evacuate OldInNew roots to OldGen, discard these roots */
 610     /* OldInNew = OldRoots */
 611     /* OldRoots = 0 */
 612
 613     for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
 614         P_ evac = (P_) IND_CLOSURE_PTR(oldroot);
 615         if (evac > OldGen) {
 616             IND_CLOSURE_PTR(oldroot) = (W_) EVACUATE_CLOSURE(evac);
 617         }
 618     }
 619     new_oldroots = genInfo.OldInNewno;
 620
 621     DEBUG_STRING("Scavenge evacuated old generation roots:");
 622     while ((newscav <= ToHp) || (oldscav <= OldHp)) {
 623         Scav = newscav;
 624         DEBUG_SCAN("Scav:  NewScav", Scav, "ToHp", ToHp);
 625         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 626         newscav = Scav;
 627
 628         Scav = oldscav;
 629         DEBUG_SCAN("Scav:  OldScav", Scav, "OldHp", OldHp);
 630         while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
 631         oldscav = Scav;
 632     }
 633
 634     old_words = OldHp - oldstartOldHp;  /* + (ToHp - oldstartToHp) */
 635
 636
 637     /* record newly promoted mutuple roots */
 638     MUT_LINK(prevmut) = (W_) genInfo.PromMutables;
 639     genInfo.PromMutables = 0;
 640
 641
 642     promote  = OldHp - genInfo.oldlim;
 643     resident = (ToHp - genInfo.newgen[genInfo.curnew].newbase + 1) + promote;
 644
 645     genInfo.newgen[genInfo.curnew].newlim = ToHp;
 646     genInfo.oldlim = OldHp;
 647
 648     genInfo.minor_since_major++;
 649
 650 #ifdef PAR
 651     RebuildGAtables(rtsFalse);
 652 #else
 653     reportDeadForeignObjs(sm->ForeignObjList,
 654                          sm->OldForeignObjList,
 655                          &(sm->OldForeignObjList));
 656     sm->ForeignObjList = NULL;   /* all (new) ForeignObjs have been promoted */
 657 #endif /* PAR */
 658
 659     if (RTSflags.GcFlags.giveStats) {
 660         char minor_str[BIG_STRING_LEN];
 661 #ifndef PAR
 662         sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
 663                 promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots,
 664                 (I_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 665                 bstk_roots, sm->rootno, alloc_cafs + new_cafs,
 666                 mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
 667 #else
 668         /* ToDo: come up with some interesting statistics for the parallel world */
 669         sprintf(minor_str, "%6lu %4lu   %4lu %4ld %3ld %3ld %4ld  %3ld %3ld %6ld   Minor",
 670                 promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, 0,
 671                 0, sm->rootno, alloc_cafs + new_cafs,
 672                 mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
 673 #endif
 674         stat_endGC(alloc, collect, resident, minor_str);
 675     } else {
 676         stat_endGC(alloc, collect, resident, "");
 677     }
 678
 679     /* ToDo: Decide to do major early ! */
 680
 681     if (genInfo.oldlim <= genInfo.oldthresh  && !do_full_collection) {
 682
 683         sm->hp = hp_start = genInfo.allocbase - 1;
 684         sm->hplim = genInfo.alloclim;
 685         sm->OldLim = genInfo.oldlim;
 686
 687         if (RTSflags.GcFlags.trace)
 688             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",
 689                     (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
 690                     (W_) genInfo.newgen[genInfo.curnew].newbase,
 691                     (W_) genInfo.newgen[genInfo.curnew].newlim,
 692                     (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
 693
 694         RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 695
 696         return GC_SUCCESS;      /* Heap OK -- Enough space to continue */
 697     }
 698
 699
 700     DEBUG_STRING("Major Collection Required");
 701     stat_startGC(0);
 702
 703     alloc = genInfo.oldlim - genInfo.oldbase + 1;
 704
 705     /* Zero bit vector for marking phase of major collection */
 706
 707     bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 708     { BitWord *ptr = genInfo.bit_vect,
 709               *end = genInfo.bit_vect + bit_words;
 710       while (ptr < end) { *(ptr++) = 0; };
 711     }
 712
 713     /* Set are for old gen CAFs to be linked */
 714
 715     CAFlocs = (PP_) genInfo.newgen[(genInfo.curnew + 1) % 2].newbase;
 716     if (genInfo.new_words < genInfo.OldCAFno) {
 717         fprintf(stderr, "colectHeap: Too many CAFs %ld to link in new semi-space %ld\n",
 718                 genInfo.OldCAFno, genInfo.alloc_words);
 719         fprintf(stderr, "            Rerun using  +RTS -A<size>  to increase allocation area\n");
 720         EXIT(EXIT_FAILURE);
 721     }
 722
 723     /* Change old generation root indirections to special OldRoot indirections */
 724     /* These will be marked and not short circuted (like SPEC 2,1 closure)     */
 725
 726     for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
 727         INFO_PTR(oldroot) = (W_) OldRoot_info;
 728     }
 729
 730     /* Discard OldInNew roots: Scanning OldRoots will reconstruct live OldInNew root list */
 731     genInfo.OldInNew = 0;
 732     genInfo.OldInNewno = 0;
 733
 734     /* Discard OldMutable roots: Scanning Mutables will reconstruct live OldMutables root list */
 735     sm->OldMutables = 0;
 736
 737     /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
 738     RESTORE_REGS(&ScavRegDump);
 739
 740     markHeapRoots(sm, genInfo.NewCAFlist, genInfo.OldCAFlist,
 741                   genInfo.oldbase, genInfo.oldlim, genInfo.bit_vect);
 742
 743     SAVE_REGS(&ScavRegDump);
 744     /* end of bracket */
 745
 746 #ifndef PAR
 747     sweepUpDeadForeignObjs(sm->OldForeignObjList,
 748                           appelInfo.oldbase,
 749                           appelInfo.bits
 750                           );
 751 #endif /* !PAR */
 752
 753     oldlim = genInfo.oldlim;
 754
 755     DEBUG_STRING("Linking Dummy CAF Ptr Locations:");
 756     CAFloc = CAFlocs;
 757     for (CAFptr = genInfo.OldCAFlist; CAFptr;
 758          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 759         DEBUG_LINK_CAF(CAFptr, CAFloc);
 760         *CAFloc = (P_) IND_CLOSURE_PTR(CAFptr);
 761         LINK_LOCATION_TO_CLOSURE(CAFloc, oldlim);
 762         CAFloc++;
 763     }
 764
 765     DEBUG_STRING("Linking Roots:");
 766     for (root = 0; root < sm->rootno; root++) {
 767         LINK_LOCATION_TO_CLOSURE(sm->roots+root, oldlim);
 768     }
 769
 770 #ifdef PAR
 771     fall over here until we figure out how to link GAs
 772 #else
 773 /*  stable pointer root now included in sm->roots
 774     DEBUG_STRING("Linking Stable Pointer Table:");
 775     LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim);
 776 */
 777     DEBUG_STRING("Linking A Stack:");
 778     for (stackptr = MAIN_SpA;
 779          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
 780          stackptr = stackptr + AREL(1)) {
 781         LINK_LOCATION_TO_CLOSURE(stackptr, oldlim);
 782     }
 783     DEBUG_STRING("Linking B Stack:");
 784     for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
 785          SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
 786          /* re-initialiser given explicitly */) {
 787
 788         P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
 789         LINK_LOCATION_TO_CLOSURE(updateClosurePtr, oldlim);
 790
 791         updateFramePtr = GRAB_SuB(updateFramePtr);
 792     }
 793 #endif  /* PAR */
 794
 795     /* Do Inplace Compaction */
 796     /* Returns start of next closure, -1 gives last allocated word */
 797
 798     genInfo.oldlim = Inplace_Compaction(genInfo.oldbase,
 799                                         genInfo.oldlim,
 800                                         genInfo.newgen[genInfo.curnew].newbase,
 801                                         genInfo.newgen[genInfo.curnew].newlim,
 802                                         genInfo.bit_vect, bit_words) - 1;
 803
 804     resident = (genInfo.oldlim - genInfo.oldbase) + 1;
 805     total_resident = genInfo.newgen[genInfo.curnew].newlim -
 806                      genInfo.newgen[genInfo.curnew].newbase + 1 + resident;
 807
 808     sm->hp = hp_start = genInfo.allocbase - 1;
 809     sm->hplim = genInfo.alloclim;
 810     sm->OldLim = genInfo.oldlim;
 811
 812     genInfo.oldwas = genInfo.oldlim;
 813     genInfo.minor_since_major = 0;
 814
 815     if (RTSflags.GcFlags.giveStats) {
 816         char major_str[BIG_STRING_LEN];
 817 #ifndef PAR
 818         sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
 819                 0, genInfo.OldInNewno,
 820                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 821                 bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
 822                 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
 823 #else
 824         sprintf(major_str, "%6d %4ld   %4u %4ld %3ld %3ld %4d  %3d %3d %6.6s  *Major* %4.1f%%",
 825                 0, genInfo.OldInNewno,
 826                 0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
 827                 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
 828 #endif
 829         stat_endGC(0, alloc, resident, major_str);
 830     } else {
 831         stat_endGC(0, alloc, resident, "");
 832     }
 833
 834     if (RTSflags.GcFlags.trace)
 835         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",
 836                 (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
 837                 (W_) genInfo.newgen[genInfo.curnew].newbase,
 838                 (W_) genInfo.newgen[genInfo.curnew].newlim,
 839                 (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
 840
 841 #ifdef DEBUG
 842     /* To help flush out bugs, we trash the part of the heap from
 843        which we're about to start allocating. */
 844     TrashMem(sm->hp+1, sm->hplim);
 845 #endif /* DEBUG */
 846
 847     RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 848
 849     if (genInfo.oldlim > genInfo.oldthresh)
 850         return GC_HARD_LIMIT_EXCEEDED;  /* Heap exhausted */
 851     else
 852         return GC_SUCCESS;              /* Heap OK */
 853 }
 854
 855 #endif /* GCgn */
 856
 857 \end{code}
 858