%****************************************************************************

The files SMevac.lc and SMscav.lhc contain the basic routines required
for two-space copying garbage collection.

Two files are required as the evac routines are conventional call/return
routines while the scavenge routines are continuation routines.

This file SMevac.lc contains the evacuation routines ...

See SMscav.lhc for calling convention documentation.

%****************************************************************************

\begin{code}
#define  SCAV_REG_MAP
#include "SMinternal.h"

#if defined(_INFO_COPYING)

/* Moves ToHp to point at the info pointer of the new to-space closure */
#define START_ALLOC(size)     ToHp += 1

/* Moves ToHp to point to the last word allocated in to-space */
#define FINISH_ALLOC(size)    ToHp += (FIXED_HS-1) + (size)


/* Copy the ith word (starting at 0) */
#define COPY_WORD(position)    ToHp[position] = evac[position]

/* Copy the ith ptr (starting at 0), adjusting by offset */
#define ADJUST_WORD(pos,off)   ((PP_)ToHp)[pos] = ((PP_)evac)[pos] + (off)

/* Copy the nth free var word in a SPEC closure (starting at 1) */
#define SPEC_COPY_FREE_VAR(n)  COPY_WORD((SPEC_HS-1) + (n))

#if FIXED_HS == 1
#define COPY_FIXED_HDR         COPY_WORD(0)
#else
#if FIXED_HS == 2
#define COPY_FIXED_HDR         COPY_WORD(0);COPY_WORD(1)
#else
#if FIXED_HS == 3
#define COPY_FIXED_HDR         COPY_WORD(0);COPY_WORD(1);COPY_WORD(2)
#else
/* I don't think this will be needed (ToDo: #error?) */
#endif /* FIXED_HS != 1, 2, or 3 */
#endif
#endif


/*** DEBUGGING MACROS ***/

#if defined(DEBUG)

#define DEBUG_EVAC(sizevar) \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
		evac, ToHp, INFO_PTR(evac), sizevar)

#define DEBUG_EVAC_DYN   \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Dyn info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), DYN_CLOSURE_SIZE(evac))

#define DEBUG_EVAC_TUPLE \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Tuple info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), TUPLE_CLOSURE_SIZE(evac))

#define DEBUG_EVAC_MUTUPLE \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, MuTuple info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), MUTUPLE_CLOSURE_SIZE(evac))

#define DEBUG_EVAC_DATA  \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Data info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), DATA_CLOSURE_SIZE(evac))

#define DEBUG_EVAC_BH(sizevar) \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BH info 0x%lx, size %ld\n", \
		evac, ToHp, INFO_PTR(evac), sizevar)

#define DEBUG_EVAC_FORWARD \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, FORWARD_ADDRESS(evac), INFO_PTR(evac))
   
#define DEBUG_EVAC_IND1 \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))

#define DEBUG_EVAC_IND2 \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac)

#define DEBUG_EVAC_PERM_IND \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Permanent Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))

#define DEBUG_EVAC_CAF_EVAC1 \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Caf 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))

#define DEBUG_EVAC_CAF_EVAC2 \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac)

#define DEBUG_EVAC_CAF_RET \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Caf 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))

#define DEBUG_EVAC_STAT \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, evac, INFO_PTR(evac))

#define DEBUG_EVAC_CONST \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: Const 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, CONST_STATIC_CLOSURE(INFO_PTR(evac)), INFO_PTR(evac))

#define DEBUG_EVAC_CHARLIKE \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: CharLike (%lx) 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, CHARLIKE_VALUE(evac), CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)), INFO_PTR(evac))

#define	DEBUG_EVAC_INTLIKE_TO_STATIC \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
        fprintf(stderr, "Evac: IntLike to Static (%ld) 0x%lx -> 0x%lx, info 0x%lx\n", \
		INTLIKE_VALUE(evac), evac, INTLIKE_CLOSURE(INTLIKE_VALUE(evac)), INFO_PTR(evac))

#define DEBUG_EVAC_TO_OLD \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
	fprintf(stderr, "Old ")

#define DEBUG_EVAC_TO_NEW \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
	fprintf(stderr, "New ")

#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
	fprintf(stderr, "  OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \
			 evac, oldind, newevac)

#define DEBUG_EVAC_OLDROOT_FORWARD \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) { \
	fprintf(stderr, "Evac: OldRoot Forward 0x%lx -> Old 0x%lx ", evac, FORWARD_ADDRESS(evac)); \
	if (! InOldGen(Scav)) fprintf(stderr, "-> New 0x%lx ", IND_CLOSURE_PTR(FORWARD_ADDRESS(evac))); \
        fprintf(stderr, "info 0x%lx\n", INFO_PTR(evac)); \
    }

