+++ /dev/null
-%
-% (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==PrelBase_Z91Z93_closure) {
- /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
- *size = *ptrs = *nonptrs = *vhs = 0;
- strcpy(type,"PrelBase_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}
projects / ghc-hetmet.git / blobdiff