path: root/ghc/runtime/storage/SMcopying.lc

\section[SM-copying]{Copying Collector Subroutines}

This is a collection of C functions used in implementing the copying
collectors.

The motivation for making this a separate file/section is twofold:

1) It lets us focus on one thing.

2) If we don't do this, there will be a huge amount of repetition
   between the various GC schemes --- a maintenance nightmare.

The second is the major motivation.  


\begin{code} 
#if defined(GC2s) || defined(GCdu) || defined(GCap) || defined(GCgn)
    /* to the end */

#define SCAV_REG_MAP
#include "SMinternal.h"
REGDUMP(ScavRegDump);

#include "SMcopying.h"
\end{code}

Comment stolen from SMscav.lc: When doing a new generation copy
collection for Appel's collector only evacuate references that point
to the new generation.  OldGen must be set to point to the end of old
space.

\begin{code}
#ifdef GCap

#define MAYBE_EVACUATE_CLOSURE( closure )   \
do {                                        \
  P_ evac = (P_) (closure);                 \
  if (evac > OldGen) {                      \
    (closure) = EVACUATE_CLOSURE(evac);     \
  }                                         \
} while (0)

#else

#define MAYBE_EVACUATE_CLOSURE( closure )   \
do {                                        \
  P_ evac = (P_) (closure);                 \
  (closure) = EVACUATE_CLOSURE(evac);       \
} while (0)

#endif
\end{code}

\begin{code}
void
SetCAFInfoTables(P_ CAFlist)
{
  P_ CAFptr;

  /* Set CAF info tables for evacuation */
  DEBUG_STRING("Setting Evac & Upd CAFs:");
  for (CAFptr = CAFlist; 
       CAFptr != NULL;
       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr) ) {
    INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
  }
}
\end{code}

\begin{code}
void
EvacuateRoots(P_ roots[], I_ rootno)
{
  I_ root;

  DEBUG_STRING("Evacuate (Reg) Roots:");
  for (root = 0; root < rootno; root++) {
    MAYBE_EVACUATE_CLOSURE( roots[root] );
  }
}
\end{code}

Evacuating events is necessary in GRAN since some TSOs and closures are only
pointed at by events we have to schedule later on.

\begin{code}
#if defined(GRAN)
void
EvacuateEvents(STG_NO_ARGS)
{
  eventq event = EventHd;

# if defined(GRAN) && defined(GRAN_CHECK)
  if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
    fprintf(RTSflags.GcFlags.statsFile,"Evacuating Events ...\n");
#endif

  DEBUG_STRING("Evacuate Events:");
  while(event != NULL)
    {
      if(EVENT_TYPE(event) == RESUMETHREAD || 
         EVENT_TYPE(event) == MOVETHREAD || 
         EVENT_TYPE(event) == CONTINUETHREAD || 
         EVENT_TYPE(event) == STARTTHREAD )

       MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );

      else if(EVENT_TYPE(event) == MOVESPARK)

        MAYBE_EVACUATE_CLOSURE( SPARK_NODE(EVENT_SPARK(event)) );

      else if (EVENT_TYPE(event) == FETCHNODE ||
               EVENT_TYPE(event) == FETCHREPLY )
        {

          MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );

	  /* In the case of packet fetching, EVENT_NODE(event) points to */
	  /* the packet (currently, malloced). The packet is just a list of */
	  /* closure addresses, with the length of the list at index 1 (the */
	  /* structure of the packet is defined in Pack.lc). */
	  if ( RTSflags.GranFlags.DoGUMMFetching && 
	       (EVENT_TYPE(event)==FETCHREPLY)) {
	    P_ buffer = (P_) EVENT_NODE(event);
	    int size = (int) buffer[PACK_SIZE_LOCN], i;

	    for (i = PACK_HDR_SIZE; i <= size-1; i++) {
              MAYBE_EVACUATE_CLOSURE( (P_)buffer[i] );
	    }
	  } else 
            MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
        } 
      else if (EVENT_TYPE(event) == GLOBALBLOCK)
	{
          MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
          MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
	}
      else if (EVENT_TYPE(event) == UNBLOCKTHREAD) 
	{
          MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
	}
      event = EVENT_NEXT(event);
    }
}
#endif  /* GRAN */
\end{code}