#ifdef CONCURRENT
#define DEBUG_EVAC_BQ \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BQ info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), BQ_CLOSURE_SIZE(evac))

#define DEBUG_EVAC_TSO(size) \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
        fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \
		evac, ToHp, size)

#define DEBUG_EVAC_STKO(a,b) \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
        fprintf(stderr, "Evac StkO: 0x%lx -> 0x%lx, size %ld (A), %ld (B)\n", \
		evac, ToHp, a, b)

# ifdef PAR
#  define DEBUG_EVAC_BF \
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
        fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BF info 0x%lx, size %lu\n", \
		evac, ToHp, INFO_PTR(evac), BF_CLOSURE_SIZE(dummy))
# endif

#endif

#else

#define DEBUG_EVAC(size)
#define DEBUG_EVAC_DYN
#define DEBUG_EVAC_TUPLE
#define DEBUG_EVAC_MUTUPLE
#define DEBUG_EVAC_DATA
#define DEBUG_EVAC_BH(size)
#define DEBUG_EVAC_FORWARD
#define DEBUG_EVAC_IND1
#define DEBUG_EVAC_IND2
#define DEBUG_EVAC_PERM_IND
#define DEBUG_EVAC_CAF_EVAC1
#define DEBUG_EVAC_CAF_EVAC2
#define DEBUG_EVAC_CAF_RET
#define DEBUG_EVAC_STAT
#define DEBUG_EVAC_CONST
#define DEBUG_EVAC_CHARLIKE
#define	DEBUG_EVAC_INTLIKE_TO_STATIC
#define DEBUG_EVAC_TO_OLD
#define DEBUG_EVAC_TO_NEW
#define DEBUG_EVAC_OLDROOT_FORWARD
#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new)

#ifdef CONCURRENT
# define DEBUG_EVAC_BQ
# define DEBUG_EVAC_TSO(size)
# define DEBUG_EVAC_STKO(s,size)
# ifdef PAR
#  define DEBUG_EVAC_BF
# endif
#endif

#endif /* not DEBUG */


#if defined(GCgn)

/* Evacuation with Promotion -- Have to decide if we promote ! */
/* This is done by fiddling the ToHp pointer before calling    */
/* the real _do_Evacute code, passing reqd forward ref info    */

/* Is a heap ptr in the old generation ? */
#define InOldGen(hpptr)    (((P_)(hpptr)) <= OldGen)

/* Should we promote to the old generation ? */
#define ShouldPromote(evac) (((P_)(evac)) <  AllocGen)


/*** Real Evac Code -- passed closure & forward ref info ***/

#define EVAC_FN(suffix) \
	P_ CAT2(_do_Evacuate_,suffix)(evac, forward_info) \
	P_ evac; P_ forward_info;


/*** Evac Decision Code -- calls real evac code ***/

extern P_ _Evacuate_Old_to_New();

#define GEN_EVAC_CODE(suffix) 			\
    P_ CAT2(_Evacuate_,suffix)(evac) 		\
        P_ evac;                     		\
    {						\
        P_ newevac, tmp;               		\
    	if (ShouldPromote(evac)) {		\
	    DEBUG_EVAC_TO_OLD;			\
	    tmp = ToHp;	ToHp = OldHp;		\
	    newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_Old_info); \
	    OldHp = ToHp; ToHp = tmp;		\
    	} else {				\
	    DEBUG_EVAC_TO_NEW;			\
	    newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_New_info); \
						\
	    /* Check if new gen closure is scavenged from the old gen */ \
	    if (InOldGen(Scav)) {               \
	    	newevac = (P_) _Evacuate_Old_to_New(newevac, evac); \
	    }					\
    	}					\
    	return newevac;				\
    }


/*** FORWARD REF STUFF ***/

/*** Setting Forward Ref: grab argument passed to evac code ***/

/* Note that writing in the forwarding address trashes part of the
   closure.  This is normally fine since, if we want the data, we'll
   have made a copy of it.  

   But, Foreign Object closures are special: we have to make sure that
   we don't damage either the linked list (which will include both
   copied and uncopied Foreign objs) or the data (which we must report
   to the outside world).  Foreign Objects closures are carefully designed
   to have a little extra space in them that can be safely
   overwritten. [ADR] 
*/

#define SET_FORWARD_REF(closure, forw) \
            SET_INFO_PTR(closure,forward); /* arg passed to evac function */ \
            FORWARD_ADDRESS(closure) = (W_)(forw)


EVAC_FN(Old_Forward_Ref)
{
    /* Forward ref to old generation -- just return */
    DEBUG_EVAC_FORWARD;

    evac = (P_) FORWARD_ADDRESS(evac);
    return(evac);
}

