path: root/ghc/runtime/gum/Pack.lc

%
% (c) The Parade/AQUA Projects, Glasgow University, 1995
%     Kevin Hammond, February 15th. 1995
%
%     This is for GUM and for GrAnSim.
%
%************************************************************************
%*                                                                      *
\section[Pack.lc]{Packing closures for export to remote processors}
%*									*
%************************************************************************

This module defines routines for packing closures in the parallel runtime
system (GUM).

The GrAnSim version of the code defines routines for *simulating* the
packing of closures in the same way it
is done in the parallel runtime system. Basically GrAnSim only puts the
addresses of the closures to be transferred into a buffer. This buffer will
then be associated with the event of transferring the graph. When this
event is scheduled, the @UnpackGraph@ routine is called and the buffer
can be discarded afterwards. 

Note that in GrAnSim we need many buffers, not just one per PE.

\begin{code}
#if defined(PAR) || defined(GRAN)   /* whole file */

#include "rtsdefs.h"

/* Which RTS flag should be used to get the size of the pack buffer ? */
#if defined(PAR)
#define PACK_BUFFER_SIZE   RTSflags.ParFlags.packBufferSize
#else   /* GRAN */
#define PACK_BUFFER_SIZE   RTSflags.GranFlags.packBufferSize
#endif
\end{code}

Static data and code declarations.

\begin{code}
#if defined(GRAN)
/* To be pedantic: in GrAnSim we're packing *addresses* of closures,
   not the closures themselves.
*/
static P_ *PackBuffer = NULL; /* size: can be set via option */
#else
static W_ *PackBuffer = NULL;                /* size: can be set via option */
#endif

static W_      packlocn, clqsize, clqpos;
static W_      unpackedsize;
static W_      reservedPAsize;         /*Space reserved for primitive arrays*/
static rtsBool RoomInBuffer;


static void    InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
#if defined(GRAN)
static rtsBool NotYetPacking PROTO((P_ closure));
static void    Pack PROTO((P_ data));
#else
static rtsBool NotYetPacking PROTO((int offset));
static void    Pack PROTO((W_ data));
#endif
static rtsBool RoomToPack PROTO((W_ size, W_ ptrs));
static void    AmPacking PROTO((P_ closure));

static void    PackClosure PROTO((P_ closure))
#if !defined(GRAN)
               , PackPLC PROTO((P_ addr))
	       , PackOffset PROTO((int offset))
	       , GlobaliseAndPackGA PROTO((P_ closure))
#endif
               ;

static int     OffsetFor PROTO((P_ closure));
\end{code}

Bit of a hack for testing if a closure is the root of the graph. This is 
set in @PackNearbyGraph@ and tested in @PackClosure@.

\begin{code}
#if defined(GRAN)
I_ packed_thunks = 0;
P_ graphroot;
#endif
\end{code}

%************************************************************************
%*                                                                      *
\subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
%*									*
%************************************************************************

@PackNearbyGraph@ packs a closure and associated graph into a static
buffer (@PackBuffer@).  It returns the address of this buffer and the
size of the data packed into the buffer (in its second parameter,
@packbuffersize@).  The associated graph is packed in a depth first
manner, hence it uses an explicit queue of closures to be packed
rather than simply using a recursive algorithm.  Once the packet is
full, closures (other than primitive arrays) are packed as FetchMes,
and their children are not queued for packing.

