\section[PerformGC]{Wrapper for heap overflow}

\begin{code}
#include "rtsdefs.h"
\end{code}

@PerformGC@ is the wrapper for calls to @collectHeap@ in the
storage manager. It performs the following actions:
\begin{enumerate}
\item Save live registers.
\item If black holing is required before garbage collection we must
black hole the update frames on the B stack and any live registers
pointing at updatable closures --- possibly R1, if live and in update? --JSM
\item Call the garbage collector.
\item Restore registers.
\end{enumerate}
They either succeed or crash-and-burn; hence, they don't return
anything.

@PerformGC@ saves the fixed STG registers. and calls the garbage
collector. It also black holes the B Stack if this is required at
garbage collection time.

There's also a function @PerformGCIO@ which does all the above and is
used to force a full collection.

\begin{code}
#if defined(CONCURRENT)
EXTFUN(EnterNodeCode);		/* For reentering node after GC */
EXTFUN(CheckHeapCode);		/* For returning to thread after a context switch */
extern P_ AvailableStack;
# if defined(PAR)
EXTDATA_RO(FetchMe_info);
# endif
#else
static void BlackHoleUpdateStack(STG_NO_ARGS);
#endif /* CONCURRENT */

extern smInfo StorageMgrInfo;
extern void PrintTickyInfo(STG_NO_ARGS);

#if defined(GRAN_CHECK) && defined(GRAN)
extern W_ debug;
#endif

/* the real work is done by this function --- see wrappers at end */

