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     /* Reset the global NeedToReSchedule --
 294        this is used only to communicate the fact that we should schedule
 295        a new thread rather than the existing one following a fetch.
 296     if (RTSflags.GranFlags.Light) {
 297       Yield(liveness);
 298     }
 299
 300     ASSERT(!RTSflags.GranFlags.Light);
 301     */
 302
 303     need_to_reschedule = NeedToReSchedule;
 304     NeedToReSchedule = rtsFalse;
 305
 306     SAVE_Liveness = liveness;
 307
 308     if (always_reenter_node) {
 309       /* Avoid infinite loops at the same context switch */
 310         if (/* (TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) || */
 311             (!need_to_reschedule &&
 312              CurrentTime[CurrentProc]<EndOfTimeSlice &&
 313              (TimeOfNextEvent==0 || TimeOfNextEvent>=CurrentTime[CurrentProc])
 314              || IgnoreEvents
 315             )) {
 316             /* TSO_SWITCH(CurrentTSO) = NULL; */
 317             return;
 318         }
 319
 320       /* Set up to re-enter Node, so as to be sure it's really there. */
 321       ASSERT(liveness & LIVENESS_R1);
 322       /* TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO); */
 323       TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
 324     }
 325
 326     /* We're in a GC callWrapper, so the thread state is safe */
 327     TSO_ARG1(CurrentTSO) = 0;
 328     TSO_PC1(CurrentTSO) = EnterNodeCode;
 329     ReSchedule( (need_to_reschedule &&
 330                  !RTSflags.GranFlags.DoReScheduleOnFetch &&
 331                  !RTSflags.GranFlags.Light) ?
 332                 CHANGE_THREAD : SAME_THREAD );
 333     /* In a block-on-fetch setup we must not use SAME_THREAD since that */
 334     /* would continue the fetching TSO, which is still at the head of the */
 335     /* of the threadq */
 336     /* GrAnSim-Light always uses SAME_THREAD */
 337 }
 338 #endif
 339
 340 #ifndef PAR
 341 /* this is a wrapper used when we want to do a full GC.
 342
 343    One reason might be that we're about to enter a time-critical piece
 344    of code and want to reduce the risk of a GC during the run.  The
 345    motivating reason is that we want to force the GC to report any
 346    dead Malloc Pointers to us.
 347
 348    Note: this should only be called using _ccall_GC_ which saves all
 349    registers in the usual place (ie the global save area) before the
 350    call and restores them afterwards.
 351
 352    ToDo: put in a runtime check that _ccall_GC_ is in action. */
 353
 354 void
 355 StgPerformGarbageCollection()
 356 {
 357 # if ! defined(__STG_GCC_REGS__)
 358     SaveAllStgRegs();   /* unregisterised case */
 359 # endif
 360
 361     RealPerformGC(0,0,0,rtsTrue);
 362
 363 # if ! defined(__STG_GCC_REGS__)
 364     RestoreAllStgRegs();    /* unregisterised case */
 365 # endif
 366 }
 367 #endif /* !PAR */
 368
 369 #if defined(CONCURRENT)
 370
 371 # if defined(GRAN)
 372
 373 #  if defined(DEPTH_FIRST_PRUNING)
 374
 375 /* Jim's spark pools are very similar to our processors, except that
 376    he uses a hard-wired constant.  This would be a mistake for us,
 377    since we won't always need this many pools.
 378 */
 379 void
 380 PruneSparks(STG_NO_ARGS)
 381 {
 382     sparkq spark, prev, next;
 383     I_ proc, pool, prunedSparks;
 384     I_ tot_sparks[MAX_PROC], total_sparks = 0, tot = 0;;
 385
 386 #  if defined(GRAN_CHECK) && defined(GRAN)
 387   if ( RTSflags.GranFlags.debug & 0x40 )
 388     fprintf(stderr,"Pruning (depth-first) spark roots for GC ...\n");
 389 #  endif
 390
 391     for(proc=0; proc<RTSflags.GranFlags.proc; ++proc) {
 392       tot_sparks[proc] = 0;
 393       prev = NULL;
 394
 395       for (pool = 0; pool < SPARK_POOLS; pool++) {
 396         prunedSparks=0;
 397
 398         for(spark = PendingSparksHd[proc][pool];
 399             spark != NULL;
 400             spark = next) {
 401           next = SPARK_NEXT(spark);
 402
 403           if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0)
 404             {
 405               if ( RTSflags.GcFlags.giveStats )
 406                 if (i==ADVISORY_POOL) {
 407                   tot_sparks[proc]++;
 408                   tot++;
 409                 }
 410
 411               /* HACK! This clause should actually never happen  HWL */
 412               if ( (SPARK_NODE(spark) == NULL) ||
 413                    (SPARK_NODE(spark) == Prelude_Z91Z93_closure) ) {
 414 #  if defined(GRAN_CHECK) && defined(GRAN)
 415                   if ( RTSflags.GcFlags.giveStats &&
 416                        (RTSflags.GranFlags.debug & 0x40) )
 417                     fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Prelude_Z91Z93_closure\n", spark);
 418 #  endif
 419                   /* prune it below */
 420                 }
 421               else if (SHOULD_SPARK(SPARK_NODE(spark))) {
 422                 /* Keep it */
 423                 if (prev == NULL)
 424                     PendingSparksHd[proc][pool] = spark;
 425                 else
 426                     SPARK_NEXT(prev) = spark;
 427                 SPARK_PREV(spark) = prev;
 428                 prev = spark;
 429                 continue;
 430               }
 431           }
 432
 433           /* By now we know that the spark has to be pruned */
 434           if(RTSflags.GranFlags.granSimStats_Sparks)
 435               /* DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark); */
 436               DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 437                                Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
 438
 439           DisposeSpark(spark);
 440           prunedSparks++;
 441     }  /* forall spark ... */
 442     if (prev == NULL)
 443         PendingSparksHd[proc][pool] = NULL;
 444     else
 445         SPARK_NEXT(prev) = NULL;
 446     PendingSparksTl[proc][pool] = prev;
 447     if ( (RTSflags.GcFlags.giveStats) &&
 448          (RTSflags.GranFlags.debug & 0x1000) &&
 449          (prunedSparks>0) )
 450         fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu sparks (_NS flag!) on proc %d (pool %d) in PruneSparks\n",
 451                 prunedSparks,proc,pool);
 452    }  /* forall pool ... */
 453   }   /* forall proc ... */
 454 #  if defined(GRAN_CHECK) && defined(GRAN)
 455   if ( RTSflags.GcFlags.giveStats ) {
 456     fprintf(RTSflags.GcFlags.statsFile,
 457             "Spark statistics (after pruning) (total sparks: %d; before pruning: %d):",
 458             tot,total_sparks);
 459     for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
 460       if (proc % 4 == 0) fprintf(RTSflags.GcFlags.statsFile,"\n> ");
 461       fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
 462     }
 463     fprintf(RTSflags.GcFlags.statsFile,".\n");
 464   }
 465 #  endif
 466 }
 467
 468 #  else /* !DEPTH_FIRST_PRUNING */
 469
 470 /* Auxiliary functions that are used in the GranSim version of PruneSparks  */
 471
 472 static W_
 473 arr_and(W_ arr[], I_ max)
 474 {
 475  I_ i;
 476  W_ res;
 477
 478  /* Doesn't work with max==0; but then, many things don't work in this */
 479  /* special case. */
 480  for (i=1, res = arr[0]; i<max; i++)
 481    res &= arr[i];
 482
 483  return (res);
 484 }
 485
 486 static W_
 487 arr_max(W_ arr[], I_ max)
 488 {
 489  I_ i;
 490  W_ res;
 491
 492  /* Doesn't work with max==0; but then, many things don't work in this */
 493  /* special case. */
 494  for (i=1, res = arr[0]; i<max; i++)
 495    res = (arr[i]>res) ? arr[i] : res;
 496
 497  return (res);
 498 }
 499
 500 /* In case of an excessive number of sparks, depth first pruning is a Bad */
 501 /* Idea as we might end up with all remaining sparks on processor 0 and */
 502 /* none on the other processors. So, this version uses breadth first */
 503 /* pruning. -- HWL */
 504
 505 void
 506 PruneSparks(STG_NO_ARGS)
 507 {
 508   sparkq spark, prev,
 509          prev_spark[MAX_PROC][SPARK_POOLS],
 510          curr_spark[MAX_PROC][SPARK_POOLS];
 511   PROC proc;
 512   W_ allProcs = 0,
 513      endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
 514   I_ pool, total_sparks=0,
 515      prunedSparks[MAX_PROC][SPARK_POOLS];
 516   I_ tot_sparks[MAX_PROC], tot = 0;;
 517
 518 #  if defined(GRAN_CHECK) && defined(GRAN)
 519   if ( RTSflags.GranFlags.debug & 0x40 )
 520     fprintf(stderr,"Pruning (breadth-first) sparks for GC ...\n");
 521 #  endif
 522
 523   /* Init */
 524   for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 525     allProcs |= PE_NUMBER(proc);
 526     tot_sparks[proc] = 0;
 527     for(pool = 0; pool < SPARK_POOLS; ++pool) {
 528       prev_spark[proc][pool] = NULL;
 529       curr_spark[proc][pool] = PendingSparksHd[proc][pool];
 530       prunedSparks[proc][pool] = 0;
 531       endQueues[pool] = 0;
 532       finishedQueues[pool] = 0;
 533     }
 534   }
 535
 536   /* Breadth first pruning */
 537   do {
 538     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 539       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 540         spark = curr_spark[proc][pool];
 541         prev = prev_spark[proc][pool];
 542
 543         if  (spark == NULL) {         /* at the end of the queue already? */
 544           if (! (endQueues[pool] & PE_NUMBER(proc)) ) {
 545             endQueues[pool] |= PE_NUMBER(proc);
 546             if (prev==NULL)
 547               PendingSparksHd[proc][pool] = NULL;
 548             else
 549               SPARK_NEXT(prev) = NULL;
 550             PendingSparksTl[proc][pool] = prev;
 551           }
 552           continue;
 553         }
 554
 555         /* HACK! This clause should actually never happen  HWL */
 556         if ( (SPARK_NODE(spark) == NULL) ||
 557              (SPARK_NODE(spark) == Prelude_Z91Z93_closure) ) {
 558 #  if defined(GRAN_CHECK) && defined(GRAN)
 559             if ( RTSflags.GcFlags.giveStats &&
 560                  (RTSflags.GranFlags.debug & 0x40) )
 561                 fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Prelude_Z91Z93_closure\n", spark);
 562 #  endif
 563             /* prune it below */
 564         } else if (SHOULD_SPARK(SPARK_NODE(spark))) {
 565             if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0) {
 566                 if ( RTSflags.GcFlags.giveStats )
 567                     if (pool==ADVISORY_POOL) {
 568                         tot_sparks[proc]++;
 569                         tot++;
 570                     }
 571
 572                 /* Keep it */
 573                 if (prev_spark[proc][pool] == NULL)
 574                     PendingSparksHd[proc][pool] = spark;
 575                 else
 576                     SPARK_NEXT(prev_spark[proc][pool]) = spark;
 577                 SPARK_PREV(spark) = prev_spark[proc][pool];
 578                 prev_spark[proc][pool] = spark;
 579                 curr_spark[proc][pool] = SPARK_NEXT(spark);
 580                 continue;
 581             } else { /* total_sparks > MAX_SPARKS */
 582                 /* Sparkq will end before the current spark */
 583                 if (prev == NULL)
 584                     PendingSparksHd[proc][pool] = NULL;
 585                 else
 586                     SPARK_NEXT(prev) = NULL;
 587                 PendingSparksTl[proc][pool] = prev;
 588                 endQueues[pool] |= PE_NUMBER(proc);
 589                 continue;
 590             }
 591         }
 592
 593         /* By now we know that the spark has to be pruned */
 594         if(RTSflags.GranFlags.granSimStats_Sparks)
 595             DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 596                              Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
 597
 598         SPARK_NODE(spark) = Prelude_Z91Z93_closure;
 599         curr_spark[proc][pool] = SPARK_NEXT(spark);
 600         prunedSparks[proc][pool]++;
 601         DisposeSpark(spark);
 602       } /* forall pool ... */
 603     }   /* forall proc ... */
 604   } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
 605
 606   /* Prune all sparks on all processor starting with */
 607   /* curr_spark[proc][pool]. */
 608
 609   do {
 610     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 611       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 612         spark = curr_spark[proc][pool];
 613
 614         if ( spark != NULL ) {
 615           if(RTSflags.GranFlags.granSimStats_Sparks)
 616             DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
 617                              Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
 618
 619           SPARK_NODE(spark) = Prelude_Z91Z93_closure;
 620           curr_spark[proc][pool] = SPARK_NEXT(spark);
 621
 622           prunedSparks[proc][pool]++;
 623           DisposeSpark(spark);
 624         } else {
 625           finishedQueues[pool] |= PE_NUMBER(proc);
 626         }
 627       }  /* forall pool ... */
 628     }    /* forall proc ... */
 629   } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
 630
 631
 632 #  if defined(GRAN_CHECK) && defined(GRAN)
 633   if ( RTSflags.GranFlags.debug & 0x1000) {
 634     for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 635       for(pool = 0; pool < SPARK_POOLS; ++pool) {
 636         if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][pool]>0)) {
 637           fprintf(RTSflags.GcFlags.statsFile,
 638                   "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
 639                   prunedSparks[proc][pool],proc,pool);
 640         }
 641       }
 642     }
 643
 644     if ( RTSflags.GcFlags.giveStats ) {
 645       fprintf(RTSflags.GcFlags.statsFile,
 646               "Spark statistics (after discarding) (total sparks = %d):",tot);
 647       for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
 648         if (proc % 4 == 0)
 649           fprintf(RTSflags.GcFlags.statsFile,"\n> ");
 650         fprintf(RTSflags.GcFlags.statsFile,
 651                 "\tPE %d: %d ",proc,tot_sparks[proc]);
 652       }
 653       fprintf(RTSflags.GcFlags.statsFile,".\n");
 654     }
 655   }
 656 #  endif
 657 }
 658
 659 #  endif  /* !DEPTH_FIRST_PRUNING */
 660
 661 # else  /* !GRAN */
 662
 663 void
 664 PruneSparks(STG_NO_ARGS)
 665 {
 666     I_ pool;
 667
 668     PP_ old;
 669     PP_ new;
 670
 671     for (pool = 0; pool < SPARK_POOLS; pool++) {
 672         new = PendingSparksBase[pool];
 673         for (old = PendingSparksHd[pool]; old < PendingSparksTl[pool]; old++) {
 674             if (SHOULD_SPARK(*old)) {
 675                 /* Keep it */
 676                 *new++ = *old;
 677             } else {
 678                 if (DO_QP_PROF)
 679                     QP_Event0(threadId++, *old);
 680 #  if 0
 681             /* ToDo: Fix log entries for pruned sparks in GUM */
 682                 if(RTSflags.GranFlags.granSimStats_Sparks)
 683                   /* DumpSparkGranEvent(SP_PRUNED, threadId++);*/
 684                   DumpGranEvent(SP_PRUNED,Prelude_Z91Z93_closure);
 685                                           ^^^^^^^^^^^ should be a TSO
 686 #  endif
 687             }
 688         }
 689         PendingSparksHd[pool] = PendingSparksBase[pool];
 690         PendingSparksTl[pool] = new;
 691     }
 692 }
 693
 694 # endif  /* !GRAN */
 695
 696 \end{code}
 697
 698 This is the real GC wrapper for the threaded world.  No context
 699 switching or other nonsense... just set up StorageMgrInfo and perform
 700 a garbage collection.
 701
 702 \begin{code}
 703 void handleTimerExpiry PROTO((rtsBool));
 704
 705 void
 706 ReallyPerformThreadGC(reqsize, do_full_collection)
 707 W_ reqsize;
 708 rtsBool do_full_collection;
 709 {
 710 # if defined(GRAN)
 711     I_ proc;
 712 #endif
 713
 714     I_ num_ptr_roots = 0;        /* we bump this counter as we store roots; de-bump it
 715                                     as we re-store them. */
 716     P_ stack, tso, next;
 717
 718     /* Discard the saved stack and TSO space.
 719        What's going on here:  TSOs and StkOs are on the mutables
 720        list (mutable things in the old generation). Here, we change
 721        them to immutable, so that the scavenger (which chks all
 722        mutable objects) can detect their immutability and remove
 723        them from the list.  Setting to MUTUPLE_VHS as the size is
 724        essentially saying "No pointers in here" (i.e., empty).
 725
 726        Without this change of status, these
 727        objects might not really die, probably with some horrible
 728        disastrous consequence that we don't want to think about.
 729        Will & Phil 95/10
 730     */
 731
 732     for(stack = AvailableStack; stack != Prelude_Z91Z93_closure; stack = next) {
 733         next = STKO_LINK(stack);
 734         FREEZE_MUT_HDR(stack, ImMutArrayOfPtrs_info);
 735         MUTUPLE_CLOSURE_SIZE(stack) = MUTUPLE_VHS;
 736     }
 737
 738     for(tso = AvailableTSO; tso != Prelude_Z91Z93_closure; tso = next) {
 739         next = TSO_LINK(tso);
 740         FREEZE_MUT_HDR(tso, ImMutArrayOfPtrs_info);
 741         MUTUPLE_CLOSURE_SIZE(tso) = MUTUPLE_VHS;
 742     }
 743
 744     AvailableStack = AvailableTSO = Prelude_Z91Z93_closure;
 745
 746     PruneSparks();
 747
 748 # if defined(GRAN)
 749     traverse_eventq_for_gc();         /* tidy up eventq for GC */
 750
 751     /* Store head and tail of runnable lists as roots for GC */
 752     if (RTSflags.GranFlags.Light) {
 753           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[0];
 754           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[0];
 755     } else {
 756       for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
 757 #  if defined(GRAN_CHECK) && defined(GRAN)
 758           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 759               fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
 760                       num_ptr_roots,proc,RunnableThreadsHd[proc]);
 761 #  endif
 762
 763           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];
 764
 765 #  if defined(GRAN_CHECK) && defined(GRAN)
 766           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 767               fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
 768                       num_ptr_roots,proc,RunnableThreadsTl[proc]);
 769 #  endif
 770           StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
 771
 772       }  /* forall proc ... */
 773     }  /* RTSflags.GranFlags.Light */
 774
 775     /* This is now done as part of collectHeap (see ../storage dir) */
 776     /* num_ptr_roots = SaveSparkRoots(num_ptr_roots); */
 777     /* num_ptr_roots = SaveEventRoots(num_ptr_roots); */
 778
 779 # else /* !GRAN */
 780
 781     StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd;
 782     StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl;
 783     StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsHd;
 784     StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsTl;
 785
 786 # endif /* GRAN */
 787
 788 # if defined(GRAN_CHECK) && defined(GRAN)
 789     if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 790       fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
 791               num_ptr_roots,CurrentTSO);
 792 # endif
 793
 794     StorageMgrInfo.roots[num_ptr_roots++] = CurrentTSO;
 795
 796 #  ifdef PAR
 797     StorageMgrInfo.roots[num_ptr_roots++] = PendingFetches;
 798 #  endif
 799
 800 # ifndef PAR
 801   StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
 802 # endif
 803
 804     StorageMgrInfo.rootno = num_ptr_roots;
 805
 806     blockUserSignals();
 807
 808     /* For VTALRM timer ticks to be handled correctly, we need to record that
 809        we are now about to enter GC, delaying the handling of timer expiry
 810        for delayed threads till after the GC.
 811     */
 812     handleTimerExpiry(rtsFalse);
 813
 814     /* ====> The REAL THING happens here */
 815     if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) {
 816
 817         OutOfHeapHook(reqsize * sizeof(W_), RTSflags.GcFlags.heapSize * sizeof(W_)); /*msg*/
 818
 819 # if defined(TICKY_TICKY)
 820         if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
 821 # endif
 822         EXIT(EXIT_FAILURE);
 823     }
 824
 825     StorageMgrInfo.rootno = 0;  /* reset */
 826
 827     /* root restoring ------------------------------- */
 828     /* must do all the restoring exactly backwards to the storing! */
 829
 830 # if defined(GRAN_CHECK) && defined(GRAN)
 831     if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 832         fprintf(RTSflags.GcFlags.statsFile,
 833                 "Restoring CurrentTSO %d -- new: 0x%lx\n",
 834                 num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
 835 # endif
 836
 837 # ifndef PAR
 838     StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
 839 # endif
 840
 841 # ifdef PAR
 842     PendingFetches = StorageMgrInfo.roots[--num_ptr_roots];
 843 # endif
 844     CurrentTSO = StorageMgrInfo.roots[--num_ptr_roots];
 845     CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);
 846
 847 # if !defined(GRAN)
 848
 849     WaitingThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
 850     WaitingThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
 851
 852     RunnableThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
 853     RunnableThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
 854
 855 # else /* GRAN */
 856
 857     /* num_ptr_roots = RestoreEventRoots(num_ptr_roots); */
 858     /* num_ptr_roots = RestoreSparkRoots(num_ptr_roots); */
 859
 860     /* NB: PROC is unsigned datatype i.e. (PROC)-1 > 0 !  */
 861
 862     if (RTSflags.GranFlags.Light) {
 863           RunnableThreadsTl[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
 864           RunnableThreadsHd[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
 865     } else {
 866       for(proc = RTSflags.GranFlags.proc - 1;
 867           (proc >= 0) && (proc < RTSflags.GranFlags.proc) ;
 868           --proc) {
 869 #  if defined(GRAN_CHECK) && defined(GRAN)
 870           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 871               fprintf(RTSflags.GcFlags.statsFile,
 872                       "Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
 873                       num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
 874 #  endif
 875           RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];
 876
 877 #  if defined(GRAN_CHECK) && defined(GRAN)
 878           if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
 879               fprintf(RTSflags.GcFlags.statsFile,
 880                       "Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
 881                       num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
 882 #  endif
 883           RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];
 884       }  /* forall proc ... */
 885     }  /* RTSflags.GranFlags.Light */
 886
 887 # endif /* GRAN */
 888
 889     /* Semantics of GC ensures that a block of `reqsize' is now available */
 890     SAVE_Hp += reqsize;
 891
 892     /* Activate the handling of entries on the WaitingThreads queue again */
 893     handleTimerExpiry(rtsTrue);
 894
 895     unblockUserSignals();
 896 }
 897
 898 #endif /* CONCURRENT */
 899
 900 \end{code}
 901
 902 This routine rattles down the B stack, black-holing any
 903 pending updates to avoid space leaks from them.
 904
 905 \begin{code}
 906 #if !defined(CONCURRENT)
 907
 908 static
 909 void
 910 BlackHoleUpdateStack(STG_NO_ARGS)
 911 {
 912     P_ PtrToUpdateFrame;
 913
 914     if (! RTSflags.GcFlags.lazyBlackHoling)
 915         return;
 916
 917     PtrToUpdateFrame = MAIN_SuB;
 918
 919     /* ToDo: There may be an optimisation here which stops at the first
 920              BHed closure on the stack as all below must have been BHed */
 921
 922     while (SUBTRACT_B_STK(PtrToUpdateFrame, stackInfo.botB) > 0) {
 923
 924         UPD_BH(GRAB_UPDATEE(PtrToUpdateFrame), BH_UPD_info);
 925
 926         /* Move PtrToUpdateFrame down B Stack */
 927         PtrToUpdateFrame = GRAB_SuB(PtrToUpdateFrame);
 928     }
 929 }
 930 #endif  /* !CONCURRENT */
 931 \end{code}