\begin{code}
#  if defined(PAR)
P_
PackNearbyGraph(closure, packbuffersize)
P_ closure;
W_ *packbuffersize;
#  else  /* GRAN */
P_
PackNearbyGraph(closure, tso, packbuffersize)
P_ closure;
P_ tso;
W_ *packbuffersize;
#  endif
{
    /* Ensure enough heap for all possible RBH_Save closures */

    ASSERT(PACK_BUFFER_SIZE > 0);

#  if defined(GRAN) && defined(GRAN_CHECK)
    if ( RTSflags.GranFlags.debug & 0x100 ) 
      fprintf(stderr,"Packing graph with root at 0x%lx (PE %d); demanded by TSO %#lx (%d) (PE %d)  ...\n",
	      closure, where_is(closure), tso, TSO_ID(tso), where_is(tso) );
#  endif   /* GRAN */

    if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
	return NULL;

    InitPacking();
#  if defined(GRAN)
    graphroot = closure;
#  endif

    QueueClosure(closure);
    do {
	PackClosure(DeQueueClosure());
    } while (!QueueEmpty());

#  if defined(PAR)
    /* Record how much space is needed to unpack the graph */
    PackBuffer[0] = unpackedsize;
#  else  /* GRAN */
    /* Record how much space is needed to unpack the graph */
    PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
    PackBuffer[PACK_TSO_LOCN] = tso;
    PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
#  endif

    /* Set the size parameter */
# if defined(PAR)
    ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
    *packbuffersize = packlocn;
#  else  /* GRAN */
    ASSERT(packlocn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
    /* ToDo: Print an earlier, more meaningful message */
    if (packlocn==PACK_HDR_SIZE) {  /* i.e. packet is empty */
      fprintf(stderr,"EMPTY PACKET! Can't transfer closure %#lx at all!!\n",
	      closure);
      EXIT(EXIT_FAILURE);
    }
    PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
    *packbuffersize = packlocn;
#  endif

#  if !defined(GRAN)
    DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */
#  endif

#  if defined(GRAN) && defined(GRAN_CHECK)
    tot_packets++; 
    tot_packet_size += packlocn-PACK_HDR_SIZE  ; 

    if ( RTSflags.GranFlags.debug & 0x100 ) {
      PrintPacket((P_)PackBuffer);
    }
#  endif   /* GRAN */

    return ((P_)PackBuffer);
}

#if defined(GRAN)
/* This version is used when the node is already local */

P_
PackOneNode(closure, tso, packbuffersize)
P_ closure;
P_ tso;
W_ *packbuffersize;
{
    int i, clpacklocn;

    InitPacking();

#  if defined(GRAN) && defined(GRAN_CHECK)
    if ( RTSflags.GranFlags.debug & 0x100 ) {
      W_ size, ptrs, nonptrs, vhs;
      P_ info;
      char str[80], junk_str[80]; 
      
      info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
      fprintf(stderr,"PackOneNode: %#lx (%s)(PE %#lx) requested by TSO %#lx (%d) (PE %#lx)\n",
	      closure, str, where_is(closure), tso, TSO_ID(tso), where_is(tso));
    }
#  endif

    Pack(closure);

    /* Record how much space is needed to unpack the graph */
    PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
    PackBuffer[PACK_TSO_LOCN] = tso;
    PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;

    /* Set the size parameter */
    ASSERT(packlocn <= PACK_BUFFER_SIZE);
    PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
    *packbuffersize = packlocn;

#  if defined(GRAN) && defined(GRAN_CHECK)
    tot_packets++; 
    tot_packet_size += packlocn-PACK_HDR_SIZE  ; 

    if ( RTSflags.GranFlags.debug & 0x100 ) {
      PrintPacket(PackBuffer);
    }
#  endif   /* GRAN */

    return ((P_)PackBuffer);
}
#endif  /* GRAN */
\end{code}

@PackTSO@ and @PackStkO@ are entry points for two special kinds of
closure which are used in the parallel RTS.  Compared with other
closures they are rather awkward to pack because they don't follow the
normal closure layout (where all pointers occur before all non-pointers).
Luckily, they're only needed when migrating threads between processors.

\begin{code}
#if defined(GRAN)
P_ *
#else
W_ *
#endif
PackTSO(tso,packbuffersize)
P_ tso;
W_ *packbuffersize;
{
  *packbuffersize = 0;
  PackBuffer[0] = PackBuffer[1] = 0;
  return(PackBuffer);
}

#if defined(GRAN)
P_ *
#else
W_ *
#endif
PackStkO(stko,packbuffersize)
P_ stko;
W_ *packbuffersize;
{
  *packbuffersize = 0;
  PackBuffer[0] = PackBuffer[1] = 0;
  return(PackBuffer);
}
\end{code}


%************************************************************************
%*                                                                      *
\subsection[PackClosure]{Packing Closures}
%*									*
%************************************************************************

@PackClosure@ is the heart of the normal packing code.  It packs a
single closure into the pack buffer, skipping over any indirections
and globalising it as necessary, queues any child pointers for further
packing, and turns it into a @FetchMe@ or revertible black hole
(@RBH@) locally if it was a thunk.  Before the actual closure is
packed, a suitable global address (GA) is inserted in the pack buffer.
There is always room to pack a fetch-me to the closure (guaranteed by
the RoomToPack calculation), and this is packed if there is no room
for the entire closure.

Space is allocated for any primitive array children of a closure, and
hence a primitive array can always be packed along with it's parent
closure.

\begin{code}
#if defined(PAR)

void
PackClosure(closure)
P_ closure;
{
    W_ size, ptrs, nonptrs, vhs;
    int i, clpacklocn;
    char str[80];

    while (IS_INDIRECTION(INFO_PTR(closure))) {
	/* Don't pack indirection closures */
#  ifdef PACK_DEBUG
	fprintf(stderr, "Shorted an indirection at %x", closure);
#  endif
	closure = (P_) IND_CLOSURE_PTR(closure);
    }

    clpacklocn = OffsetFor(closure);

    /* If the closure's not already being packed */
    if (NotYetPacking(clpacklocn)) {
	P_ info;

	/*
	 * PLCs reside on all of the PEs already. Just pack the
	 * address as a GA (a bit of a kludge, since an address may
	 * not fit in *any* of the individual GA fields). Const,
	 * charlike and small intlike closures are converted into
	 * PLCs.
	 */
	switch (INFO_TYPE(INFO_PTR(closure))) {

	case INFO_CHARLIKE_TYPE:
#  ifdef PACK_DEBUG
	    fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
#  endif
	    PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
	    return;

	case INFO_CONST_TYPE:
#  ifdef PACK_DEBUG
	    fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
#  endif
	    PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
	    return;

	case INFO_STATIC_TYPE:
	case INFO_CAF_TYPE:	/* For now we ship indirections to CAFs: They are
				 * evaluated on each PE if needed */
#  ifdef PACK_DEBUG
	    fprintf(stderr, "Packing a PLC %x\n", closure);
#  endif
	    PackPLC(closure);
	    return;

	case INFO_INTLIKE_TYPE:
	    {
		I_ val = INTLIKE_VALUE(closure);

		if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
#  ifdef PACK_DEBUG
		    fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
#  endif
		    PackPLC(INTLIKE_CLOSURE(val));
		    return;
		} else {
#  ifdef PACK_DEBUG
		    fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
#  endif
		    break;
		}
	    }
	default:
#  ifdef PACK_DEBUG
	    fprintf(stderr, "Not a PLC: ");
#  endif
	}			/* Switch */

	/* Otherwise it's not Fixed */

	info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);

	if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
	    size = ptrs = nonptrs = vhs = 0;

	/*
	 * Now peek ahead to see whether the closure has any primitive array
	 * children
	 */
	for (i = 0; i < ptrs; ++i) {
	    P_ childInfo;
	    W_ childSize, childPtrs, childNonPtrs, childVhs;

	    childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
	      &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
	    if (IS_BIG_MOTHER(childInfo)) {
		reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
		  + childPtrs * PACK_FETCHME_SIZE;
	    }
	}

	/* Record the location of the GA */
	AmPacking(closure);

	/* Pack the global address */
	GlobaliseAndPackGA(closure);

	/*
	 * Pack a fetchme to the closure if it's a black hole, or the buffer is full
	 * and it isn't a primitive array. N.B. Primitive arrays are always packed
	 * (because their parents index into them directly)
	 */

	if (IS_BLACK_HOLE(info) ||
	  !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
	  || IS_BIG_MOTHER(info))) {

	    ASSERT(packlocn > PACK_HDR_SIZE);

	    /* Just pack as a FetchMe */
	    info = FetchMe_info;
	    for (i = 0; i < FIXED_HS; ++i) {
		if (i == INFO_HDR_POSN)
		    Pack((W_) FetchMe_info);
		else
		    Pack(closure[i]);
	    }

	    unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);

	} else {
	    /* At last! A closure we can actually pack! */

	    if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
		fprintf(stderr, "Warning: Replicated a Mutable closure!\n");

	    for (i = 0; i < FIXED_HS + vhs; ++i)
		Pack(closure[i]);

	    for (i = 0; i < ptrs; ++i)
		QueueClosure(((PP_) (closure))[i + FIXED_HS + vhs]);

	    for (i = 0; i < nonptrs; ++i)
		Pack(closure[i + FIXED_HS + vhs + ptrs]);

	    unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);

	    /*
	     * Record that this is a revertable black hole so that we can fill in
	     * its address from the fetch reply.  Problem: unshared thunks may cause
	     * space leaks this way, their GAs should be deallocated following an
	     * ACK.
	     */

	    if (IS_THUNK(info) && IS_UPDATABLE(info)) {
#  ifdef DEBUG
		P_ rbh =
#  else
		(void)
#  endif
		convertToRBH(closure);

		ASSERT(rbh != NULL);
	    }
	}
    }
    /* Pack an indirection to the original closure! */
    else
	PackOffset(clpacklocn);
}