EVAC_FN(New_Forward_Ref)
{
    /* Forward ref to new generation -- check scavenged from the old gen */
    DEBUG_EVAC_FORWARD;

    if (InOldGen(Scav)) {
    	evac = (P_) _Evacuate_Old_to_New(FORWARD_ADDRESS(evac), evac);
    } else {
        evac = (P_) FORWARD_ADDRESS(evac);
    }
    return(evac);
}

EVAC_FN(OldRoot_Forward)
{
    /* Forward ref to old generation root -- return old root or new gen closure */
    DEBUG_EVAC_OLDROOT_FORWARD;

    /* grab old generation root */
    evac = (P_) FORWARD_ADDRESS(evac);

    /* if scavenging new generation return the new generation
       closure rather than the old generation root */
    if (! InOldGen(Scav)) {
	evac = (P_) IND_CLOSURE_PTR(evac);
    }

    return(evac);
}

EXTDATA_RO(Forward_Ref_New_info);
EXTDATA_RO(Forward_Ref_Old_info);
EXTDATA_RO(OldRoot_Forward_Ref_info);

/*** Old Gen Reference to New Gen Closure ***/

P_
_Evacuate_Old_to_New(newevac, evac)
P_ newevac, evac;
{
    /* New generation closure referenced from the old generation           */
    /*    allocate old generation indirection to newevac                   */
    /*    reset forward reference in original allocation area to oldind    */
    /*      evacuating this should return the old root or the new gen      */
    /*      closure depending if referenced from the old generation        */
    /*    return oldind as evacuated location                              */
    /*      reference from oldgen will be to this oldind closure           */

    P_ oldind = OldHp + 1;                     /* see START_ALLOC  */
    OldHp = oldind + (FIXED_HS-1) + MIN_UPD_SIZE;  /* see FINISH_ALLOC */

    DEBUG_EVAC_OLD_TO_NEW(oldind, evac, newevac);
    
    INFO_PTR(evac)	     = (W_) OldRoot_Forward_Ref_info;
    FORWARD_ADDRESS(evac)    = (W_)oldind;
	    
    INFO_PTR(oldind)         = (W_) OldRoot_info;
    IND_CLOSURE_PTR(oldind)  = (W_) newevac;
    IND_CLOSURE_LINK(oldind) = (W_) genInfo.OldInNew;
    genInfo.OldInNew = oldind;
    genInfo.OldInNewno++;

    return oldind;
}

#define PROMOTE_MUTABLE(evac)			    \
    if (InOldGen(evac)) {			    \
	MUT_LINK(evac) = (W_) genInfo.PromMutables; \
	genInfo.PromMutables = (P_) evac;	    \
    }

#else /* ! GCgn */

#if defined(GCap)

#define PROMOTE_MUTABLE(evac)			    \
    MUT_LINK(evac) = (W_) appelInfo.PromMutables;   \
    appelInfo.PromMutables = (P_) evac;

#else

#define PROMOTE_MUTABLE(evac)

#endif /* GCap */

/*** Real Evac Code -- simply passed closure ***/

#define EVAC_FN(suffix)	P_ CAT2(_Evacuate_,suffix)(P_ evac)

/*** FORWARD REF STUFF ***/

#define SET_FORWARD_REF(closure, forw) \
            SET_INFO_PTR(closure, Forward_Ref_info); \
            FORWARD_ADDRESS(closure) = (W_) (forw)

P_
_Evacuate_Forward_Ref(evac)
P_ evac;
{
    DEBUG_EVAC_FORWARD;
    evac = (P_) FORWARD_ADDRESS(evac);
    return(evac);
}

EXTDATA_RO(Forward_Ref_info);

#endif /* ! GCgn */


/*** SPECIALISED CODE ***/

/* Note: code for evacuating selectors is given near that for Ind(irections) */

EVAC_FN(1)
{
    START_ALLOC(1);

    DEBUG_EVAC(1);
    COPY_FIXED_HDR;
    SPEC_COPY_FREE_VAR(1);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(1);
    return(evac);
}

EVAC_FN(2)
{
    START_ALLOC(2);
    DEBUG_EVAC(2);
    COPY_FIXED_HDR;
    SPEC_COPY_FREE_VAR(1);
    SPEC_COPY_FREE_VAR(2);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(2);
    return(evac);
}

EVAC_FN(3)
{
    START_ALLOC(3);
    DEBUG_EVAC(3);
    COPY_FIXED_HDR;
    SPEC_COPY_FREE_VAR(1);
    SPEC_COPY_FREE_VAR(2);
    SPEC_COPY_FREE_VAR(3);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(3);
    return(evac);
}