\begin{code}
#if defined(CONCURRENT) 
# if defined(GRAN)
void
EvacuateSparks(STG_NO_ARGS)
{
  sparkq spark;
  PROC proc;
  I_ pool, total_sparks=0;

  /* Sparks have been pruned already at this point */

# if defined(GRAN) && defined(GRAN_CHECK)
  if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
    fprintf(RTSflags.GcFlags.statsFile,"Evacuating Sparks ...\n");
# endif

  DEBUG_STRING("Evacuate Sparks (GRAN):");
  for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
    for(pool = 0; pool < SPARK_POOLS; ++pool) {
      for(spark = PendingSparksHd[proc][pool]; 
	  spark != NULL; 
	  spark = SPARK_NEXT(spark))
        {
# if defined(GRAN) && defined(GRAN_CHECK)
          if ( RTSflags.GcFlags.giveStats && 
	       (RTSflags.GranFlags.debug & 0x40) &&
	       !SHOULD_SPARK(SPARK_NODE(spark)) )
             fprintf(RTSflags.GcFlags.statsFile,"Qagh {EvacuateSparks}Daq: spark @ 0x%x with node 0x%x shouldn't spark!\n",
                     spark,SPARK_NODE(spark));
# endif
          MAYBE_EVACUATE_CLOSURE(SPARK_NODE(spark));
        }  /* forall spark ... */
    }     /* forall pool ... */
  }      /* forall proc ... */
}

# else  /* !GRAN */

void
EvacuateSparks(STG_NO_ARGS)
{
    PP_ sparkptr;
    int pool;


    DEBUG_STRING("Evacuate Sparks:");
    for (pool = 0; pool < SPARK_POOLS; pool++) {
	for (sparkptr = PendingSparksHd[pool];
	  sparkptr < PendingSparksTl[pool]; sparkptr++) {
	    MAYBE_EVACUATE_CLOSURE(*((PP_) sparkptr));
	}
    }
}
# endif
#endif  /* CONCURRENT */
\end{code}

Note: no \tr{evacuate[AB]Stack} for ``parallel'' systems, because they
don't have a single main stack.

\begin{code}
#if !defined(PAR)
void
EvacuateAStack(PP_ stackA, PP_ botA /* botA points to bottom-most word */)
{
  PP_ stackptr;
  
  DEBUG_STRING("Evacuate A Stack:");
  for (stackptr = stackA;
       SUBTRACT_A_STK(stackptr, botA) >= 0;
       stackptr = stackptr + AREL(1)) {
    MAYBE_EVACUATE_CLOSURE( *((PP_) stackptr) );
  }
}
#endif /* not PAR */
\end{code}

ToDo: Optimisation which squeezes out update frames which point to
garbage closures.

Perform collection first

Then process B stack removing update frames (bot to top via pointer
reversal) that reference garbage closues (test infoptr !=
EVACUATED_INFOPTR)

Otherwise closure is live update reference to to-space address

\begin{code}
#if !defined(PAR)
void
EvacuateBStack( stackB, botB, roots )
  P_ stackB;
  P_ botB;  /* botB points to bottom-most word */
  I_ *roots;
{
  I_ bstk_roots;
  P_ updateFramePtr;
  P_ updatee;

  DEBUG_STRING("Evacuate B Stack:");
  bstk_roots = 0;
  for (updateFramePtr = stackB;  /* stackB points to topmost update frame */
       SUBTRACT_B_STK(updateFramePtr, botB) > 0;
       updateFramePtr = GRAB_SuB(updateFramePtr)) {
    
    /* Evacuate the thing to be updated */
    updatee = GRAB_UPDATEE(updateFramePtr);
    MAYBE_EVACUATE_CLOSURE(updatee);
    PUSH_UPDATEE(updateFramePtr, updatee);
    bstk_roots++;
  }
  *roots = bstk_roots;
}
#endif /* not PAR */
\end{code}

When we do a copying collection, we want to evacuate all of the local
entries in the GALA table for which there are outstanding remote
pointers (i.e. for which the weight is not MAX_GA_WEIGHT.)

\begin{code}
#ifdef PAR