#else  /* GRAN */

/* Fake the packing of a closure */

void
PackClosure(closure)
P_ closure;
{
    W_ size, ptrs, nonptrs, vhs;
    W_ childSize, childPtrs, junk;   /*size, no. ptrs etc. of a child closure*/
    P_ childInfo;
    P_ info;
    int i, clpacklocn;
    W_ PAsize = 0;           /*total size + no. ptrs of all child prim arrays*/
    W_ PAptrs = 0;
    char str[80], junk_str[80]; 
    rtsBool will_be_rbh, no_more_thunks_please;

    /* In GranSim we don't pack and unpack closures -- we just simulate */
    /* that by updating the bitmask. So, the graph structure is unchanged */
    /* i.e. we don't short out indirections here. -- HWL */

    if (where_is(closure) != where_is(graphroot)) {
      /* GUM would pack a FETCHME here; simulate that by increasing the */
      /* unpacked size accordingly but don't pack anything -- HWL */
      unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(closure);
      return; 
    }
    /* clpacklocn = OffsetFor(closure); */

    /* If the closure's not already being packed */
    if (NotYetPacking(closure)) {
	switch (INFO_TYPE(INFO_PTR(closure))) {
	case INFO_SPEC_RBH_TYPE:
	case INFO_GEN_RBH_TYPE:
#  if defined(GRAN) && defined(GRAN_CHECK)
	  if ( RTSflags.GranFlags.debug & 0x100 ) {
	    fprintf(stderr,"************ Avoid packing RBH @ %#lx!\n", closure);
	  }
#  endif
          /* Just ignore RBHs i.e. they stay where they are */
	  return;

	case INFO_CHARLIKE_TYPE:
	case INFO_CONST_TYPE:
	case INFO_STATIC_TYPE:
	case INFO_CAF_TYPE:       /* For now we ship indirections to CAFs:
				   * They are evaluated on each PE if needed */
	  Pack(closure);
	  return;

	case INFO_INTLIKE_TYPE:
	  {
	    I_ val = INTLIKE_VALUE(closure);
	    if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
	      Pack(closure);
	      return;
	    } else {
	      break;
	    }
	  }
	default:
	  /* Just fall through to the rest of the function */
	}     /* Switch */

	/* Otherwise it's not Fixed */

	info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
	will_be_rbh = IS_THUNK(info) && IS_UPDATABLE(info);
	no_more_thunks_please = 
	   (RTSflags.GranFlags.ThunksToPack>0) && 
	   (packed_thunks>=RTSflags.GranFlags.ThunksToPack);

	if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
	    size = ptrs = nonptrs = vhs = 0;

	/* Now peek ahead to see whether the closure has any primitive */
	/* array children */ 
	for (i = 0; i < ptrs; ++i) {
	    P_ childInfo;
	    W_ childSize, childPtrs, childNonPtrs, childVhs;

	  childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
				       &childSize, &childPtrs, &childNonPtrs,
				       &childVhs, junk_str);
	  if (IS_BIG_MOTHER(childInfo)) {
		reservedPAsize += PACK_GA_SIZE + FIXED_HS + 
		                  childVhs + childNonPtrs +
		                  childPtrs * PACK_FETCHME_SIZE;
	    PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
	    PAptrs += childPtrs;
	  }
	}

	/* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
	 * is full and it isn't a primitive array. N.B. Primitive arrays are
	 * always packed (because their parents index into them directly) */

	if (IS_BLACK_HOLE(info) || 
	    !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs) 
	      || IS_BIG_MOTHER(info))) 
          return;

	/* At last! A closure we can actually pack! */

	if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
	    fprintf(stderr,"Warning: Replicated a Mutable closure!");

