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