void
RealPerformGC(liveness, reqsize, always_reenter_node, do_full_collection)
  W_ liveness;
  W_ reqsize;
  W_  always_reenter_node;
  rtsBool do_full_collection;
{
    I_ num_ptr_roots = 0; /* we bump this counter as we
			         store roots; de-bump it
			         as we re-store them. */
#if defined(PROFILING)
    CostCentre Save_CCC;
#endif

    /* stop the profiling timer --------------------- */
#if defined(PROFILING)
/*    STOP_TIME_PROFILER; */
#endif

#ifdef CONCURRENT

    SAVE_Liveness = liveness;

    /*
    fprintf(stderr,"RealGC:liveness=0x%lx,reqsize=0x%lx,reenter=%lx,do_full=%d,context_switch=%ld\n",
	liveness, reqsize,always_reenter_node,do_full_collection,context_switch);
    */

    /* 
       Even on a uniprocessor, we may have to reenter node after a 
       context switch.  Though it can't turn into a FetchMe, its shape
       may have changed (e.g. from a thunk to a data object).
     */
    if (always_reenter_node) {
    	/* Avoid infinite loops at the same heap check */
    	if (SAVE_Hp <= SAVE_HpLim && TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) {
    	    TSO_SWITCH(CurrentTSO) = NULL;
    	    return;
    	}
	/* Set up to re-enter Node, so as to be sure it's really there. */
	ASSERT(liveness & LIVENESS_R1);
    	TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
	TSO_PC2(CurrentTSO) = EnterNodeCode;
    }

    SAVE_Hp -= reqsize;

    if (context_switch && !do_full_collection
# if defined(PROFILING)
       && !interval_expired
# endif
      ) {
    	/* We're in a GC callWrapper, so the thread state is safe */
    	TSO_ARG1(CurrentTSO) = reqsize;
    	TSO_PC1(CurrentTSO) = CheckHeapCode;
# ifdef PAR
	if (RTSflags.ParFlags.granSimStats) {
	    TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
	}
# endif
# if defined(GRAN)
    	ReSchedule(9 /*i.e. error; was SAME_THREAD*/);
# else
    	ReSchedule(1);
# endif
    }

    /* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
# if defined(PROFILING)
    Save_CCC = CCC;
# endif
# if defined(PAR)
    CCC = (CostCentre)STATIC_CC_REF(CC_GC);
    CCC->scc_count++;
# endif

    ReallyPerformThreadGC(reqsize, do_full_collection);

#else	/* !CONCURRENT */

# if defined(PROFILING)
    /* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
    Save_CCC = CCC;
    CCC = (CostCentre)STATIC_CC_REF(CC_GC);
    CCC->scc_count++;
# endif

    /* root saving ---------------------------------- */

# define __ENROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */	\
	do { if ( cond ) {				\
	StorageMgrInfo.roots[num_ptr_roots] = CAT2(MAIN_R,n).p; \
	num_ptr_roots++;				\
	}} while (0)

    __ENROOT_PTR_REG(IS_LIVE_R1(liveness),1);
    __ENROOT_PTR_REG(IS_LIVE_R2(liveness),2);
    __ENROOT_PTR_REG(IS_LIVE_R3(liveness),3);
    __ENROOT_PTR_REG(IS_LIVE_R4(liveness),4);
    __ENROOT_PTR_REG(IS_LIVE_R5(liveness),5);
    __ENROOT_PTR_REG(IS_LIVE_R6(liveness),6);
    __ENROOT_PTR_REG(IS_LIVE_R7(liveness),7);
    __ENROOT_PTR_REG(IS_LIVE_R8(liveness),8);

    /* 
     * Before we garbage collect we may have to squeeze update frames and/or
     * black hole the update stack 
    */
    if (! RTSflags.GcFlags.squeezeUpdFrames) {
	BlackHoleUpdateStack();    	

    } else { /* Squeeze and/or black hole update frames */
	I_ displacement;

	displacement = SqueezeUpdateFrames(stackInfo.botB + BREL(1), MAIN_SpB, MAIN_SuB);

	MAIN_SuB += BREL(displacement);
	MAIN_SpB += BREL(displacement);
	/* fprintf(stderr, "B size %d, squeezed out %d\n", MAIN_SpB - stackInfo.botB,
                displacement); */
    }

    ASSERT(num_ptr_roots <= SM_MAXROOTS);
    StorageMgrInfo.rootno = num_ptr_roots;

    SAVE_Hp -= reqsize;
	/* Move (SAVE_)Hp back to where it was */
	/* (heap is known to grow upwards) */
	/* we *do* have to do this, so reported stats will be right! */

    /* the main business ---------------------------- */

    blockUserSignals();
    
    {
      int GC_result;

      /* Restore hpLim to its "correct" setting */
      StorageMgrInfo.hplim += StorageMgrInfo.hardHpOverflowSize;

      GC_result = collectHeap(reqsize, &StorageMgrInfo, do_full_collection);

      if ( GC_result == GC_HARD_LIMIT_EXCEEDED ) {
	OutOfHeapHook(reqsize * sizeof(W_)); /*msg*/
	shutdownHaskell();
	EXIT(EXIT_FAILURE);

      } else if ( GC_result == GC_SOFT_LIMIT_EXCEEDED ) {
	/* Allow ourselves to use emergency space */
	/* Set hplim so that we'll GC when we hit the soft limit */
	StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;
	raiseError( softHeapOverflowHandler );

      } else if ( GC_result == GC_SUCCESS ) {
	/* Set hplim so that we'll GC when we hit the soft limit */
	StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;

      } else { /* This should not happen */
	fprintf(stderr, "Panic: garbage collector returned %d please report it as a bug to glasgow-haskell-bugs@dcs.gla.ac.uk\n", GC_result );

# if defined(TICKY_TICKY)
	if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
# endif
	abort();
      }
    }

    StorageMgrInfo.rootno = 0;	/* reset */

    SAVE_Hp += reqsize;
    /* Semantics of GC ensures that a block of
	`reqsize' is now available (and allocated) [NB: sequential only] */

    /* root restoring ------------------------------- */
    /* must do all the restoring exactly backwards to the storing! */

    /* now the general regs, in *backwards* order */

# define __DEROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */	\
	do { if ( cond ) {				\
	num_ptr_roots--;				\
	CAT2(MAIN_R,n).p = StorageMgrInfo.roots[num_ptr_roots]; \
	}} while (0)

    __DEROOT_PTR_REG(IS_LIVE_R8(liveness),8);
    __DEROOT_PTR_REG(IS_LIVE_R7(liveness),7);
    __DEROOT_PTR_REG(IS_LIVE_R6(liveness),6);
    __DEROOT_PTR_REG(IS_LIVE_R5(liveness),5);
    __DEROOT_PTR_REG(IS_LIVE_R4(liveness),4);
    __DEROOT_PTR_REG(IS_LIVE_R3(liveness),3);
    __DEROOT_PTR_REG(IS_LIVE_R2(liveness),2);
    __DEROOT_PTR_REG(IS_LIVE_R1(liveness),1);

    ASSERT(num_ptr_roots == 0); /* we have put it all back */

    unblockUserSignals();

#endif	/* !CONCURRENT */

#if defined(PROFILING)
    CCC = Save_CCC;

    RESTART_TIME_PROFILER;
#endif
}
\end{code}