#  if defined(GRAN) && defined(GRAN_CHECK)
	if (no_more_thunks_please && will_be_rbh) {
	  tot_cuts++;
	  if ( RTSflags.GranFlags.debug & 0x100 ) 
	    fprintf(stderr,"PackClosure (w/ RTSflags.GranFlags.ThunksToPack=%d): Cutting tree with root at %#lx\n",
		      RTSflags.GranFlags.ThunksToPack, closure);
	} else if (will_be_rbh || (closure==graphroot) ) {
	    packed_thunks++;
	    tot_thunks++;
        }
#  endif
	if (!(no_more_thunks_please && will_be_rbh)) {
	  Pack(closure);         /* actual PACKING done here --  HWL */
	  for (i = 0; i < ptrs; ++i)
	    QueueClosure(((StgPtrPtr) (closure))[i + FIXED_HS + vhs]);

	  /* Turn thunk into a revertible black hole. */
	  if (will_be_rbh)
            { 
	     P_ rbh;

#  if defined(GRAN) && defined(GRAN_CHECK)
	     if ( RTSflags.GranFlags.debug & 0x100 ) {
	       fprintf(stderr,"> RBHing the following closure:\n (%#lx) ",
	  	                closure);
	       G_PPN(closure);                          /* see StgDebug */
	     }
#  endif
	     rbh = convertToRBH(closure);
	     ASSERT(rbh != NULL);
	    }
        }        
      }
    else /* !NotYetPacking(clpacklocn) */ 
         /* Don't have to do anything in GrAnSim if closure is already */
	 /* packed -- HWL */
      {
#  if defined(GRAN) && defined(GRAN_CHECK)
	if ( RTSflags.GranFlags.debug & 0x100 )
	  fprintf(stderr,"*** Closure %#lx is already packed and omitted now!\n",
		  closure);
#  endif
      }
}
#endif  /* PAR */
\end{code}

%************************************************************************
%*                                                                      *
\subsection[simple-pack-routines]{Simple Packing Routines}
%*									*
%************************************************************************

About  packet sizes  in GrAnSim: In  GrAnSim  we use  a  malloced block  of
gransim_pack_buffer_size words to   simulate a  packet of  pack_buffer_size
words.  In the simulated  PackBuffer  we only keep   the  addresses of  the
closures that would be packed in the parallel  system (see Pack). To decide
if a  packet overflow  occurs   pack_buffer_size must be   compared  versus
unpackedsize (see RoomToPack).      Currently, there is    no  multi packet
strategy implemented, so in  the case of  an overflow  we just stop  adding
closures  to the  closure queue.  If  an  overflow of the  simulated packet
occurs, we just realloc some more space for it and carry on as usual.  
% -- HWL

\begin{code}
#if defined(GRAN)
static P_ *
InstantiatePackBuffer () {

  PackBuffer = 
    /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
    (P_ *) stgMallocWords(RTSflags.GranFlags.packBufferSize_internal+PACK_HDR_SIZE,
                          "InstantiatePackBuffer") ;

  PackBuffer[PACK_SIZE_LOCN] = (P_)RTSflags.GranFlags.packBufferSize_internal;

  return (PackBuffer);
}
#endif
\end{code}

@Pack@ is the basic packing routine.  It just writes a word of
data into the pack buffer and increments the pack location.

\begin{code}
#if defined(PAR)
static void
Pack(data)
  W_ data;
{
    ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
    PackBuffer[packlocn++] = data;
}
#else  /* GRAN */
static void
Pack(addr)
P_ addr;
{
  W_ size, ptrs, nonptrs, vhs;
  P_ info;
  char str[80];

  /* This checks the size of the GrAnSim internal pack buffer. The simulated
     pack buffer is checked via RoomToPack (as in GUM) */
  if (packlocn >= (int)PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE) {

# if defined(GRAN_CHECK)
    if ( RTSflags.GranFlags.debug & 0x8000 ) {
      fprintf(stderr, "Increasing size of PackBuffer %#lx to %d words (PE %u @ %d)\n",
	      PackBuffer, PackBuffer[PACK_SIZE_LOCN]+REALLOC_SZ,
	      CurrentProc, CurrentTime[CurrentProc]);
    }
# endif
    PackBuffer = (P_ *) realloc(PackBuffer, 
				sizeof(P_)*(REALLOC_SZ +
                                            (int)PackBuffer[PACK_SIZE_LOCN] +
                                            PACK_HDR_SIZE)) ;
    if (PackBuffer == NULL) {
      fprintf(stderr,"Failing to realloc %d more words for PackBuffer %#lx (PE %u @ %d)\n", 
	      REALLOC_SZ, PackBuffer, CurrentProc, CurrentTime[CurrentProc]);
      EXIT(EXIT_FAILURE);
    } 
    PackBuffer[PACK_SIZE_LOCN] += REALLOC_SZ;
  }

  ASSERT(packlocn < PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);

  if (addr==NULL) 
    fprintf(stderr,"Qagh {Pack}Daq: Trying to pack 0\n");
  PackBuffer[packlocn++] = addr;
  /* ASSERT: Data is a closure in GrAnSim here */
  info = get_closure_info(addr, &size, &ptrs, &nonptrs, &vhs, str);
  unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? 
				        MIN_UPD_SIZE : 
				        size);
}
#endif  /* PAR */
\end{code}

