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

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

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(_GC_DEBUG)

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

#define DEBUG_EVAC_DYN   \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, FORWARD_ADDRESS(evac), INFO_PTR(evac))
   
#define DEBUG_EVAC_IND1 \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac)

#define DEBUG_EVAC_PERM_IND \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac)

#define DEBUG_EVAC_CAF_RET \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \
		evac, evac, INFO_PTR(evac))

#define DEBUG_EVAC_CONST \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 (SM_trace & 2) \
	fprintf(stderr, "Old ")

#define DEBUG_EVAC_TO_NEW \
    if (SM_trace & 2) \
	fprintf(stderr, "New ")

#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \
    if (SM_trace & 2) \
	fprintf(stderr, "  OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \
			 evac, oldind, newevac)

#define DEBUG_EVAC_OLDROOT_FORWARD \
    if (SM_trace & 2) { \
	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 (SM_trace & 2) \
        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 (SM_trace & 2) \
        fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \
		evac, ToHp, size)

#define DEBUG_EVAC_STKO(a,b) \
    if (SM_trace & 2) \
        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 (SM_trace & 2) \
        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 _GC_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, Malloc Pointer closures are special: we have to make sure that
   we don't damage either the linked list (which will include both
   copied and uncopied Malloc ptrs) or the data (which we must report
   to the outside world).  Malloc Ptr 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)


P_
_Evacuate_Old_Forward_Ref(evac)
P_ evac;
{
    /* Forward ref to old generation -- just return */
    DEBUG_EVAC_FORWARD;

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

P_
_Evacuate_New_Forward_Ref(evac)
P_ evac;
{
    /* 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);
}

P_
_Evacuate_OldRoot_Forward(evac)
P_ evac;
{
    /* 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)(evac) \
	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@ (Who 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}

#ifdef PAR

#define SPEC_RBH_EVAC_FN(n) \
EVAC_FN(CAT2(RBH_,n)) \
{ \
    int i; \
    START_ALLOC(n); \
    DEBUG_EVAC(n); \
    COPY_FIXED_HDR; \
    for (i = 0; i < n - 1; i++) { COPY_WORD(SPEC_RBH_HS + i); } \
    SET_FORWARD_REF(evac,ToHp); \
    evac = ToHp; \
    FINISH_ALLOC(n); \
    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(MallocPtr)
{
    START_ALLOC(MallocPtr_SIZE);
    DEBUG_EVAC(MallocPtr_SIZE);

#if defined(_GC_DEBUG)
    if (SM_trace & 16) {
      printf("DEBUG: Evacuating MallocPtr(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
      printf(" Data = %x, Next = %x\n", 
	     MallocPtr_CLOSURE_DATA(evac), MallocPtr_CLOSURE_LINK(evac) );
    }
#endif

    COPY_FIXED_HDR;

    SET_FORWARD_REF(evac,ToHp);
    MallocPtr_CLOSURE_DATA(ToHp) = MallocPtr_CLOSURE_DATA(evac);
    MallocPtr_CLOSURE_LINK(ToHp) = MallocPtr_CLOSURE_LINK(evac);

#if defined(_GC_DEBUG)
    if (SM_trace & 16) {
      printf("DEBUG: Evacuated  MallocPtr(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
      printf(" Data = %x, Next = %x\n", 
	     MallocPtr_CLOSURE_DATA(ToHp), MallocPtr_CLOSURE_LINK(ToHp) );
    }
#endif

    evac = ToHp;
    FINISH_ALLOC(MallocPtr_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}

#ifdef PAR
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 */

P_
_Evacuate_Static(evac)
P_ evac;
{
    DEBUG_EVAC_STAT;
    return(evac);
}

void
_Scavenge_Static(STG_NO_ARGS)
{
    fprintf(stderr,"Called _Scavenge_Static: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
    abort();
}


/*** BLACK HOLE CODE ***/

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

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

/*** INDIRECTION CODE ***/

/* Evacuation: Evacuate closure pointed to */

P_
_Evacuate_Ind(evac)
P_ evac;
{
    DEBUG_EVAC_IND1;
    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;
    return(evac);

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

#ifdef USE_COST_CENTRES
#undef PI
EVAC_FN(PI)
{
    START_ALLOC(MIN_UPD_SIZE);
    DEBUG_EVAC_PERM_IND;
    COPY_FIXED_HDR;
    COPY_WORD(IND_HS);
    SET_FORWARD_REF(evac,ToHp);
    evac = ToHp;
    FINISH_ALLOC(MIN_UPD_SIZE);
    return(evac);
}
#endif

/*** 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?
*/
static P_
_EvacuateSelector_n(evac, 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 */

#if defined(_GC_DEBUG)
    if (SM_trace & 2)
        fprintf(stderr, "Evac Selector: 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
		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 */
	  /* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */
	  return( _Evacuate_2(evac) );

#if defined(_GC_DEBUG)
    if (SM_trace & 2)
        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 */

#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

    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(MIN_UPD_SIZE);
    DEBUG_EVAC_BQ;

    COPY_FIXED_HDR;
    COPY_WORD(BQ_HS);

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

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

    return(evac);
}

EVAC_FN(TSO)
{
    I_ count;

    START_ALLOC(TSO_VHS + TSO_CTS_SIZE);
    DEBUG_EVAC_TSO(TSO_VHS + TSO_CTS_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(TSO_VHS + TSO_CTS_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;

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

    COPY_FIXED_HDR;
#ifdef DO_REDN_COUNTING
    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;

    START_ALLOC(BF_CLOSURE_SIZE(evac));
    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(BF_CLOSURE_SIZE(evac));

    /* 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) */
/* Scavenging: Should not be scavenged */  

P_
_Evacuate_Caf(evac)
P_ evac;
{
    DEBUG_EVAC_CAF_RET;
    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.
*/

P_
_Evacuate_Caf_Evac_Upd(evac)
  P_ evac;
{
    P_ closure = evac;

    DEBUG_EVAC_CAF_EVAC1;
    INFO_PTR(evac) = (W_) Caf_info;		/* Change to return CAF */

    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 */
/* Scavenging: Const closures should never be scavenged */

P_
_Evacuate_Const(evac)
P_ evac;
{
    DEBUG_EVAC_CONST;
    evac = CONST_STATIC_CLOSURE(INFO_PTR(evac));
    return(evac);
}

void
_Scavenge_Const(STG_NO_ARGS)
{
    fprintf(stderr,"Called _Scavenge_Const: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
    abort();
}


/*** CHARLIKE CLOSURE CODE ***/

/* Evacuation: Just return address of the static closure stored fixed array */
/* Scavenging: CharLike closures should never be scavenged */

P_
_Evacuate_CharLike(evac)
P_ evac;
{
    DEBUG_EVAC_CHARLIKE;
    evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac));
    return(evac);
}

void
_Scavenge_CharLike(STG_NO_ARGS)
{
    fprintf(stderr,"Called _Scavenge_CharLike: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
    abort();
}
\end{code}

--- INTLIKE CLOSURE CODE ---

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

Scavenging: IntLike closures should never be scavenged.

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 <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {   /* in range of static closures */
	DEBUG_EVAC_INTLIKE_TO_STATIC;
	evac = (P_) INTLIKE_CLOSURE(val);             /* return appropriate static closure */
    }
    else {
	START_ALLOC(1);                                   /* evacuate closure of size 1 */
	DEBUG_EVAC(1);
	COPY_FIXED_HDR;
	SPEC_COPY_FREE_VAR(1);
	SET_FORWARD_REF(evac,ToHp);
	evac = ToHp;
	FINISH_ALLOC(1);
    }
    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}