EVAC_FN(4)
{
    START_ALLOC(4);
    DEBUG_EVAC(4);
    COPY_FIXED_HDR;
    SPEC_COPY_FREE_VAR(1);
    SPEC_COPY_FREE_VAR(2);
    SPEC_COPY_FREE_VAR(3);
    SPEC_COPY_FREE_VAR(4);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(4);
    return(evac);
}

EVAC_FN(5)
{
    START_ALLOC(5);
    DEBUG_EVAC(5);
    COPY_FIXED_HDR;
    SPEC_COPY_FREE_VAR(1);
    SPEC_COPY_FREE_VAR(2);
    SPEC_COPY_FREE_VAR(3);
    SPEC_COPY_FREE_VAR(4);
    SPEC_COPY_FREE_VAR(5);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(5);
    return(evac);
}

#define BIG_SPEC_EVAC_FN(n) \
EVAC_FN(n) \
{ \
    int i; \
    START_ALLOC(n); \
    DEBUG_EVAC(n); \
    COPY_FIXED_HDR; \
    for (i = 1; i <= n; i++) { SPEC_COPY_FREE_VAR(i); } \
    SET_FORWARD_REF(evac,ToHp); \
    evac = ToHp; \
    FINISH_ALLOC(n); \
    return(evac); \
}

/* instantiate for 6--12 */
BIG_SPEC_EVAC_FN(6)
BIG_SPEC_EVAC_FN(7)
BIG_SPEC_EVAC_FN(8)
BIG_SPEC_EVAC_FN(9)
BIG_SPEC_EVAC_FN(10)
BIG_SPEC_EVAC_FN(11)
BIG_SPEC_EVAC_FN(12)

\end{code}

A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Whom are we fooling?
This means 2), and the first word after the fixed header is a
@MUT_LINK@.  The second word is a pointer to a blocking queue.
Remaining words are the same as the underlying @SPEC@ closure.  Unlike
their @SPEC@ cousins, @SPEC_RBH@ closures require special handling for
generational collectors, because the blocking queue is a mutable
field.

We don't expect to have a lot of these, so I haven't unrolled the
first five instantiations of the macro, but feel free to do so if it
turns you on.

\begin{code}

#if defined(PAR) || defined(GRAN)

#define SPEC_RBH_EVAC_FN(n)					\
EVAC_FN(CAT2(RBH_,n)) 						\
{ 								\
    I_ count = FIXED_HS - 1;					\
    I_ size  = SPEC_RBH_VHS + (n); 				\
    START_ALLOC(size); 						\
    DEBUG_EVAC(size); 						\
    COPY_FIXED_HDR; 						\
    while (++count <= size + (FIXED_HS - 1)) {			\
	COPY_WORD(count);					\
    }								\
    SET_FORWARD_REF(evac,ToHp); 				\
    evac = ToHp; 						\
    FINISH_ALLOC(size);						\
								\
    PROMOTE_MUTABLE(evac);					\
								\
    return(evac); 						\
}

/* instantiate for 2--12 */
SPEC_RBH_EVAC_FN(2)
SPEC_RBH_EVAC_FN(3)
SPEC_RBH_EVAC_FN(4)
SPEC_RBH_EVAC_FN(5)
SPEC_RBH_EVAC_FN(6)
SPEC_RBH_EVAC_FN(7)
SPEC_RBH_EVAC_FN(8)
SPEC_RBH_EVAC_FN(9)
SPEC_RBH_EVAC_FN(10)
SPEC_RBH_EVAC_FN(11)
SPEC_RBH_EVAC_FN(12)

#endif

#ifndef PAR
EVAC_FN(ForeignObj)
{
    I_ size = ForeignObj_SIZE;
    START_ALLOC(size);
    DEBUG_EVAC(size);

#if defined(DEBUG)
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
      printf("DEBUG: Evacuating ForeignObj(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
      printf(" Data = %x, Finaliser= %x, Next = %x\n", 
	     ForeignObj_CLOSURE_DATA(evac), 
	     ForeignObj_CLOSURE_FINALISER(evac), 
	     ForeignObj_CLOSURE_LINK(evac) );
    }
#endif

    COPY_FIXED_HDR;

    SET_FORWARD_REF(evac,ToHp);
    ForeignObj_CLOSURE_DATA(ToHp)      = ForeignObj_CLOSURE_DATA(evac);
    ForeignObj_CLOSURE_FINALISER(ToHp) = ForeignObj_CLOSURE_FINALISER(evac);
    ForeignObj_CLOSURE_LINK(ToHp)      = ForeignObj_CLOSURE_LINK(evac);

#if defined(DEBUG)
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
      printf("DEBUG: Evacuated  ForeignObj(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
      printf(" Data = %x, Finaliser = %x, Next = %x\n", 
	     ForeignObj_CLOSURE_DATA(ToHp), 
	     ForeignObj_CLOSURE_FINALISER(ToHp), 
	     ForeignObj_CLOSURE_LINK(ToHp));
    }
#endif

    evac = ToHp;
    FINISH_ALLOC(size);
    return(evac);
}
#endif /* !PAR */