void
EvacuateLocalGAs(rtsBool full)
{
    GALA *gala;
    GALA *next;
    GALA *prev = NULL;

    for (gala = liveIndirections; gala != NULL; gala = next) {
	next = gala->next;
	ASSERT(gala->ga.loc.gc.gtid == mytid);
        if (gala->ga.weight != MAX_GA_WEIGHT) {
	    /* Remote references exist, so we must evacuate the local closure */
	    P_ old = gala->la;
	    MAYBE_EVACUATE_CLOSURE(gala->la);
	    if (!full && gala->preferred && gala->la != old) {
		(void) removeHashTable(LAtoGALAtable, (W_) old, (void *) gala);
		insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
	    }
	    gala->next = prev;
	    prev = gala;
	} else {
	    /* Since we have all of the weight, this GA is no longer needed */
	    W_ pga = PackGA(thisPE, gala->ga.loc.gc.slot);

#ifdef FREE_DEBUG
	    fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
#endif
	    gala->next = freeIndirections;
	    freeIndirections = gala;
	    (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
	    if (!full && gala->preferred)
		(void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
#ifdef DEBUG
	    gala->ga.weight = 0x0d0d0d0d;
	    gala->la = (P_) 0xbadbad;
#endif
	}
    }
    liveIndirections = prev;
}

\end{code}

\begin{code}

EXTDATA_RO(Forward_Ref_info);

void
RebuildGAtables(rtsBool full)
{
    GALA *gala;
    GALA *next;
    GALA *prev;
    P_ closure;

    prepareFreeMsgBuffers();

    for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
	next = gala->next;
	ASSERT(gala->ga.loc.gc.gtid != mytid);

	closure = gala->la;

	/*
	 * If the old closure has not been forwarded, we let go.  Note that this
	 * approach also drops global aliases for PLCs.
	 */

#if defined(GCgn) || defined(GCap)
	if (closure > OldGen) {
#endif
	    if (!full && gala->preferred)
		(void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);

	    /* Follow indirection chains to the end, just in case */
	    while (IS_INDIRECTION(INFO_PTR(closure)))
		closure = (P_) IND_CLOSURE_PTR(closure);

	    /* Change later to incorporate a _FO bit in the INFO_TYPE for GCgn */
#ifdef GCgn
    fall over, until _FO bits are added
#endif
	    if (INFO_PTR(closure) != (W_) Forward_Ref_info) {
		int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
		W_ pga = PackGA(pe, gala->ga.loc.gc.slot);

		(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
		freeRemoteGA(pe, &(gala->ga));
		gala->next = freeGALAList;
		freeGALAList = gala;
	    } else {
		/* Find the new space object */
		closure = (P_) FORWARD_ADDRESS(closure);
		gala->la = closure;

		if (!full && gala->preferred)
		    insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
		gala->next = prev;
		prev = gala;
	    }
#if defined(GCgn) || defined(GCap)
	} else {
	    /* Old generation, minor collection; just keep it */
	    gala->next = prev;
	    prev = gala;
	}
#endif
    }
    liveRemoteGAs = prev;

    /* If we have any remaining FREE messages to send off, do so now */
    sendFreeMessages();

    if (full)
	RebuildLAGAtable();
}

#endif

\end{code}

\begin{code}
void
Scavenge(void)
{
  DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
  while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
  DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
}
\end{code}

\begin{code}
#ifdef GCdu

void
EvacuateCAFs( CAFlist )
  P_ CAFlist;
{
  P_ CAFptr;

  DEBUG_STRING("Evacuate CAFs:");
  for (CAFptr = CAFlist; 
       CAFptr != NULL;
       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
    EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
  }
}

/* ToDo: put GCap EvacuateCAFs code here */

#else /* not GCdu */

void
EvacAndScavengeCAFs( CAFlist, extra_words, roots )
  P_ CAFlist;
  I_ *extra_words;
  I_ *roots;
{
  I_ caf_roots = 0;
  P_ caf_start = ToHp;
  P_ CAFptr;

  DEBUG_STRING("Evacuate & Scavenge CAFs:");
  for (CAFptr = CAFlist; 
       CAFptr != NULL;
       CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {

      EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
      caf_roots++;

      DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
      while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
      DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
  }
  *extra_words = ToHp - caf_start;
  *roots = caf_roots;
}

#endif /* !GCdu */

#endif /* defined(_INFO_COPYING) */
\end{code}