This is a wrapper used for all standard, non-threaded, non-parallel GC
purposes.
\begin{code}
#ifdef HEAP_CHK_HYGIENE
I_ doHygieneCheck = 0;
#endif

void
PerformGC(args)
  W_ args;
{
    W_ liveness = HEAP_OVERFLOW_LIVENESS(args);
    W_ reqsize = HEAP_OVERFLOW_REQSIZE(args);
    W_ always_reenter_node = HEAP_OVERFLOW_REENTER(args);

#ifdef HEAP_CHK_HYGIENE
    if (doHygieneCheck) {
	checkHygiene();
	return;
    }
#endif
    RealPerformGC(liveness, reqsize, always_reenter_node, rtsFalse);
}

#if defined(CONCURRENT) && defined(GRAN)
/* This is directly called from the macro GRAN_RESCHEDULE out of the */
/* threaded world. -- HWL */

void
PerformReschedule(liveness, always_reenter_node)
  W_ liveness;
  W_  always_reenter_node;

{
    I_ need_to_reschedule;

    /* Reset the global NeedToReSchedule -- 
       this is used only to communicate the fact that we should schedule
       a new thread rather than the existing one following a fetch.
    */
    need_to_reschedule = NeedToReSchedule;
    NeedToReSchedule = rtsFalse;

    SAVE_Liveness = liveness;

    if (always_reenter_node) {
      /* Avoid infinite loops at the same context switch */
    	if ((TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) &&
	    !need_to_reschedule) {
    	    TSO_SWITCH(CurrentTSO) = NULL;
    	    return;
    	}

      /* Set up to re-enter Node, so as to be sure it's really there. */
      ASSERT(liveness & LIVENESS_R1);
      TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
      TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
    }

    /* We're in a GC callWrapper, so the thread state is safe */
    TSO_ARG1(CurrentTSO) = 0;
    TSO_PC1(CurrentTSO) = EnterNodeCode;
    ReSchedule( (need_to_reschedule && !DoReScheduleOnFetch) ? 
	        CHANGE_THREAD : SAME_THREAD );
}
#endif

#ifndef PAR
/* this is a wrapper used when we want to do a full GC.  

   One reason might be that we're about to enter a time-critical piece
   of code and want to reduce the risk of a GC during the run.  The
   motivating reason is that we want to force the GC to report any
   dead Malloc Pointers to us.

   Note: this should only be called using _ccall_GC_ which saves all
   registers in the usual place (ie the global save area) before the
   call and restores them afterwards.

   ToDo: put in a runtime check that _ccall_GC_ is in action. */

void
StgPerformGarbageCollection()
{
# if ! defined(__STG_GCC_REGS__)
    SaveAllStgRegs();	/* unregisterised case */
# endif

    RealPerformGC(0,0,0,rtsTrue);

# if ! defined(__STG_GCC_REGS__)
    RestoreAllStgRegs();    /* unregisterised case */
# endif
}
#endif /* !PAR */

#ifdef CONCURRENT

# if defined(GRAN)

/* Jim's spark pools are very similar to our processors, except that
   he uses a hard-wired constant.  This would be a mistake for us,
   since we won't always need this many pools.
*/
void 
PruneSparks(STG_NO_ARGS)
{
    sparkq spark, prev, next;
    I_ proc, pool, prunedSparks;

    for(proc=0; proc<max_proc; ++proc) {
    prev = NULL;

    for (pool = 0; pool < SPARK_POOLS; pool++) {
    prunedSparks=0;

    for(spark = PendingSparksHd[proc][pool]; 
	spark != NULL; 
	spark = next) {
        next = SPARK_NEXT(spark);

	/* HACK! The first clause should actually never happen  HWL */

	if ( (SPARK_NODE(spark) == NULL) || 
	     (SPARK_NODE(spark) == Nil_closure) ) {
#  if defined(GRAN_CHECK) && defined(GRAN)
	      if ( debug & 0x40 ) 
		fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Nil_closure\n", spark);
#  endif
    	    if (do_qp_prof)
    	    	QP_Event0(threadId++, SPARK_NODE(spark));

	    if(do_sp_profile)
	      DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark);

	    DisposeSpark(spark);
	    prunedSparks++;
	    }
    	else if (SHOULD_SPARK(SPARK_NODE(spark))) {
    	    /* Keep it */
    	    if (prev == NULL)
    	    	PendingSparksHd[proc][pool] = spark;
    	    else
    	    	SPARK_NEXT(prev) = spark;
    	    SPARK_PREV(spark) = prev;
    	    prev = spark;
    	} else {
    	    if (do_qp_prof)
    	    	QP_Event0(threadId++, SPARK_NODE(spark));

	    if(do_sp_profile)
	      DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark);

	    DisposeSpark(spark);
	    prunedSparks++;
        }
    }  /* forall spark ... */
    if (prev == NULL)
    	PendingSparksHd[proc][pool] = NULL;
    else
    	SPARK_NEXT(prev) = NULL;
    PendingSparksTl[proc][pool] = prev;
    if (prunedSparks>0) 
      fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %ld in PruneSparks\n",
	      prunedSparks,(W_) MAX_SPARKS,proc);
   }  /* forall pool ... */
  }   /* forall proc ... */
}