/*** GENERIC CASE CODE ***/

EVAC_FN(S)
{
    I_ count = FIXED_HS - 1;
    I_ size = GEN_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC(size);
    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);
    return(evac);
}

\end{code}

Like a @SPEC_RBH@, a @GEN_RBH@ must be at least @MIN_UPD_SIZE@, and
the first word after the fixed header is a @MUT_LINK@.  The second
word is a pointer to a blocking queue.  Remaining words are the same
as the underlying @GEN@ closure.

\begin{code}

#if defined(PAR) || defined(GRAN)
EVAC_FN(RBH_S)
{
    I_ count = GEN_RBH_HS - 1;
    I_ size = GEN_RBH_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC(size);
    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);

    PROMOTE_MUTABLE(evac);

    return(evac);
}
#endif

/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/

EVAC_FN(Dyn)
{
    I_ count = FIXED_HS - 1;
    I_ size = DYN_CLOSURE_SIZE(evac);  /* Includes size and no-of-ptrs fields */

    START_ALLOC(size);
    DEBUG_EVAC_DYN;
    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);
    return(evac);
}

/*** TUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/

EVAC_FN(Tuple)
{
    I_ count = FIXED_HS - 1; 
    I_ size = TUPLE_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC_TUPLE;
    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);
    return(evac);
}

/*** MUTUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/
/*               Only if special GC treatment required             */

#ifdef GC_MUT_REQUIRED
EVAC_FN(MuTuple)
{
    I_ count = FIXED_HS - 1; 
    I_ size = MUTUPLE_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC_MUTUPLE;

    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return(evac);
}
#endif /* GCgn or GCap */


/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/

EVAC_FN(Data)
{
    I_ count = FIXED_HS - 1; 
    I_ size = DATA_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC_DATA;
    COPY_FIXED_HDR;
    while (++count <= size + (FIXED_HS - 1)) {
	COPY_WORD(count);
    }
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);
    return(evac);
}


/*** STATIC CLOSURE CODE ***/

/* Evacuation: Just return static address (no copying required)
               Evac already contains this address -- just return   */
/* Scavenging: Static closures should never be scavenged */

EVAC_FN(Static)
{
    DEBUG_EVAC_STAT;
    return(evac);
}

/*** BLACK HOLE CODE ***/

EVAC_FN(BH_U)
{
    START_ALLOC(BH_U_SIZE);
    DEBUG_EVAC_BH(BH_U_SIZE);
    COPY_FIXED_HDR;
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(BH_U_SIZE);
    return(evac);
}

EVAC_FN(BH_N)
{
    START_ALLOC(BH_N_SIZE);
    DEBUG_EVAC_BH(BH_N_SIZE);
    COPY_FIXED_HDR;
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(BH_N_SIZE);
    return(evac);
}

/*** INDIRECTION CODE ***/

/* permanent indirections first */
#if defined(PROFILING) || defined(TICKY_TICKY)
#undef PI

EVAC_FN(PI) /* used for ticky in case just below... */
{
#ifdef TICKY_TICKY
    if (! AllFlags.doUpdEntryCounts) {
	DEBUG_EVAC_IND1;
	GC_SHORT_IND(); /* ticky: record that we shorted an indirection */

	evac = (P_) IND_CLOSURE_PTR(evac);

# if defined(GCgn) || defined(GCap)
	if (evac > OldGen)  /* Only evacuate new gen with generational collector */
	    evac = EVACUATE_CLOSURE(evac);
# else
	evac = EVACUATE_CLOSURE(evac);
# endif

	DEBUG_EVAC_IND2;
    } else {
#endif

	/* *not* shorting one out... */
	START_ALLOC(IND_CLOSURE_SIZE(dummy));
	DEBUG_EVAC_PERM_IND;
	COPY_FIXED_HDR;
	COPY_WORD(IND_HS);
	SET_FORWARD_REF(evac,ToHp);
	evac = ToHp;
	FINISH_ALLOC(IND_CLOSURE_SIZE(dummy));

#ifdef TICKY_TICKY
    }
#endif
    return(evac);
}
#endif /* PROFILING or TICKY */