If a closure is local, make it global.  Then, divide its weight for export.
The GA is then packed into the pack buffer.

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

static void
GlobaliseAndPackGA(closure)
P_ closure;
{
    globalAddr *ga;
    globalAddr packGA;

    if ((ga = LAGAlookup(closure)) == NULL)
	ga = MakeGlobal(closure, rtsTrue);
    splitWeight(&packGA, ga);
    ASSERT(packGA.weight > 0);

#ifdef PACK_DEBUG
    fprintf(stderr, "Packing (%x, %d, %x)\n", 
      packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
#endif
    Pack((W_) packGA.weight);
    Pack((W_) packGA.loc.gc.gtid);
    Pack((W_) packGA.loc.gc.slot);
}
\end{code}

@PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
address follows instead of PE, slot.

\begin{code}
static void
PackPLC(addr)
P_ addr;
{
    Pack(0L);			/* weight */
    Pack((W_) addr);		/* address */
}
\end{code}

@PackOffset@ packs a special GA value that will be interpreted as
an offset to a closure in the pack buffer.  This is used to avoid
unfolding the graph structure into a tree.

\begin{code}
static void
PackOffset(offset)
int offset;
{
#ifdef PACK_DEBUG
    fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
#endif
    Pack(1L);			/* weight */
    Pack(0L);			/* pe */
    Pack(offset);		/* slot/offset */
}
#endif  /* !GRAN */
\end{code}

%************************************************************************
%*                                                                      *
\subsection[pack-offsets]{Offsets into the Pack Buffer}
%*									*
%************************************************************************

The offset hash table is used during packing to record the location in
the pack buffer of each closure which is packed.

\begin{code}
#if defined(PAR)
static HashTable *offsettable;
\end{code}

@InitPacking@ initialises the packing buffer etc.

\begin{code}
void
InitPackBuffer(STG_NO_ARGS)
{
  if (PackBuffer == NULL) { /* not yet allocated */

      PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
					 "InitPackBuffer");

      InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
      AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
  }
}
#endif /* PAR */

static void
InitPacking(STG_NO_ARGS)
{
#if defined(GRAN)
  PackBuffer = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
                                            /* NB: free in UnpackGraph */
#endif

  packlocn = PACK_HDR_SIZE;
  unpackedsize = 0;
  reservedPAsize = 0;
  RoomInBuffer = rtsTrue;
  InitClosureQueue();
#if defined(PAR)
  offsettable = allocHashTable();
#else
  packed_thunks = 0;                        
#endif
}
\end{code}

@DonePacking@ is called when we've finished packing.  It releases memory
etc.

\begin{code}
#if defined(PAR)

static void
DonePacking(STG_NO_ARGS)
{
  freeHashTable(offsettable,NULL);
  offsettable = NULL;
}
\end{code}

@AmPacking@ records that the closure is being packed.  Note the abuse
of the data field in the hash table -- this saves calling @malloc@!

\begin{code}
static void
AmPacking(closure)
P_ closure;
{
#ifdef PACK_DEBUG
    fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n", 
      closure, INFO_PTR(closure), packlocn);
#endif
    insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
}
\end{code}

@OffsetFor@ returns an offset for a closure which is already being
packed.

\begin{code}
static int
OffsetFor(P_ closure)
{
    return (int) (W_) lookupHashTable(offsettable, (W_) closure);
}
\end{code}

@NotYetPacking@ determines whether the closure's already being packed.
Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.

\begin{code}
static rtsBool
NotYetPacking(offset)
int offset;
{
  return(offset < PACK_HDR_SIZE);
}

#else  /* GRAN */

static rtsBool
NotYetPacking(closure)
P_ closure;
{ int i;
  rtsBool found = rtsFalse;

  for (i=PACK_HDR_SIZE; (i<packlocn) && !found; i++)
    found = PackBuffer[i]==closure;

  return (!found);
}
#endif
\end{code}

@RoomToPack@ determines whether there's room to pack the closure into
the pack buffer based on 

o how full the buffer is already,
o the closures' size and number of pointers (which must be packed as GAs),
o the size and number of pointers held by any primitive arrays that it points to

It has a *side-effect* in assigning RoomInBuffer to False.

