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 I_
  61 initHeap( sm )
  62     smInfo *sm;
  63 {
  64     I_ heap_error = 0;
  65     I_ bit_words;
  66
  67     /* should cause link error */
  68     ADRpanic("Completely untested on SP and MP stuff... also doesn't benefit from commoning up in SMcopying and SMcompacting");
  69
  70     if (heap_space == 0) { /* allocates if it doesn't already exist */
  71
  72         /* Allocate the roots space */
  73         sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
  74
  75         /* Allocate the heap */
  76         heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
  77
  78         if (SM_force_gc == USE_2s) {
  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 (SM_force_gc == USE_2s) {
  90         genInfo.semi_space = SM_word_heap_size / 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 (SM_alloc_size) {
 101             sm->hplim = sm->hp + SM_alloc_size;
 102             SM_alloc_min = 0; /* No min; alloc size specified */
 103
 104             if (sm->hplim > genInfo.space[genInfo.semi_space].lim) {
 105                 fprintf(stderr, "Not enough heap for requested alloc size\n");
 106                 return -1;
 107             }
 108         } else {
 109             sm->hplim = genInfo.space[genInfo.semi_space].lim;
 110         }
 111
 112         sm->OldLim = genInfo.oldlim;
 113         sm->CAFlist = NULL;
 114
 115 #ifndef PAR
 116         initExtensions( sm );
 117 #endif
 118
 119         if (SM_trace) {
 120             fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n",
 121                     (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
 122             fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n         hp 0x%lx, hplim 0x%lx, free %ld\n",
 123                     genInfo.semi_space,
 124                     (W_) genInfo.space[genInfo.semi_space].base,
 125                     (W_) genInfo.space[genInfo.semi_space].lim,
 126                     (W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp));
 127         }
 128         return 0;
 129     }
 130
 131     if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE;
 132
 133     genInfo.alloc_words = SM_alloc_size;
 134     genInfo.new_words   = SM_alloc_size;
 135
 136     genInfo.allocbase  = heap_space + SM_word_heap_size - genInfo.alloc_words;
 137     genInfo.alloclim   = heap_space + SM_word_heap_size - 1;
 138
 139     genInfo.newgen[0].newbase   = genInfo.allocbase - genInfo.new_words;
 140     genInfo.newgen[0].newlim    = genInfo.newgen[0].newbase - 1;
 141
 142     genInfo.newgen[1].newbase   = genInfo.allocbase - 2 * genInfo.new_words;
 143     genInfo.newgen[1].newlim    = genInfo.newgen[1].newbase - 1;
 144
 145     genInfo.oldbase = heap_space;
 146
 147     if (SM_major_gen_size) {
 148         genInfo.old_words = SM_major_gen_size;
 149         genInfo.oldend    = heap_space + genInfo.old_words - 1;
 150         genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
 151                                          /* ToDo: extra old ind words not accounted for ! */
 152
 153         bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 154         if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
 155             /* bit vector in allocation area */
 156             genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
 157             if (genInfo.oldend >= genInfo.newgen[1].newbase) heap_error = 1;
 158         } else {
 159             /* bit area in free area */
 160             genInfo.bit_vect   = (BitWord *) genInfo.oldend + 1;
 161             if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1;
 162         }
 163     } else {
 164         genInfo.old_words = SM_word_heap_size - genInfo.alloc_words - 2 * genInfo.new_words;
 165         genInfo.oldend    = heap_space + genInfo.old_words - 1;
 166         genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
 167                                          /* ToDo: extra old ind words not accounted for ! */
 168
 169         bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 170         if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
 171             /* bit vector in allocation area */
 172             genInfo.bit_vect  = (BitWord *) genInfo.allocbase;
 173         } else {
 174             /* bit vector in reserved space in old generation */
 175             bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
 176
 177             genInfo.bit_vect   = (BitWord *) heap_space;
 178             genInfo.oldbase   += bit_words;
 179             genInfo.old_words -= bit_words;
 180         }
 181         if (genInfo.oldbase > genInfo.oldthresh) heap_error = 1;
 182     }
 183
 184     if (heap_error) {
 185         fprintf(stderr, "initHeap: Requested heap size: %ld\n", SM_word_heap_size);
 186         fprintf(stderr, "          Alloc area %ld  Delay area %ld  Old area %ld  Bit area %ld\n",
 187                                    genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words,
 188                                    genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words);
 189         fprintf(stderr, "          Heap not large enough for generational gc with these specs\n");
 190         fprintf(stderr, "          +RTS -H<size> option will increase heap size and/or\n");
 191         fprintf(stderr, "               -A<size> option will decrease allocation area\n");
 192         return -1;
 193     }
 194
 195
 196     genInfo.oldlim     = genInfo.oldbase - 1;
 197     genInfo.oldwas     = genInfo.oldbase - 1;
 198
 199     genInfo.curnew     = 0;
 200     genInfo.OldInNew   = 0;
 201     genInfo.OldInNewno = 0;
 202     genInfo.NewCAFlist = NULL;
 203     genInfo.NewCAFno   = 0;
 204     genInfo.OldCAFlist = NULL;
 205     genInfo.OldCAFno   = 0;
 206
 207     genInfo.PromMutables = 0;
 208
 209     sm->hp = hp_start = genInfo.allocbase - 1;
 210     sm->hplim = genInfo.alloclim;
 211
 212     sm->OldLim = genInfo.oldlim;
 213     sm->CAFlist = NULL;
 214
 215 #ifndef PAR
 216     initExtensions( sm );
 217 #endif
 218
 219     if (SM_trace) {
 220         fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n",
 221                 (W_) heap_space, (W_) (heap_space + SM_word_heap_size - 1));
 222         fprintf(stderr, "          alloc %ld, new %ld, old %ld, bit %ld\n",
 223                 genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words);
 224         fprintf(stderr, "          allocbase 0x%lx, alloclim 0x%lx\n",
 225                 (W_) genInfo.allocbase, (W_) genInfo.alloclim);
 226         fprintf(stderr, "          newbases 0x%lx 0x%lx\n",
 227                 (W_) genInfo.newgen[0].newbase, (W_) genInfo.newgen[1].newbase);
 228         fprintf(stderr, "          oldbase 0x%lx oldthresh 0x%lx bits 0x%lx\n",
 229                 (W_) genInfo.oldbase, (W_) genInfo.oldthresh, (W_) genInfo.bit_vect);
 230         fprintf(stderr, "          hp 0x%lx, hplim 0x%lx\n",
 231                 (W_) sm->hp, (W_) sm->hplim);
 232     }
 233
 234     return 0;
 235 }
 236
 237 I_
 238 collect2s(reqsize, sm)
 239     W_ reqsize;
 240     smInfo *sm;
 241 {
 242     I_  root, bstk_roots, caf_roots, extra_caf_words;
 243     PP_ stackptr;
 244     P_  CAFptr, updateFramePtr, caf_start;
 245
 246     I_ free_space,      /* No of words of free space following GC */
 247         alloc,          /* Number of words allocated since last GC */
 248         resident;       /* Number of words remaining after GC */
 249
 250     SAVE_REGS(&ScavRegDump); /* Save registers */
 251
 252     if (SM_trace)
 253         fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, req %lu\n",
 254                 genInfo.semi_space,
 255                 (W_) genInfo.space[genInfo.semi_space].base,
 256                 (W_) genInfo.space[genInfo.semi_space].lim,
 257                 (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
 258
 259     alloc = sm->hp - hp_start;
 260     stat_startGC(alloc);
 261
 262     genInfo.semi_space = NEXT_SEMI_SPACE(genInfo.semi_space);
 263     ToHp = genInfo.space[genInfo.semi_space].base - 1;
 264     Scav = genInfo.space[genInfo.semi_space].base;
 265     OldGen = sm->OldLim; /* always evac ! */
 266
 267     DEBUG_STRING("Setting Evac & Upd CAFs:");
 268     for (CAFptr = sm->CAFlist; CAFptr;
 269          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 270         INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
 271     }
 272
 273 #ifdef PAR
 274     EvacuateLocalGAs(rtsTrue);
 275 #else
 276     evacSPTable( sm );
 277 #endif /* PAR */
 278
 279     DEBUG_STRING("Evacuate Roots:");
 280     for (root = 0; root < sm->rootno; root++) {
 281         P_ evac = sm->roots[root];
 282         sm->roots[root] = EVACUATE_CLOSURE(evac);
 283     }
 284
 285 #if !defined(PAR)
 286
 287     DEBUG_STRING("Evacuate A Stack:");
 288     for (stackptr = MAIN_SpA;
 289          SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
 290                 /* botA points to bottom-most word */
 291          stackptr = stackptr + AREL(1)) {
 292         P_ evac = *stackptr;
 293         *stackptr = EVACUATE_CLOSURE(evac);
 294     }
 295     DEBUG_STRING("Evacuate B Stack:");
 296     bstk_roots = 0;
 297     for (updateFramePtr = MAIN_SuB;   /* SuB points to topmost update frame */
 298          SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
 299                 /* botB points to bottom-most word */
 300          /* re-initialiser given explicitly */) {
 301
 302         P_ evac = GRAB_UPDATEE(updateFramePtr);
 303         PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
 304         bstk_roots++;
 305
 306         updateFramePtr = GRAB_SuB(updateFramePtr);
 307     }
 308 #endif  /* PAR */
 309
 310     DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
 311     while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 312     DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 313
 314     DEBUG_STRING("Evacuate & Scavenge CAFs:");
 315     caf_roots = 0;
 316     caf_start = ToHp;
 317     for (CAFptr = sm->CAFlist; CAFptr;
 318          CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
 319
 320         EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
 321         caf_roots++;
 322
 323         DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
 324         while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
 325         DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
 326
 327         /* this_extra_caf_words = ToHp - this_caf_start; */
 328         /* ToDo: Report individual CAF space */
 329     }
 330     extra_caf_words = ToHp - caf_start;
 331
 332 #ifdef PAR
 333     RebuildGAtables(rtsTrue);
 334 #else
 335     reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
 336 #endif /* PAR */
 337
 338     /* TIDY UP AND RETURN */
 339
 340     sm->hp = hp_start = ToHp;  /* Last allocated word */
 341     sm->hplim = genInfo.space[genInfo.semi_space].lim;
 342
 343     resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1);
 344     /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
 345     free_space = sm->hplim - sm->hp;
 346
 347     if (SM_stats_verbose) {
 348         char comment_str[BIG_STRING_LEN];
 349 #ifndef PAR
 350         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 351                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
 352                 bstk_roots, sm->rootno,
 353                 caf_roots, extra_caf_words*sizeof(W_),
 354                 (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
 355                 (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
 356 #else
 357         /* ToDo: come up with some interesting statistics for the parallel world */
 358         sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu  2s",
 359                 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
 360 #endif
 361         stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
 362     } else {
 363         stat_endGC(alloc, SM_word_heap_size, resident, "");
 364     }
 365
 366     if (SM_trace)
 367         fprintf(stderr, "Done:  space %ld, base 0x%lx, lim 0x%lx\n       hp 0x%lx, hplim 0x%lx, free %lu\n",
 368                 genInfo.semi_space,
 369                 (W_) genInfo.space[genInfo.semi_space].base,
 370                 (W_) genInfo.space[genInfo.semi_space].lim,
 371                 (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
 372
 373 #ifdef DEBUG
 374     /* To help flush out bugs, we trash the part of the heap from
 375        which we're about to start allocating. */
 376     TrashMem(sm->hp+1, sm->hplim);
 377 #endif /* DEBUG */
 378
 379     RESTORE_REGS(&ScavRegDump);     /* Restore Registers */
 380
 381     if ((SM_alloc_size > free_space) || (reqsize > free_space))
 382         return(-1);     /* Heap exhausted */
 383
 384     return(0);          /* Heap OK */
 385 }
 386
 387
 388 I_
 389 collectHeap(reqsize, sm)
 390     W_ reqsize;
 391     smInfo *sm;
 392 {
 393     PP_ stackptr, botA;
 394     P_    mutptr, prevmut, updateFramePtr, botB,
 395               CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp,
 396               oldscav, newscav;
 397     I_    root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs,
 398               alloc_oldroots, new_oldroots, old_words;
 399
 400     I_    bit_words;
 401     P_    oldlim;
 402     PP_ CAFlocs, CAFloc;
 403
 404        I_ alloc,        /* number of words allocated since last GC */
 405         collect,        /* number of words collected */
 406         promote,        /* number of words promoted  */
 407         resident,       /* number of words remaining */
 408         total_resident; /* total number of words remaining after major collection */
 409
 410     fflush(stdout);     /* Flush stdout at start of GC */
 411
 412     if (SM_force_gc == USE_2s) {
 413         return collect2s(reqsize, sm);
 414     }
 415
 416
 417     if (reqsize > genInfo.alloc_words) {
 418         fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n",
 419                 reqsize, genInfo.alloc_words);
 420         fprintf(stderr, "             Rerun using  +RTS -A<size>  to increase allocation area\n");
 421         EXIT(EXIT_FAILURE);
 422     }
 423
 424     SAVE_REGS(&ScavRegDump);        /* Save registers */
 425
 426     if (SM_trace) 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 (SM_stats_verbose) {
 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 (SM_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 (SM_stats_verbose) {
 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 / (StgFloat) SM_word_heap_size * 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 / (StgFloat) SM_word_heap_size * 100);
 802 #endif
 803         stat_endGC(0, alloc, resident, major_str);
 804     } else {
 805         stat_endGC(0, alloc, resident, "");
 806     }
 807
 808     if (SM_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