EVAC_FN(Ind) /* Indirections are shorted-out; if doing weird ticky
		stuff, we will have used *permanent* indirections
		for overwriting updatees...
	     */
{
    DEBUG_EVAC_IND1;
    GC_SHORT_IND(); /* ticky: record that we shorted an indirection */

    evac = (P_) IND_CLOSURE_PTR(evac);

# if defined(GCgn) || defined(GCap)
    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
	evac = EVACUATE_CLOSURE(evac);
# else
    evac = EVACUATE_CLOSURE(evac);
# endif

    DEBUG_EVAC_IND2;

    /* This will generate a stack of returns for a chain of indirections!
       However chains can only be 2 long.
    */

    return(evac);
}

/*** SELECTORS CODE (much like an indirection) ***/

/* Evacuate a thunk which is selector; it has one free variable which
   points to something which will evaluate to a constructor in a
   single-constructor data type.
 
   If it is so evaluated at GC time, we want to simply select the n'th
   field.

   This thunk is of course always a Spec thing, since it has only one
   free var.

   The constructor is guaranteed to be a Spec thing, so we know where
   the n'th field is.

   ToDo: what if the constructor is a Gen thing?
   
   "selector_depth" stuff below: (WDP 95/12)

      It is possible to have a *very* considerable number of selectors
      all chained together, which will cause the code here to chew up
      enormous C stack space (very deeply nested set of calls), which
      can crash the program.

      Various solutions are possible, but we opt for a simple one --
      we run a "selector_depth" counter, and we stop doing the
      selections if we get beyond that depth.  The main nice property
      is that it doesn't affect (or slow down) any of the rest of the
      GC.
      
      What should the depth be?  For SPARC friendliness, it should
      probably be very small (e.g., 8 or 16), to avoid register-window
      spillage.  However, that would increase the chances that
      selectors are left undone and lots of junk is promoted to the
      old generation.  So we set it quite a bit higher -- we'd like to
      do all the selections except in the most extreme circumstances.
*/
static int selector_depth = 0;
#define MAX_SELECTOR_DEPTH 100 /* reasonably arbitrary */

static P_
_EvacuateSelector_n(P_ evac, I_ n)
{
    P_ maybe_con = (P_) evac[_FHS];

    /* must be a SPEC 2 1 closure */
    ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */

#ifdef TICKY_TICKY
    /* if a thunk, its update-entry count must be zero */
    ASSERT(TICKY_HDR(evac) == 0);
#endif

    selector_depth++; /* see story above */

#if defined(DEBUG)
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
        fprintf(stderr, "Evac Selector (depth %ld): 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
		selector_depth, evac, INFO_PTR(evac), maybe_con,
		INFO_PTR(maybe_con), INFO_TAG(INFO_PTR(maybe_con)));
#endif

    if (INFO_TAG(INFO_PTR(maybe_con)) < 0   /* not in WHNF */
#if !defined(CONCURRENT)
        || (! RTSflags.GcFlags.lazyBlackHoling) /* see "price of laziness" paper */
#endif
	|| selector_depth > MAX_SELECTOR_DEPTH
	|| (! RTSflags.GcFlags.doSelectorsAtGC)
       ) {
#ifdef TICKY_TICKY
	  if (INFO_TAG(INFO_PTR(maybe_con)) >= 0) { /* we *could* have done it */
	     GC_SEL_ABANDONED();
	  }
#endif
	  /* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */
	  return( _Evacuate_2(evac) );
    }

#if defined(DEBUG)
    if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
        fprintf(stderr, "Evac Selector:shorting: 0x%lx -> 0x%lx\n",
		evac, maybe_con[_FHS + n]);
#endif

    /* Ha!  Short it out */
    evac = (P_) (maybe_con[_FHS + n]);	/* evac now has the result of the selection */

    GC_SEL_MINOR(); /* ticky-ticky */

#if defined(GCgn) || defined(GCap)
    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
	evac = EVACUATE_CLOSURE(evac);
#else
    evac = EVACUATE_CLOSURE(evac);
#endif

    selector_depth--; /* see story above */

    return(evac);
}

#define DEF_SEL_EVAC(n) \
P_ CAT2(_EvacuateSelector_,n) (evac) P_ evac; \
{ return(_EvacuateSelector_n(evac,n)); }

/* all the entry points */
DEF_SEL_EVAC(0)
DEF_SEL_EVAC(1)
DEF_SEL_EVAC(2)
DEF_SEL_EVAC(3)
DEF_SEL_EVAC(4)
DEF_SEL_EVAC(5)
DEF_SEL_EVAC(6)
DEF_SEL_EVAC(7)
DEF_SEL_EVAC(8)
DEF_SEL_EVAC(9)
DEF_SEL_EVAC(10)
DEF_SEL_EVAC(11)
DEF_SEL_EVAC(12)

#ifdef CONCURRENT
EVAC_FN(BQ)
{
    START_ALLOC(BQ_CLOSURE_SIZE(dummy));
    DEBUG_EVAC_BQ;

    COPY_FIXED_HDR;
    COPY_WORD(BQ_HS);

    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(BQ_CLOSURE_SIZE(dummy));

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return(evac);
}

