ghc/runtime/c-as-asm/HpOverflow.lc

   1 \section[PerformGC]{Wrapper for heap overflow}
   2
   3 \begin{code}
   4 #include "rtsdefs.h"
   5 \end{code}
   6
   7 @PerformGC@ is the wrapper for calls to @collectHeap@ in the
   8 storage manager. It performs the following actions:
   9 \begin{enumerate}
  10 \item Save live registers.
  11 \item If black holing is required before garbage collection we must
  12 black hole the update frames on the B stack and any live registers
  13 pointing at updatable closures --- possibly R1, if live and in update? --JSM
  14 \item Call the garbage collector.
  15 \item Restore registers.
  16 \end{enumerate}
  17 They either succeed or crash-and-burn; hence, they don't return
  18 anything.
  19
  20 @PerformGC@ saves the fixed STG registers. and calls the garbage
  21 collector. It also black holes the B Stack if this is required at
  22 garbage collection time.
  23
  24 There's also a function @PerformGCIO@ which does all the above and is
  25 used to force a full collection.
  26
  27 \begin{code}
  28 #if defined(CONCURRENT)
  29 EXTFUN(EnterNodeCode);          /* For reentering node after GC */
  30 EXTFUN(CheckHeapCode);          /* For returning to thread after a context switch */
  31 extern P_ AvailableStack;
  32 # if defined(PAR)
  33 EXTDATA_RO(FetchMe_info);
  34 # endif
  35 #else
  36 static void BlackHoleUpdateStack(STG_NO_ARGS);
  37 #endif /* CONCURRENT */
  38
  39 extern smInfo StorageMgrInfo;
  40 extern void PrintTickyInfo(STG_NO_ARGS);
  41
  42 /* the real work is done by this function --- see wrappers at end */
  43
  44 void
  45 RealPerformGC(liveness, reqsize, always_reenter_node, do_full_collection)
  46   W_ liveness;
  47   W_ reqsize;
  48   W_  always_reenter_node;
  49   rtsBool do_full_collection;
  50 {
  51     I_ num_ptr_roots = 0; /* we bump this counter as we
  52                                  store roots; de-bump it
  53                                  as we re-store them. */
  54 #if defined(PROFILING)
  55     CostCentre Save_CCC;
  56 #endif
  57
  58     /* stop the profiling timer --------------------- */
  59 #if defined(PROFILING)
  60 /*    STOP_TIME_PROFILER; */
  61 #endif
  62
  63 #ifdef CONCURRENT
  64
  65     SAVE_Liveness = liveness;
  66
  67     /*
  68     fprintf(stderr,"RealGC:liveness=0x%lx,reqsize=0x%lx,reenter=%lx,do_full=%d,context_switch=%ld\n",
  69         liveness, reqsize,always_reenter_node,do_full_collection,context_switch);
  70     */
  71
  72     /*
  73        Even on a uniprocessor, we may have to reenter node after a
  74        context switch.  Though it can't turn into a FetchMe, its shape
  75        may have changed (e.g. from a thunk to a data object).
  76      */
  77     if (always_reenter_node) {
  78         /* Avoid infinite loops at the same heap check */
  79         if (SAVE_Hp <= SAVE_HpLim && TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) {
  80             TSO_SWITCH(CurrentTSO) = NULL;
  81             return;
  82         }
  83         /* Set up to re-enter Node, so as to be sure it's really there. */
  84         ASSERT(liveness & LIVENESS_R1);
  85         TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
  86         TSO_PC2(CurrentTSO) = EnterNodeCode;
  87     }
  88
  89     SAVE_Hp -= reqsize;
  90
  91     if (context_switch && !do_full_collection
  92 # if defined(PROFILING)
  93        && !interval_expired
  94 # endif
  95       ) {
  96         /* We're in a GC callWrapper, so the thread state is safe */
  97         TSO_ARG1(CurrentTSO) = reqsize;
  98         TSO_PC1(CurrentTSO) = CheckHeapCode;
  99 # ifdef PAR
 100         if (RTSflags.ParFlags.granSimStats) {
 101             TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
 102         }
 103 # endif
 104 # if defined(GRAN)
 105         ReSchedule(SAME_THREAD);
 106 # else
 107         ReSchedule(1);
 108 # endif
 109     }
 110
 111 # if defined(PROFILING)
 112     Save_CCC = CCC;
 113 # endif
 114 # if defined(PAR)
 115     SET_CCC_RTS(CC_GC,0,1);   /* without the sub_scc_count++ */
 116 # endif
 117
 118     ReallyPerformThreadGC(reqsize, do_full_collection);
 119
 120 #else   /* !CONCURRENT */
 121
 122 # if defined(PROFILING)
 123     Save_CCC = CCC;
 124     SET_CCC_RTS(CC_GC,0,1);   /* without the sub_scc_count++ */
 125 # endif
 126
 127     /* root saving ---------------------------------- */
 128
 129 # define __ENROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */   \
 130         do { if ( cond ) {                              \
 131         StorageMgrInfo.roots[num_ptr_roots] = CAT2(MAIN_R,n).p; \
 132         num_ptr_roots++;                                \
 133         }} while (0)
 134
 135     __ENROOT_PTR_REG(IS_LIVE_R1(liveness),1);
 136     __ENROOT_PTR_REG(IS_LIVE_R2(liveness),2);
 137     __ENROOT_PTR_REG(IS_LIVE_R3(liveness),3);
 138     __ENROOT_PTR_REG(IS_LIVE_R4(liveness),4);
 139     __ENROOT_PTR_REG(IS_LIVE_R5(liveness),5);
 140     __ENROOT_PTR_REG(IS_LIVE_R6(liveness),6);
 141     __ENROOT_PTR_REG(IS_LIVE_R7(liveness),7);
 142     __ENROOT_PTR_REG(IS_LIVE_R8(liveness),8);
 143
 144     /*
 145      * Before we garbage collect we may have to squeeze update frames and/or
 146      * black hole the update stack
 147     */
 148     if (! RTSflags.GcFlags.squeezeUpdFrames) {
 149         BlackHoleUpdateStack();
 150
 151     } else { /* Squeeze and/or black hole update frames */
 152         I_ displacement;
 153
 154         displacement = SqueezeUpdateFrames(stackInfo.botB + BREL(1), MAIN_SpB, MAIN_SuB);
 155
 156         MAIN_SuB += BREL(displacement);
 157         MAIN_SpB += BREL(displacement);
 158         /* fprintf(stderr, "B size %d, squeezed out %d\n", MAIN_SpB - stackInfo.botB,
 159                 displacement); */
 160     }
 161
 162     /* Add the stable pointer table to the roots list */
 163 #ifndef PAR
 164    StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
 165 #endif
 166
 167     ASSERT(num_ptr_roots <= SM_MAXROOTS);
 168     StorageMgrInfo.rootno = num_ptr_roots;
 169
 170     SAVE_Hp -= reqsize;
 171         /* Move (SAVE_)Hp back to where it was */
 172         /* (heap is known to grow upwards) */
 173         /* we *do* have to do this, so reported stats will be right! */
 174
 175     /* the main business ---------------------------- */
 176
 177     blockUserSignals();
 178
 179     {
 180       int GC_result;
 181
 182       /* Restore hpLim to its "correct" setting */
 183       StorageMgrInfo.hplim += StorageMgrInfo.hardHpOverflowSize;
 184
 185       GC_result = collectHeap(reqsize, &StorageMgrInfo, do_full_collection);
 186
 187       if ( GC_result == GC_HARD_LIMIT_EXCEEDED ) {
 188         OutOfHeapHook(reqsize * sizeof(W_), RTSflags.GcFlags.heapSize * sizeof(W_)); /*msg*/
 189         shutdownHaskell();
 190         EXIT(EXIT_FAILURE);
 191
 192       } else if ( GC_result == GC_SOFT_LIMIT_EXCEEDED ) {
 193         /* Allow ourselves to use emergency space */
 194         /* Set hplim so that we'll GC when we hit the soft limit */
 195         StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;
 196         raiseError( softHeapOverflowHandler );
 197
 198       } else if ( GC_result == GC_SUCCESS ) {
 199         /* Set hplim so that we'll GC when we hit the soft limit */
 200         StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;
 201
 202       } else { /* This should not happen */
 203         fprintf(stderr, "Panic: garbage collector returned %d please report it as a bug to glasgow-haskell-bugs@dcs.gla.ac.uk\n", GC_result );
 204
 205 # if defined(TICKY_TICKY)
 206         if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 207 # endif
 208         abort();
 209       }
 210     }
 211
 212     StorageMgrInfo.rootno = 0;  /* reset */
 213
 214     SAVE_Hp += reqsize;
 215     /* Semantics of GC ensures that a block of
 216         `reqsize' is now available (and allocated) [NB: sequential only] */
 217
 218     /* root restoring ------------------------------- */
 219     /* must do all the restoring exactly backwards to the storing! */
 220
 221     /* remove the stable pointer table first */
 222 #ifndef PAR
 223     StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
 224 #endif
 225
 226     /* now the general regs, in *backwards* order */
 227
 228 # define __DEROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */   \
 229         do { if ( cond ) {                              \
 230         num_ptr_roots--;                                \
 231         CAT2(MAIN_R,n).p = StorageMgrInfo.roots[num_ptr_roots]; \
 232         }} while (0)
 233
 234     __DEROOT_PTR_REG(IS_LIVE_R8(liveness),8);
 235     __DEROOT_PTR_REG(IS_LIVE_R7(liveness),7);
 236     __DEROOT_PTR_REG(IS_LIVE_R6(liveness),6);
 237     __DEROOT_PTR_REG(IS_LIVE_R5(liveness),5);
 238     __DEROOT_PTR_REG(IS_LIVE_R4(liveness),4);
 239     __DEROOT_PTR_REG(IS_LIVE_R3(liveness),3);
 240     __DEROOT_PTR_REG(IS_LIVE_R2(liveness),2);
 241     __DEROOT_PTR_REG(IS_LIVE_R1(liveness),1);
 242
 243     ASSERT(num_ptr_roots == 0); /* we have put it all back */
 244
 245     unblockUserSignals();
 246
 247 #endif  /* !CONCURRENT */
 248
 249 #if defined(PROFILING)
 250     CCC = Save_CCC;
 251
 252     RESTART_TIME_PROFILER;
 253 #endif
 254 }
 255 \end{code}
 256
 257 This is a wrapper used for all standard, non-threaded, non-parallel GC
 258 purposes.
 259 \begin{code}
 260 #ifdef HEAP_CHK_HYGIENE
 261 I_ doHygieneCheck = 0;
 262 #endif
 263
 264 void
 265 PerformGC(args)
 266   W_ args;
 267 {
 268     W_ liveness = HEAP_OVERFLOW_LIVENESS(args);
 269     W_ reqsize = HEAP_OVERFLOW_REQSIZE(args);
 270     W_ always_reenter_node = HEAP_OVERFLOW_REENTER(args);
 271
 272 #ifdef HEAP_CHK_HYGIENE
 273     if (doHygieneCheck) {
 274         checkHygiene();
 275         return;
 276     }
 277 #endif
 278     RealPerformGC(liveness, reqsize, always_reenter_node, rtsFalse);
 279 }
 280
 281 #if defined(CONCURRENT) && defined(GRAN)
 282 /* This is directly called from the macro GRAN_RESCHEDULE out of the */
 283 /* threaded world. -- HWL */
 284
 285 void
 286 PerformReschedule(liveness, always_reenter_node)
 287   W_ liveness;
 288   rtsBool  always_reenter_node;
 289
 290 {
 291     rtsBool need_to_reschedule;
 292
 293 #if 0 && defined(DEBUG)
 294     fprintf(stderr,"PerfReS:liveness=0x%lx,reenter=%lx,,context_switch=%ld\n",
 295         liveness, always_reenter_node, context_switch);
 296 #endif
 297
 298     /* Reset the global NeedToReSchedule --
 299        this is used only to communicate the fact that we should schedule
 300        a new thread rather than the existing one following a fetch.
 301     if (RTSflags.GranFlags.Light) {
 302       Yield(liveness);
 303     }
 304
 305     ASSERT(!RTSflags.GranFlags.Light);
 306     */
 307
 308     need_to_reschedule = NeedToReSchedule;
 309     NeedToReSchedule = rtsFalse;
 310
 311     SAVE_Liveness = liveness;
 312
 313     if (always_reenter_node) {
 314       /* Avoid infinite loops at the same context switch */
 315         if (/* (TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) || */
 316             (!need_to_reschedule &&
 317              CurrentTime[CurrentProc]<EndOfTimeSlice &&
 318              (TimeOfNextEvent==0 || TimeOfNextEvent>=CurrentTime[CurrentProc])
 319              || IgnoreEvents
 320             )) {
 321             /* TSO_SWITCH(CurrentTSO) = NULL; */
 322             return;
 323         }
 324
 325       /* Set up to re-enter Node, so as to be sure it's really there. */
 326       ASSERT(liveness & LIVENESS_R1);
 327       /* TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO); */
 328       TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
 329     }
 330
 331     /* We're in a GC callWrapper, so the thread state is safe */
 332     TSO_ARG1(CurrentTSO) = 0;
 333     TSO_PC1(CurrentTSO) = EnterNodeCode;
 334     ReSchedule( (need_to_reschedule &&
 335                  !RTSflags.GranFlags.DoReScheduleOnFetch &&
 336                  !RTSflags.GranFlags.Light) ?
 337                 CHANGE_THREAD : SAME_THREAD );
 338     /* In a block-on-fetch setup we must not use SAME_THREAD since that */
 339     /* would continue the fetching TSO, which is still at the head of the */
 340     /* of the threadq */
 341     /* GrAnSim-Light always uses SAME_THREAD */
 342 }
 343 #endif
 344
 345 #ifndef PAR
 346 /* this is a wrapper used when we want to do a full GC.
 347
 348    One reason might be that we're about to enter a time-critical piece
 349    of code and want to reduce the risk of a GC during the run.  The
 350    motivating reason is that we want to force the GC to report any
 351    dead Malloc Pointers to us.
 352
 353    Note: this should only be called using _ccall_GC_ which saves all
 354    registers in the usual place (ie the global save area) before the
 355    call and restores them afterwards.
 356
 357    ToDo: put in a runtime check that _ccall_GC_ is in action. */
 358
 359 void
 360 StgPerformGarbageCollection()
 361 {
 362 # if ! defined(__STG_GCC_REGS__)
 363     SaveAllStgRegs();   /* unregisterised case */
 364 # endif
 365
 366     RealPerformGC(0,0,0,rtsTrue);
 367
 368 # if ! defined(__STG_GCC_REGS__)
 369     RestoreAllStgRegs();    /* unregisterised case */
 370 # endif
 371 }
 372 #endif /* !PAR */
 373
 374 #if defined(CONCURRENT)
 375
 376 # if defined(GRAN)
 377
 378 #  if defined(DEPTH_FIRST_PRUNING)
 379
 380 /* Jim's spark pools are very similar to our processors, except that
 381    he uses a hard-wired constant.  This would be a mistake for us,
 382    since we won't always need this many pools.
 383 */
 384 void
 385 PruneSparks(STG_NO_ARGS)
 386 {
 387     sparkq spark, prev, next;
 388     I_ proc, pool, prunedSparks;
 389     I_ tot_sparks[MAX_PROC], total_sparks = 0, tot = 0;;
 390
 391 #  if defined(GRAN_CHECK) && defined(GRAN)
 392   if ( RTSflags.GranFlags.debug & 0x40 )
 393     fprintf(stderr,"Pruning (depth-first) spark roots for GC ...\n");
 394 #  endif
 395
 396     for(proc=0; proc<RTSflags.GranFlags.proc; ++proc) {
 397       tot_sparks[proc] = 0;
 398       prev = NULL;
 399
 400       for (pool = 0; pool < SPARK_POOLS; pool++) {
 401         prunedSparks=0;
 402
 403         for(spark = PendingSparksHd[proc][pool];
 404             spark != NULL;
 405             spark = next) {
 406           next = SPARK_NEXT(spark);
 407
 408           if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0)
 409             {
 410               if ( RTSflags.GcFlags.giveStats )
 411                 if (i==ADVISORY_POOL) {
 412                   tot_sparks[proc]++;
 413                   tot++;
 414                 }
 415
 416               /* HACK! This clause should actually never happen  HWL */
 417               if ( (SPARK_NODE(spark) == NULL) ||
 418                    (SPARK_NODE(spark) == PrelBase_Z91Z93_closure) ) {
 419 #  if defined(GRAN_CHECK) && defined(GRAN)
 420                   if ( RTSflags.GcFlags.giveStats &&
 421                        (RTSflags.GranFlags.debug & 0x40) )
 422                     fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or PrelBase_Z91Z93_closure\n", spark);
 423 #  endif
 424                   /* prune it below */
 425                 }
 426               else if (SHOULD_SPARK(SPARK_NODE(spark))) {
 427                 /* Keep it */
 428                 if (prev == NULL)
 429                     PendingSparksHd[proc][pool] = spark;
 430                 else
 431                     SPARK_NEXT(prev) = spark;
 432                 SPARK_PREV(spark) = prev;
 433                 prev = spark;
 434                 continue;
 435               }
 436           }
 437
 438           /* By now we know that the spark has to be pruned */
 439           if(RTSflags.GranFlags.granSimStats_Sparks)
 440               /* DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark); */
 441               DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 442                                PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
 443
 444           DisposeSpark(spark);
 445           prunedSparks++;
 446     }  /* forall spark ... */
 447     if (prev == NULL)
 448         PendingSparksHd[proc][pool] = NULL;
 449     else
 450         SPARK_NEXT(prev) = NULL;
 451     PendingSparksTl[proc][pool] = prev;
 452     if ( (RTSflags.GcFlags.giveStats) &&
 453          (RTSflags.GranFlags.debug & 0x1000) &&
 454          (prunedSparks>0) )
 455         fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu sparks (_NS flag!) on proc %d (pool %d) in PruneSparks\n",
 456                 prunedSparks,proc,pool);
 457    }  /* forall pool ... */
 458   }   /* forall proc ... */
 459 #  if defined(GRAN_CHECK) && defined(GRAN)
 460   if ( RTSflags.GcFlags.giveStats ) {
 461     fprintf(RTSflags.GcFlags.statsFile,
 462             "Spark statistics (after pruning) (total sparks: %d; before pruning: %d):",
 463             tot,total_sparks);
 464     for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
 465       if (proc % 4 == 0) fprintf(RTSflags.GcFlags.statsFile,"\n> ");
 466       fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
 467     }
 468     fprintf(RTSflags.GcFlags.statsFile,".\n");
 469   }
 470 #  endif
 471 }
 472
 473 #  else /* !DEPTH_FIRST_PRUNING */
 474
 475 /* Auxiliary functions that are used in the GranSim version of PruneSparks  */
 476
 477 static W_
 478 arr_and(W_ arr[], I_ max)
 479 {
 480  I_ i;
 481  W_ res;
 482
 483  /* Doesn't work with max==0; but then, many things don't work in this */
 484  /* special case. */
 485  for (i=1, res = arr[0]; i<max; i++)
 486    res &= arr[i];
 487
 488  return (res);
 489 }
 490
 491 static W_
 492 arr_max(W_ arr[], I_ max)
 493 {
 494  I_ i;
 495  W_ res;
 496
 497  /* Doesn't work with max==0; but then, many things don't work in this */
 498  /* special case. */
 499  for (i=1, res = arr[0]; i<max; i++)
 500    res = (arr[i]>res) ? arr[i] : res;
 501
 502  return (res);
 503 }
 504
 505 /* In case of an excessive number of sparks, depth first pruning is a Bad */
 506 /* Idea as we might end up with all remaining sparks on processor 0 and */
 507 /* none on the other processors. So, this version uses breadth first */
 508 /* pruning. -- HWL */
 509
 510 void
 511 PruneSparks(STG_NO_ARGS)
 512 {
 513   sparkq spark, prev,
 514          prev_spark[MAX_PROC][SPARK_POOLS],
 515          curr_spark[MAX_PROC][SPARK_POOLS];
 516   PROC proc;
 517   W_ allProcs = 0,
 518      endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
 519   I_ pool, total_sparks=0,
 520      prunedSparks[MAX_PROC][SPARK_POOLS];
 521   I_ tot_sparks[MAX_PROC], tot = 0;;
 522
 523 #  if defined(GRAN_CHECK) && defined(GRAN)
 524   if ( RTSflags.GranFlags.debug & 0x40 )
 525     fprintf(stderr,"Pruning (breadth-first) sparks for GC ...\n");
 526 #  endif
 527
 528   /* Init */
 529   for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 530     allProcs |= PE_NUMBER(proc);
 531     tot_sparks[proc] = 0;
 532     for(pool = 0; pool < SPARK_POOLS; ++pool) {
 533       prev_spark[proc][pool] = NULL;
 534       curr_spark[proc][pool] = PendingSparksHd[proc][pool];
 535       prunedSparks[proc][pool] = 0;
 536       endQueues[pool] = 0;
 537       finishedQueues[pool] = 0;
 538     }
 539   }
 540
 541   /* Breadth first pruning */
 542   do {
 543     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 544       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 545         spark = curr_spark[proc][pool];
 546         prev = prev_spark[proc][pool];
 547
 548         if  (spark == NULL) {         /* at the end of the queue already? */
 549           if (! (endQueues[pool] & PE_NUMBER(proc)) ) {
 550             endQueues[pool] |= PE_NUMBER(proc);
 551             if (prev==NULL)
 552               PendingSparksHd[proc][pool] = NULL;
 553             else
 554               SPARK_NEXT(prev) = NULL;
 555             PendingSparksTl[proc][pool] = prev;
 556           }
 557           continue;
 558         }
 559
 560         /* HACK! This clause should actually never happen  HWL */
 561         if ( (SPARK_NODE(spark) == NULL) ||
 562              (SPARK_NODE(spark) == PrelBase_Z91Z93_closure) ) {
 563 #  if defined(GRAN_CHECK) && defined(GRAN)
 564             if ( RTSflags.GcFlags.giveStats &&
 565                  (RTSflags.GranFlags.debug & 0x40) )
 566                 fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or PrelBase_Z91Z93_closure\n", spark);
 567 #  endif
 568             /* prune it below */
 569         } else if (SHOULD_SPARK(SPARK_NODE(spark))) {
 570             if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0) {
 571                 if ( RTSflags.GcFlags.giveStats )
 572                     if (pool==ADVISORY_POOL) {
 573                         tot_sparks[proc]++;
 574                         tot++;
 575                     }
 576
 577                 /* Keep it */
 578                 if (prev_spark[proc][pool] == NULL)
 579                     PendingSparksHd[proc][pool] = spark;
 580                 else
 581                     SPARK_NEXT(prev_spark[proc][pool]) = spark;
 582                 SPARK_PREV(spark) = prev_spark[proc][pool];
 583                 prev_spark[proc][pool] = spark;
 584                 curr_spark[proc][pool] = SPARK_NEXT(spark);
 585                 continue;
 586             } else { /* total_sparks > MAX_SPARKS */
 587                 /* Sparkq will end before the current spark */
 588                 if (prev == NULL)
 589                     PendingSparksHd[proc][pool] = NULL;
 590                 else
 591                     SPARK_NEXT(prev) = NULL;
 592                 PendingSparksTl[proc][pool] = prev;
 593                 endQueues[pool] |= PE_NUMBER(proc);
 594                 continue;
 595             }
 596         }
 597
 598         /* By now we know that the spark has to be pruned */
 599         if(RTSflags.GranFlags.granSimStats_Sparks)
 600             DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 601                              PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
 602
 603         SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
 604         curr_spark[proc][pool] = SPARK_NEXT(spark);
 605         prunedSparks[proc][pool]++;
 606         DisposeSpark(spark);
 607       } /* forall pool ... */
 608     }   /* forall proc ... */
 609   } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
 610
 611   /* Prune all sparks on all processor starting with */
 612   /* curr_spark[proc][pool]. */
 613
 614   do {
 615     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 616       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 617         spark = curr_spark[proc][pool];
 618
 619         if ( spark != NULL ) {
 620           if(RTSflags.GranFlags.granSimStats_Sparks)
 621             DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 622                              PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
 623
 624           SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
 625           curr_spark[proc][pool] = SPARK_NEXT(spark);
 626
 627           prunedSparks[proc][pool]++;
 628           DisposeSpark(spark);
 629         } else {
 630           finishedQueues[pool] |= PE_NUMBER(proc);
 631         }
 632       }  /* forall pool ... */
 633     }    /* forall proc ... */
 634   } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
 635
 636
 637 #  if defined(GRAN_CHECK) && defined(GRAN)
 638   if ( RTSflags.GranFlags.debug & 0x1000) {
 639     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 640       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 641         if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][pool]>0)) {
 642           fprintf(RTSflags.GcFlags.statsFile,
 643                   "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
 644                   prunedSparks[proc][pool],proc,pool);
 645         }
 646       }
 647     }
 648
 649     if ( RTSflags.GcFlags.giveStats ) {
 650       fprintf(RTSflags.GcFlags.statsFile,
 651               "Spark statistics (after discarding) (total sparks = %d):",tot);
 652       for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
 653         if (proc % 4 == 0)
 654           fprintf(RTSflags.GcFlags.statsFile,"\n> ");
 655         fprintf(RTSflags.GcFlags.statsFile,
 656                 "\tPE %d: %d ",proc,tot_sparks[proc]);
 657       }
 658       fprintf(RTSflags.GcFlags.statsFile,".\n");
 659     }
 660   }
 661 #  endif
 662 }
 663
 664 #  endif  /* !DEPTH_FIRST_PRUNING */
 665
 666 # else  /* !GRAN */
 667
 668 void
 669 PruneSparks(STG_NO_ARGS)
 670 {
 671     I_ pool;
 672
 673     PP_ old;
 674     PP_ new;
 675
 676     for (pool = 0; pool < SPARK_POOLS; pool++) {
 677         new = PendingSparksBase[pool];
 678         for (old = PendingSparksHd[pool]; old < PendingSparksTl[pool]; old++) {
 679             if (SHOULD_SPARK(*old)) {
 680                 /* Keep it */
 681                 *new++ = *old;
 682             } else {
 683                 if (DO_QP_PROF)
 684                     QP_Event0(threadId++, *old);
 685 #  if 0
 686             /* ToDo: Fix log entries for pruned sparks in GUM */
 687                 if(RTSflags.GranFlags.granSimStats_Sparks)
 688                   /* DumpSparkGranEvent(SP_PRUNED, threadId++);*/
 689                   DumpGranEvent(SP_PRUNED,PrelBase_Z91Z93_closure);
 690                                           ^^^^^^^^^^^ should be a TSO
 691 #  endif
 692             }
 693         }
 694         PendingSparksHd[pool] = PendingSparksBase[pool];
 695         PendingSparksTl[pool] = new;
 696     }
 697 }
 698
 699 # endif  /* !GRAN */
 700
 701 \end{code}
 702
 703 This is the real GC wrapper for the threaded world.  No context
 704 switching or other nonsense... just set up StorageMgrInfo and perform
 705 a garbage collection.
 706
 707 \begin{code}
 708 void handleTimerExpiry PROTO((rtsBool));
 709
 710 void
 711 ReallyPerformThreadGC(reqsize, do_full_collection)
 712 W_ reqsize;
 713 rtsBool do_full_collection;
 714 {
 715 # if defined(GRAN)
 716     I_ proc;
 717 #endif
 718
 719     I_ num_ptr_roots = 0;        /* we bump this counter as we store roots; de-bump it
 720                                     as we re-store them. */
 721     P_ stack, tso, next;
 722
 723     /* Discard the saved stack and TSO space.
 724        What's going on here:  TSOs and StkOs are on the mutables
 725        list (mutable things in the old generation). Here, we change
 726        them to immutable, so that the scavenger (which chks all
 727        mutable objects) can detect their immutability and remove
 728        them from the list.  Setting to MUTUPLE_VHS as the size is
 729        essentially saying "No pointers in here" (i.e., empty).
 730
 731        Without this change of status, these
 732        objects might not really die, probably with some horrible
 733        disastrous consequence that we don't want to think about.
 734        Will & Phil 95/10
 735     */
 736
 737     for(stack = AvailableStack; stack != PrelBase_Z91Z93_closure; stack = next) {
 738         next = STKO_LINK(stack);
 739         FREEZE_MUT_HDR(stack, ImMutArrayOfPtrs_info);
 740         MUTUPLE_CLOSURE_SIZE(stack) = MUTUPLE_VHS;
 741     }
 742
 743     for(tso = AvailableTSO; tso != PrelBase_Z91Z93_closure; tso = next) {
 744         next = TSO_LINK(tso);
 745         FREEZE_MUT_HDR(tso, ImMutArrayOfPtrs_info);
 746         MUTUPLE_CLOSURE_SIZE(tso) = MUTUPLE_VHS;
 747     }
 748
 749     AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
 750
 751     PruneSparks();
 752
 753 # if defined(GRAN)
 754     traverse_eventq_for_gc();         /* tidy up eventq for GC */
 755
 756     /* Store head and tail of runnable lists as roots for GC */
 757     if (RTSflags.GranFlags.Light) {
 758           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[0];
 759           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[0];
 760     } else {
 761       for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 762 #  if defined(GRAN_CHECK) && defined(GRAN)
 763           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 764               fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
 765                       num_ptr_roots,proc,RunnableThreadsHd[proc]);
 766 #  endif
 767
 768           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];
 769
 770 #  if defined(GRAN_CHECK) && defined(GRAN)
 771           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 772               fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
 773                       num_ptr_roots,proc,RunnableThreadsTl[proc]);
 774 #  endif
 775           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
 776
 777       }  /* forall proc ... */
 778     }  /* RTSflags.GranFlags.Light */
 779
 780     /* This is now done as part of collectHeap (see ../storage dir) */
 781     /* num_ptr_roots = SaveSparkRoots(num_ptr_roots); */
 782     /* num_ptr_roots = SaveEventRoots(num_ptr_roots); */
 783
 784 # else /* !GRAN */
 785
 786     StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd;
 787     StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl;
 788     StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsHd;
 789     StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsTl;
 790
 791 # endif /* GRAN */
 792
 793 # if defined(GRAN_CHECK) && defined(GRAN)
 794     if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 795       fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
 796               num_ptr_roots,CurrentTSO);
 797 # endif
 798
 799     StorageMgrInfo.roots[num_ptr_roots++] = CurrentTSO;
 800
 801 #  ifdef PAR
 802     StorageMgrInfo.roots[num_ptr_roots++] = PendingFetches;
 803 #  endif
 804
 805 # ifndef PAR
 806   StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
 807 # endif
 808
 809     StorageMgrInfo.rootno = num_ptr_roots;
 810
 811     blockUserSignals();
 812
 813     /* For VTALRM timer ticks to be handled correctly, we need to record that
 814        we are now about to enter GC, delaying the handling of timer expiry
 815        for delayed threads till after the GC.
 816     */
 817     handleTimerExpiry(rtsFalse);
 818
 819     /* ====> The REAL THING happens here */
 820     if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) {
 821
 822         OutOfHeapHook(reqsize * sizeof(W_), RTSflags.GcFlags.heapSize * sizeof(W_)); /*msg*/
 823
 824 # if defined(TICKY_TICKY)
 825         if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 826 # endif
 827         EXIT(EXIT_FAILURE);
 828     }
 829
 830     StorageMgrInfo.rootno = 0;  /* reset */
 831
 832     /* root restoring ------------------------------- */
 833     /* must do all the restoring exactly backwards to the storing! */
 834
 835 # if defined(GRAN_CHECK) && defined(GRAN)
 836     if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 837         fprintf(RTSflags.GcFlags.statsFile,
 838                 "Restoring CurrentTSO %d -- new: 0x%lx\n",
 839                 num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
 840 # endif
 841
 842 # ifndef PAR
 843     StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
 844 # endif
 845
 846 # ifdef PAR
 847     PendingFetches = StorageMgrInfo.roots[--num_ptr_roots];
 848 # endif
 849     CurrentTSO = StorageMgrInfo.roots[--num_ptr_roots];
 850     CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);
 851
 852 # if !defined(GRAN)
 853
 854     WaitingThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
 855     WaitingThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
 856
 857     RunnableThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
 858     RunnableThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
 859
 860 # else /* GRAN */
 861
 862     /* num_ptr_roots = RestoreEventRoots(num_ptr_roots); */
 863     /* num_ptr_roots = RestoreSparkRoots(num_ptr_roots); */
 864
 865     /* NB: PROC is unsigned datatype i.e. (PROC)-1 > 0 !  */
 866
 867     if (RTSflags.GranFlags.Light) {
 868           RunnableThreadsTl[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
 869           RunnableThreadsHd[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
 870     } else {
 871       for(proc = RTSflags.GranFlags.proc - 1;
 872           (proc >= 0) && (proc < RTSflags.GranFlags.proc) ;
 873           --proc) {
 874 #  if defined(GRAN_CHECK) && defined(GRAN)
 875           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 876               fprintf(RTSflags.GcFlags.statsFile,
 877                       "Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
 878                       num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
 879 #  endif
 880           RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];
 881
 882 #  if defined(GRAN_CHECK) && defined(GRAN)
 883           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 884               fprintf(RTSflags.GcFlags.statsFile,
 885                       "Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
 886                       num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
 887 #  endif
 888           RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];
 889       }  /* forall proc ... */
 890     }  /* RTSflags.GranFlags.Light */
 891
 892 # endif /* GRAN */
 893
 894     /* Semantics of GC ensures that a block of `reqsize' is now available */
 895     SAVE_Hp += reqsize;
 896
 897     /* Activate the handling of entries on the WaitingThreads queue again */
 898     handleTimerExpiry(rtsTrue);
 899
 900     unblockUserSignals();
 901 }
 902
 903 #endif /* CONCURRENT */
 904
 905 \end{code}
 906
 907 This routine rattles down the B stack, black-holing any
 908 pending updates to avoid space leaks from them.
 909
 910 \begin{code}
 911 #if !defined(CONCURRENT)
 912
 913 static
 914 void
 915 BlackHoleUpdateStack(STG_NO_ARGS)
 916 {
 917     P_ PtrToUpdateFrame;
 918
 919     if (! RTSflags.GcFlags.lazyBlackHoling)
 920         return;
 921
 922     PtrToUpdateFrame = MAIN_SuB;
 923
 924     /* ToDo: There may be an optimisation here which stops at the first
 925              BHed closure on the stack as all below must have been BHed */
 926
 927     while (SUBTRACT_B_STK(PtrToUpdateFrame, stackInfo.botB) > 0) {
 928
 929         UPD_BH(GRAB_UPDATEE(PtrToUpdateFrame), BH_UPD_info);
 930
 931         /* Move PtrToUpdateFrame down B Stack */
 932         PtrToUpdateFrame = GRAB_SuB(PtrToUpdateFrame);
 933     }
 934 }
 935 #endif  /* !CONCURRENT */
 936 \end{code}