# else  /* !GRAN */

void
PruneSparks(STG_NO_ARGS)
{
    I_ pool;

    PP_ old;
    PP_ new;

    for (pool = 0; pool < SPARK_POOLS; pool++) {
	new = PendingSparksBase[pool];
	for (old = PendingSparksHd[pool]; old < PendingSparksTl[pool]; old++) {
	    if (SHOULD_SPARK(*old)) {
		/* Keep it */
		*new++ = *old;
	    } else {
		if (DO_QP_PROF)
		    QP_Event0(threadId++, *old);
#  ifdef PAR
	        if(do_sp_profile)
		    DumpSparkGranEvent(SP_PRUNED, threadId++);
#  endif
	    }
	}
	PendingSparksHd[pool] = PendingSparksBase[pool];
	PendingSparksTl[pool] = new;
    }
}

# endif  /* !GRAN */

\end{code}

This is the real GC wrapper for the threaded world.  No context
switching or other nonsense... just set up StorageMgrInfo and perform
a garbage collection.

\begin{code}

void 
ReallyPerformThreadGC(reqsize, do_full_collection)
W_ reqsize;
rtsBool do_full_collection;
{
# if defined(GRAN)
    I_ proc;
#endif

    I_ num_ptr_roots = 0;   	 /* we bump this counter as we store roots; de-bump it
			            as we re-store them. */
    P_ stack, tso, next;

    /* Discard the saved stack and TSO space.
       What's going on here:  TSOs and StkOs are on the mutables
       list (mutable things in the old generation). Here, we change
       them to immutable, so that the scavenger (which chks all
       mutable objects) can detect their immutability and remove
       them from the list.  Setting to MUTUPLE_VHS as the size is
       essentially saying "No pointers in here" (i.e., empty).

       Without this change of status, these
       objects might not really die, probably with some horrible
       disastrous consequence that we don't want to think about.
       Will & Phil 95/10
    */

    for(stack = AvailableStack; stack != Nil_closure; stack = next) {
	next = STKO_LINK(stack);
	FREEZE_MUT_HDR(stack, ImMutArrayOfPtrs_info);
	MUTUPLE_CLOSURE_SIZE(stack) = MUTUPLE_VHS;
    }

    for(tso = AvailableTSO; tso != Nil_closure; tso = next) {
	next = TSO_LINK(tso);
	FREEZE_MUT_HDR(tso, ImMutArrayOfPtrs_info);
	MUTUPLE_CLOSURE_SIZE(tso) = MUTUPLE_VHS;
    }

    AvailableStack = AvailableTSO = Nil_closure;

    PruneSparks();

# if defined(GRAN)
    for(proc = 0; proc < max_proc; ++proc) {

#  if 0
    for(i = 0; i < SPARK_POOLS; i++) {
      if (PendingSparksHd[proc][i] != NULL)
        StorageMgrInfo.roots[num_ptr_roots++] = PendingSparksHd[proc][i];
      if ( PendingSparksTl[proc][i] != NULL)
        StorageMgrInfo.roots[num_ptr_roots++] = PendingSparksTl[proc][i];
     }
#  endif /* 0 */

#  if defined(GRAN_CHECK) && defined(GRAN)
	      if ( debug & 0x40 ) 
		fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
			num_ptr_roots,proc,RunnableThreadsHd[proc]);
#  endif

    StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];

#  if defined(GRAN_CHECK) && defined(GRAN)
	      if ( debug & 0x40 ) 
		fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
			num_ptr_roots,proc,RunnableThreadsTl[proc]);