EVAC_FN(TSO)
{
    I_ count;
    I_ size = TSO_VHS + TSO_CTS_SIZE;

    START_ALLOC(size);
    DEBUG_EVAC_TSO(size);

    COPY_FIXED_HDR;
    for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
    	COPY_WORD(count);
    }

    *TSO_INTERNAL_PTR(ToHp) = *TSO_INTERNAL_PTR(evac);

    SET_FORWARD_REF(evac, ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return evac;
}

EVAC_FN(StkO)
{
    I_ count;
    I_ size       = STKO_CLOSURE_SIZE(evac);
    I_ spa_offset = STKO_SpA_OFFSET(evac);
    I_ spb_offset = STKO_SpB_OFFSET(evac);
    I_ sub_offset = STKO_SuB_OFFSET(evac);
    I_ offset;

    ASSERT(sanityChk_StkO(evac));

    START_ALLOC(size);
    DEBUG_EVAC_STKO(STKO_CLOSURE_CTS_SIZE(evac) - spa_offset + 1, spb_offset);

    COPY_FIXED_HDR;
#ifdef TICKY_TICKY
    COPY_WORD(STKO_ADEP_LOCN);
    COPY_WORD(STKO_BDEP_LOCN);
#endif
    COPY_WORD(STKO_SIZE_LOCN);
    COPY_WORD(STKO_RETURN_LOCN);
    COPY_WORD(STKO_LINK_LOCN);

    /* Adjust the four stack pointers -- ORDER IS IMPORTANT!! */
    offset = ToHp - evac;

    STKO_SuB(ToHp) = STKO_SuB(evac) + offset;
    STKO_SpB(ToHp) = STKO_SpB(evac) + offset;
    STKO_SpA(ToHp) = STKO_SpA(evac) + offset;
    STKO_SuA(ToHp) = STKO_SuA(evac) + offset;


    /* Slide the A stack */
    for (count = spa_offset; count <= STKO_CLOSURE_CTS_SIZE(evac); count++) {
	COPY_WORD((STKO_HS-1) + count);
    }

    /* Slide the B stack, repairing internal pointers */
    for (count = spb_offset; count >= 1;) {
    	if (count > sub_offset) {
	    COPY_WORD((STKO_HS-1) + count);
    	    count--;
    	} else {
    	    P_ subptr;
    	    /* Repair the internal pointers in the update frame */
	    COPY_WORD((STKO_HS-1) + count + BREL(UF_RET));
	    COPY_WORD((STKO_HS-1) + count + BREL(UF_UPDATEE));
	    ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUA),offset);
	    ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUB),offset);
    	    subptr = GRAB_SuB(STKO_CLOSURE_ADDR(ToHp,sub_offset));
    	    sub_offset = STKO_CLOSURE_OFFSET(ToHp,subptr);
    	    count -= STD_UF_SIZE;
    	}
    }

    SET_FORWARD_REF(evac, ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return evac;
}

#ifdef PAR
EVAC_FN(FetchMe)
{
    START_ALLOC(2);
    DEBUG_EVAC(2);
    COPY_FIXED_HDR;
    COPY_WORD(FETCHME_GA_LOCN);
    ASSERT(GALAlookup(FETCHME_GA(evac)) != NULL);

    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(2);

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return(evac);
}

EVAC_FN(BF)
{
    I_ count;
    I_ size = BF_CLOSURE_SIZE(evac);

    START_ALLOC(size);
    DEBUG_EVAC_BF;

    COPY_FIXED_HDR;
    for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
    	COPY_WORD(count);
    }
    COPY_WORD(BF_LINK_LOCN);
    COPY_WORD(BF_NODE_LOCN);
    COPY_WORD(BF_GTID_LOCN);
    COPY_WORD(BF_SLOT_LOCN);
    COPY_WORD(BF_WEIGHT_LOCN);

    SET_FORWARD_REF(evac, ToHp);
    evac = ToHp;
    FINISH_ALLOC(size);

    /* Add to OldMutables list (if evacuated to old generation) */
    PROMOTE_MUTABLE(evac);

    return evac;
}
#endif  /* PAR */
#endif	/* CONCURRENT */

/*** SPECIAL CAF CODE ***/

/* Evacuation: Return closure pointed to (already explicitly evacuated) */

EVAC_FN(Caf)
{
    DEBUG_EVAC_CAF_RET;
    GC_SHORT_CAF(); /* ticky: record that we shorted an indirection */

    evac = (P_) IND_CLOSURE_PTR(evac);
    return(evac);
}