\begin{code}
static rtsBool
RoomToPack(size, ptrs)
W_ size, ptrs;
{
#if defined(PAR)
    if (RoomInBuffer &&
      (packlocn + reservedPAsize + size +
	((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
    {
#ifdef PACK_DEBUG
	fprintf(stderr, "Buffer full\n");
#endif
	RoomInBuffer = rtsFalse;
    }
#else   /* GRAN */
    if (RoomInBuffer &&
        (unpackedsize + reservedPAsize + size +
	((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
    {
#if defined(GRAN_CHECK)
    if ( RTSflags.GranFlags.debug & 0x100 ) 
	fprintf(stderr, "Buffer full\n");
#endif
	RoomInBuffer = rtsFalse;
    }
#endif
    return (RoomInBuffer);
}
\end{code}

%************************************************************************
%*                                                                      *
\subsection[pack-closure-queue]{Closure Queues}
%*									*
%************************************************************************

These routines manage the closure queue.

\begin{code}
static W_ clqpos, clqsize;

static P_ *ClosureQueue = NULL;   /* HWL: init in main */
\end{code}

@InitClosureQueue@ initialises the closure queue.

\begin{code}
void
AllocClosureQueue(size)
  W_ size;
{
  ASSERT(ClosureQueue == NULL);
  ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
}

void
InitClosureQueue(STG_NO_ARGS)
{
  clqpos = clqsize = 0;

  if ( ClosureQueue == NULL ) 
     AllocClosureQueue(PACK_BUFFER_SIZE);
}
\end{code}

@QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
@rtsFalse@ otherwise.

\begin{code}
rtsBool
QueueEmpty(STG_NO_ARGS)
{
  return(clqpos >= clqsize);
}
\end{code}

@QueueClosure@ adds its argument to the closure queue.

\begin{code}
void
QueueClosure(closure)
P_ closure;
{
  if(clqsize < PACK_BUFFER_SIZE )
    ClosureQueue[clqsize++] = closure;
  else
    {
      fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
      EXIT(EXIT_FAILURE);
    }
}
\end{code}

@DeQueueClosure@ returns the head of the closure queue.

\begin{code}
P_ 
DeQueueClosure(STG_NO_ARGS)
{
  if(!QueueEmpty())
    return(ClosureQueue[clqpos++]);
  else
    return(NULL);
}
\end{code}

%************************************************************************
%*                                                                      *
\subsection[pack-ga-types]{Types of Global Addresses}
%*									*
%************************************************************************

These routines determine whether a GA is one of a number of special types
of GA.

\begin{code}
#if defined(PAR)
rtsBool
isOffset(ga)
globalAddr *ga;
{
    return (ga->weight == 1 && ga->loc.gc.gtid == 0);
}

rtsBool
isFixed(ga)
globalAddr *ga;
{
    return (ga->weight == 0);
}
#endif
\end{code}

%************************************************************************
%*                                                                      *
\subsection[pack-print-packet]{Printing Packet Contents}
%*									*
%************************************************************************

\begin{code}
#if defined(DEBUG) || defined(GRAN_CHECK)

#if defined(PAR)
void
PrintPacket(buffer)
P_ buffer;
{
    W_ size, ptrs, nonptrs, vhs;
    char str[80];

    globalAddr ga;

    W_ bufsize;
    P_ parent;
    W_ pptr = 0, pptrs = 0, pvhs;

    W_ unpacklocn = PACK_HDR_SIZE;
    W_ gastart = unpacklocn;
    W_ closurestart = unpacklocn;

    P_ info;

    int i;

    InitClosureQueue();

    /* Unpack the header */
    bufsize = buffer[0];

    fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);

    do {
	gastart = unpacklocn;
	ga.weight = buffer[unpacklocn++];
	if (ga.weight > 0) {
	    ga.loc.gc.gtid = buffer[unpacklocn++];
	    ga.loc.gc.slot = buffer[unpacklocn++];
	} else 
	    ga.loc.plc = (P_) buffer[unpacklocn++];
	closurestart = unpacklocn;

	if (isFixed(&ga)) {
	    fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
	} else if (isOffset(&ga)) {
	    fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
	}
	/* Print normal closures */
	else {
	    fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart, 
              ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);

	    info = get_closure_info((P_) (buffer + closurestart), &size,
	                            &ptrs, &nonptrs, &vhs, str);

            if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
	      size = ptrs = nonptrs = vhs = 0;

	    if (IS_THUNK(info)) {
		if (IS_UPDATABLE(info))
		    fputs("SHARED ", stderr);
		else
		    fputs("UNSHARED ", stderr);
	    } 
            if (IS_BLACK_HOLE(info)) {
		fputs("BLACK HOLE\n", stderr);
	    } else {
		/* Fixed header */
		fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
		for (i = 1; i < FIXED_HS; i++)
		    fprintf(stderr, " %#lx", buffer[unpacklocn++]);

		/* Variable header */
		if (vhs > 0) {
		    fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);

		    for (i = 1; i < vhs; i++)
			fprintf(stderr, " %#lx", buffer[unpacklocn++]);
		}

		fprintf(stderr, "] PTRS %u", ptrs);

		/* Non-pointers */
		if (nonptrs > 0) {
		    fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
		
		    for (i = 1; i < nonptrs; i++)
			fprintf(stderr, " %#lx", buffer[unpacklocn++]);

		    putc(']', stderr);
		}
		putc('\n', stderr);
	    }

	    /* Add to queue for processing */
	    QueueClosure((P_) (buffer + closurestart));
	}

	/* Locate next parent pointer */
	pptr++;
	while (pptr + 1 > pptrs) {
	    parent = DeQueueClosure();

	    if (parent == NULL)
		break;
	    else {
		(void) get_closure_info(parent, &size, &pptrs, &nonptrs,
		                        &pvhs, str);
		pptr = 0;
	    }
	}
    } while (parent != NULL);

    fprintf(stderr, "--- End ---\n\n");
}
#else  /* GRAN */
void
PrintPacket(buffer)
P_ buffer;
{
    extern char *info_hdr_type(P_ infoptr);  /* defined in Threads.lc */
    extern char *info_type(P_ infoptr);      /* defined in Threads.lc */

    char str1[80], str2[80], junk_str[80];

    W_ size, ptrs, nonptrs, vhs;

    /* globalAddr ga; */

    W_ bufsize, unpackedsize ;
    P_ parent;
    W_ pptr = 0, pptrs = 0, pvhs;

    W_ unpacklocn = PACK_HDR_SIZE;
    W_ gastart = unpacklocn;
    W_ closurestart = unpacklocn;

    P_ info, tso;
    P_ closure;

    int i;

    InitClosureQueue();

#    if defined(GRAN) && defined(GRAN_CHECK)
    if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
      fprintf(stderr,"Packet @ 0x%lx hs no flag : 0x%lx\n",
	      buffer, buffer[PACK_FLAG_LOCN]);
      EXIT(EXIT_FAILURE);
    }
#    endif

    tso = (P_) buffer[PACK_TSO_LOCN];

    /* Unpack the header */
    unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
    bufsize = buffer[PACK_SIZE_LOCN];

    fprintf(stderr, "Packed Packet %#lx, size %u (unpacked size is %u); demanded by TSO %#lx (%d)(PE %d)\n--- Begin ---\n", 
	            buffer, bufsize, unpackedsize, tso, TSO_ID(tso), where_is(tso));

    do {
	closurestart = unpacklocn;
	closure = (P_) buffer[unpacklocn++];
	
	fprintf(stderr, "[%u]: (%#lx) ", closurestart, closure);

	info = get_closure_info((P_) (closure), 
				         &size, &ptrs, &nonptrs, &vhs,str1);
	strcpy(str2,info_type(info));
	fprintf(stderr, "(%s|%s) ", str1, str2);
	
        if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
	  size = ptrs = nonptrs = vhs = 0;
	
	if (IS_THUNK(info)) {
		if (IS_UPDATABLE(info))
		    fputs("SHARED ", stderr);
		else
		    fputs("UNSHARED ", stderr);
	} 
        if (IS_BLACK_HOLE(info)) {
		fputs("BLACK HOLE\n", stderr);
	} else {
		/* Fixed header */
		fprintf(stderr, "FH [%#lx", closure[0]);
		for (i = 1; i < FIXED_HS; i++)
		    fprintf(stderr, " %#lx", closure[i]);
	
		/* Variable header */
		if (vhs > 0) {
		    fprintf(stderr, "] VH [%#lx", closure[FIXED_HS]);
	
		    for (i = 1; i < vhs; i++)
			fprintf(stderr, " %#lx", closure[FIXED_HS+i]);
		}
	
		fprintf(stderr, "] PTRS %u", ptrs);
	
		/* Non-pointers */
		if (nonptrs > 0) {
		    fprintf(stderr, " NPTRS [%#lx", closure[FIXED_HS+vhs]);
		
		    for (i = 1; i < nonptrs; i++)
			fprintf(stderr, " %#lx", closure[FIXED_HS+vhs+i]);
	
		    putc(']', stderr);
		}
		putc('\n', stderr);
	}
    } while (unpacklocn<bufsize) ;  /* (parent != NULL); */

    fprintf(stderr, "--- End ---\n\n");
}
#endif /* PAR */
#endif /* DEBUG || GRAN_CHECK */
\end{code}

%************************************************************************
%*                                                                      *
\subsection[pack-get-closure-info]{Closure Info}
%*									*
%************************************************************************

@get_closure_info@ determines the size, number of pointers etc. for this
type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.

[Can someone please keep this function up to date.  I keep needing it
 (or something similar) for interpretive code, and it keeps
 bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95]

\begin{code}
P_
get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
P_ closure;
W_ *size, *ptrs, *nonptrs, *vhs;
char *type;
{
   P_ ip = (P_) INFO_PTR(closure);

   if (closure==NULL) {
     fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
     *size = *ptrs = *nonptrs = *vhs = 0; 
     strcpy(type,"ERROR in get_closure_info");
     return;
   } else if (closure==Prelude_Z91Z93_closure) {
     /* fprintf(stderr, "Qagh {get_closure_info}Daq: Prelude_Z91Z93_closure closure\n"); */
     *size = *ptrs = *nonptrs = *vhs = 0; 
     strcpy(type,"Prelude_Z91Z93_closure");
     return;
   };

    ip = (P_) INFO_PTR(closure);

    switch (INFO_TYPE(ip)) {
    case INFO_SPEC_U_TYPE:
    case INFO_SPEC_S_TYPE:
    case INFO_SPEC_N_TYPE:
	*size = SPEC_CLOSURE_SIZE(closure);
	*ptrs = SPEC_CLOSURE_NoPTRS(closure);
	*nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
	*vhs = 0 /*SPEC_VHS*/;
	strcpy(type,"SPEC");
	break;

    case INFO_GEN_U_TYPE:
    case INFO_GEN_S_TYPE:
    case INFO_GEN_N_TYPE:
	*size = GEN_CLOSURE_SIZE(closure);
	*ptrs = GEN_CLOSURE_NoPTRS(closure);
	*nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
	*vhs = GEN_VHS;
	strcpy(type,"GEN");
	break;

    case INFO_DYN_TYPE:
	*size = DYN_CLOSURE_SIZE(closure);
	*ptrs = DYN_CLOSURE_NoPTRS(closure);
	*nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
	*vhs = DYN_VHS;
	strcpy(type,"DYN");
	break;

    case INFO_TUPLE_TYPE:
	*size = TUPLE_CLOSURE_SIZE(closure);
	*ptrs = TUPLE_CLOSURE_NoPTRS(closure);
	*nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
	*vhs = TUPLE_VHS;
	strcpy(type,"TUPLE");
	break;

    case INFO_DATA_TYPE:
	*size = DATA_CLOSURE_SIZE(closure);
	*ptrs = DATA_CLOSURE_NoPTRS(closure);
	*nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
	*vhs = DATA_VHS;
	strcpy(type,"DATA");
	break;

    case INFO_IMMUTUPLE_TYPE:
    case INFO_MUTUPLE_TYPE:
	*size = MUTUPLE_CLOSURE_SIZE(closure);
	*ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
	*nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
	*vhs = MUTUPLE_VHS;
	strcpy(type,"(IM)MUTUPLE");
	break;

    case INFO_STATIC_TYPE:
	*size = STATIC_CLOSURE_SIZE(closure);
	*ptrs = STATIC_CLOSURE_NoPTRS(closure);
	*nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
	*vhs = STATIC_VHS;
	strcpy(type,"STATIC");
	break;

    case INFO_CAF_TYPE:
    case INFO_IND_TYPE:
	*size = IND_CLOSURE_SIZE(closure);
	*ptrs = IND_CLOSURE_NoPTRS(closure);
	*nonptrs = IND_CLOSURE_NoNONPTRS(closure);
	*vhs = IND_VHS;
	strcpy(type,"CAF|IND");
	break;

    case INFO_CONST_TYPE:
	*size = CONST_CLOSURE_SIZE(closure);
	*ptrs = CONST_CLOSURE_NoPTRS(closure);
	*nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
	*vhs = CONST_VHS;
	strcpy(type,"CONST");
	break;

    case INFO_SPEC_RBH_TYPE:
	*size = SPEC_RBH_CLOSURE_SIZE(closure);
	*ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
	*nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
	if (*ptrs <= 2) {
	    *nonptrs -= (2 - *ptrs);
	    *ptrs = 1;
	} else
	    *ptrs -= 1;
	*vhs = SPEC_RBH_VHS;
	strcpy(type,"SPEC_RBH");
	break;

    case INFO_GEN_RBH_TYPE:
	*size = GEN_RBH_CLOSURE_SIZE(closure);
	*ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
	*nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
	if (*ptrs <= 2) {
	    *nonptrs -= (2 - *ptrs);
	    *ptrs = 1;
	} else
	    *ptrs -= 1;
	*vhs = GEN_RBH_VHS;
	strcpy(type,"GEN_RBH");
	break;

    case INFO_CHARLIKE_TYPE:
	*size = CHARLIKE_CLOSURE_SIZE(closure);
	*ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
	*nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
	*vhs = CHARLIKE_VHS;
	strcpy(type,"CHARLIKE");
	break;

    case INFO_INTLIKE_TYPE:
	*size = INTLIKE_CLOSURE_SIZE(closure);
	*ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
	*nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
	*vhs = INTLIKE_VHS;
	strcpy(type,"INTLIKE");
	break;

#  if !defined(GRAN)
    case INFO_FETCHME_TYPE:
	*size = FETCHME_CLOSURE_SIZE(closure);
        *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
        *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
        *vhs = FETCHME_VHS;
	strcpy(type,"FETCHME");
	break;

    case INFO_FMBQ_TYPE:
	*size = FMBQ_CLOSURE_SIZE(closure);
        *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
        *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
        *vhs = FMBQ_VHS;
	strcpy(type,"FMBQ");
	break;
#  endif

    case INFO_BQ_TYPE:
	*size = BQ_CLOSURE_SIZE(closure);
        *ptrs = BQ_CLOSURE_NoPTRS(closure);
        *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
        *vhs = BQ_VHS;
	strcpy(type,"BQ");
	break;

    case INFO_BH_TYPE:
	*size = BH_CLOSURE_SIZE(closure);
        *ptrs = BH_CLOSURE_NoPTRS(closure);
        *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
        *vhs = BH_VHS;
	strcpy(type,"BH");
	break;

    case INFO_TSO_TYPE:
	*size = 0; /* TSO_CLOSURE_SIZE(closure); */
        *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
        *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
        *vhs = TSO_VHS;
	strcpy(type,"TSO");
	break;

    case INFO_STKO_TYPE:
        *size = 0;
    	*ptrs = 0;
        *nonptrs = 0;
    	*vhs = STKO_VHS;
    	strcpy(type,"STKO");
        break;

    default:
	fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
	  INFO_TYPE(ip), (W_) closure);
	EXIT(EXIT_FAILURE);
    }

    return ip;
}
\end{code}

@AllocateHeap@ will bump the heap pointer by @size@ words if the space
is available, but it will not perform garbage collection.

\begin{code}
P_
AllocateHeap(size)
W_ size;
{
    P_ newClosure;

    /* Allocate a new closure */
    if (SAVE_Hp + size > SAVE_HpLim)
	return NULL;

    newClosure = SAVE_Hp + 1;
    SAVE_Hp += size;

    return newClosure;
}

#if defined(PAR)

void
doGlobalGC(STG_NO_ARGS)
{
  fprintf(stderr,"Splat -- we just hit global GC!\n");
  EXIT(EXIT_FAILURE);
  fishing = rtsFalse;
}

#endif /* PAR */
\end{code}

\begin{code}
#endif /* PAR  || GRAN  -- whole file */
\end{code}