#  endif       
    StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
    }  /* forall proc ... */

    num_ptr_roots = SaveSparkRoots(num_ptr_roots);
    num_ptr_roots = SaveEventRoots(num_ptr_roots);

# else /* !GRAN */

    StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd;
    StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl;
    StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsHd;
    StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsTl;

# endif /* !GRAN */

# if defined(GRAN_CHECK) && defined(GRAN)
    if ( debug & 0x40 ) 
      fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
	      num_ptr_roots,CurrentTSO);
# endif

    StorageMgrInfo.roots[num_ptr_roots++] = CurrentTSO;

#  ifdef PAR
    StorageMgrInfo.roots[num_ptr_roots++] = PendingFetches;
#  endif

    StorageMgrInfo.rootno = num_ptr_roots;

    blockUserSignals();
    
    if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) { 

	OutOfHeapHook(reqsize * sizeof(W_)); /*msg*/

# if defined(TICKY_TICKY)
	if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
# endif
	EXIT(EXIT_FAILURE);
    }

    StorageMgrInfo.rootno = 0;	/* reset */

    /* root restoring ------------------------------- */
    /* must do all the restoring exactly backwards to the storing! */

# if defined(GRAN_CHECK) && defined(GRAN)
	  if ( debug & 0x40 ) 
	    fprintf(RTSflags.GcFlags.statsFile,"Restoring CurrentTSO %d -- new: 0x%lx\n",
		    num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
# endif

# ifdef PAR
    PendingFetches = StorageMgrInfo.roots[--num_ptr_roots];
# endif
    CurrentTSO = StorageMgrInfo.roots[--num_ptr_roots];
    CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);

# if !defined(GRAN)

    WaitingThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
    WaitingThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];

    RunnableThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
    RunnableThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];

# else /* GRAN */

    num_ptr_roots = RestoreEventRoots(num_ptr_roots);
    num_ptr_roots = RestoreSparkRoots(num_ptr_roots);

    /* NB: PROC is unsigned datatype i.e. (PROC)-1 == (PROC)255  */

    for(proc = max_proc - 1; (proc >= 0) && (proc < max_proc) ; --proc) {

#  if defined(GRAN_CHECK) && defined(GRAN)
	  if ( debug & 0x40 ) 
	    fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
		    num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
#  endif

    RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];

#  if defined(GRAN_CHECK) && defined(GRAN)
	  if ( debug & 0x40 ) 
	    fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
		    num_ptr_roots,proc,StorageMgrInfo.roots[num_ptr_roots]);
#  endif

    RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];

#  if 0
    for(i = SPARK_POOLS - 1; i >= 0; --i) {
      if (PendingSparksTl[proc][i] != NULL)
        PendingSparksTl[proc][i] =  StorageMgrInfo.roots[--num_ptr_roots];
      if (PendingSparksHd[proc][i] != NULL)
        PendingSparksHd[proc][i] =  StorageMgrInfo.roots[--num_ptr_roots];
     }
#  endif
    }

# endif /* GRAN */

    /* Semantics of GC ensures that a block of `reqsize' is now available */
    SAVE_Hp += reqsize;

    unblockUserSignals();
}

#endif /* CONCURRENT */

\end{code}

This routine rattles down the B stack, black-holing any
pending updates to avoid space leaks from them.

\begin{code}
#if !defined(CONCURRENT)

static
void
BlackHoleUpdateStack(STG_NO_ARGS)
{
    P_ PtrToUpdateFrame;

    if (! RTSflags.GcFlags.lazyBlackHoling)
    	return;

    PtrToUpdateFrame = MAIN_SuB;

    /* ToDo: There may be an optimisation here which stops at the first
	     BHed closure on the stack as all below must have been BHed */

    while (SUBTRACT_B_STK(PtrToUpdateFrame, stackInfo.botB) > 0) {

	UPD_BH(GRAB_UPDATEE(PtrToUpdateFrame), BH_UPD_info);

        /* Move PtrToUpdateFrame down B Stack */
	PtrToUpdateFrame = GRAB_SuB(PtrToUpdateFrame);
    }
}
#endif	/* CONCURRENT */
\end{code}


\begin{code}
#if defined(CONCURRENT) && !defined(GRAN)
void
PerformReschedule(W_ liveness, W_ always_reenter_node)
{ }
#endif
\end{code}