/* In addition we need an internal Caf indirection which evacuates,
   updates and returns the indirection. Before GC is started, the
   @CAFlist@ must be traversed and the info tables set to this.
*/

EVAC_FN(Caf_Evac_Upd)
{
    P_ closure = evac;

    DEBUG_EVAC_CAF_EVAC1;

    INFO_PTR(evac) = (W_) Caf_info;	/* Change back to Caf_info */

    evac = (P_) IND_CLOSURE_PTR(evac);          /* Grab reference and evacuate */

#if defined(GCgn) || defined(GCap)
    if (evac > OldGen)  /* Only evacuate new gen with generational collector */
	evac = EVACUATE_CLOSURE(evac);
#else
    evac = EVACUATE_CLOSURE(evac);
#endif

    IND_CLOSURE_PTR(closure) = (W_) evac;       /* Update reference */

    DEBUG_EVAC_CAF_EVAC2;
    return(evac);

    /* This will generate a stack of returns for a chain of indirections!
       However chains can only be 2 long.
   */
}


/*** CONST CLOSURE CODE ***/

/* Evacuation: Just return address of the static closure stored in the info table */

EVAC_FN(Const)
{
#ifdef TICKY_TICKY
     if (AllFlags.doUpdEntryCounts) {
	/* evacuate as if a closure of size 0
	   (there is no _Evacuate_0 to call)
	*/
	START_ALLOC(0);
	DEBUG_EVAC(0);
	COPY_FIXED_HDR;
	SET_FORWARD_REF(evac,ToHp);
	evac = ToHp;
	FINISH_ALLOC(0);

     } else {
#endif

    DEBUG_EVAC_CONST;
    GC_COMMON_CONST(); /* ticky */

    evac = CONST_STATIC_CLOSURE(INFO_PTR(evac));

#ifdef TICKY_TICKY
    }
#endif
    return(evac);
}

/*** CHARLIKE CLOSURE CODE ***/

/* Evacuation: Just return address of the static closure stored fixed array */

EVAC_FN(CharLike)
{
#ifdef TICKY_TICKY
     if (AllFlags.doUpdEntryCounts) {
	evac = _Evacuate_1(evac);  /* evacuate closure of size 1 */
     } else {
#endif

    DEBUG_EVAC_CHARLIKE;
    GC_COMMON_CHARLIKE(); /* ticky */

    evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac));

#ifdef TICKY_TICKY
    }
#endif
    return(evac);
}
\end{code}

--- INTLIKE CLOSURE CODE ---

Evacuation: Return address of the static closure if available
Otherwise evacuate converting to aux closure.

There are some tricks here:
\begin{enumerate}
\item
The main trick is that if the integer is in a certain range, we
replace it by a pointer to a statically allocated integer.
\end{enumerate}

(Would it not be more efficient to update the copy directly since
we're about to set a forwarding reference in the original? ADR)

\begin{code}
EVAC_FN(IntLike)
{
    I_ val = INTLIKE_VALUE(evac);
 
    if (val >= MIN_INTLIKE   /* in range of static closures */
     && val <= MAX_INTLIKE
#ifdef TICKY_TICKY
     && !AllFlags.doUpdEntryCounts
#endif
       ) {
	DEBUG_EVAC_INTLIKE_TO_STATIC;
	GC_COMMON_INTLIKE(); /* ticky */

	evac = (P_) INTLIKE_CLOSURE(val); /* return appropriate static closure */
    }
    else {
	evac = _Evacuate_1(evac); /* evacuate closure of size 1 */

#ifdef TICKY_TICKY
	if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
#endif
    }

    return(evac);
}

#if defined (GCgn)
GEN_EVAC_CODE(1)
GEN_EVAC_CODE(2)
GEN_EVAC_CODE(3)
GEN_EVAC_CODE(4)
GEN_EVAC_CODE(5)
GEN_EVAC_CODE(6)
GEN_EVAC_CODE(7)
GEN_EVAC_CODE(8)
GEN_EVAC_CODE(9)
GEN_EVAC_CODE(10)
GEN_EVAC_CODE(11)
GEN_EVAC_CODE(12)
GEN_EVAC_CODE(S)
GEN_EVAC_CODE(Dyn)
GEN_EVAC_CODE(Tuple)
GEN_EVAC_CODE(Data)
GEN_EVAC_CODE(MuTuple)
GEN_EVAC_CODE(IntLike)	/* ToDo: may create oldgen roots referencing static ints */
GEN_EVAC_CODE(CAT2(BH_,MIN_UPD_SIZE))
GEN_EVAC_CODE(CAT2(BH_,MIN_NONUPD_SIZE))
#endif /* GCgn */

#else  /* ! _INFO_COPYING */
This really really should not ever ever come up!
#endif /* ! _INFO_COPYING */
\end{code}