X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fruntime%2Fgum%2FPack.lc;fp=ghc%2Fruntime%2Fgum%2FPack.lc;h=0000000000000000000000000000000000000000;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=4a2e402eb46589a6446529845b1e03d33575c035;hpb=967cc47f37cb93a5e2b6df7822c9a646f0428247;p=ghc-hetmet.git diff --git a/ghc/runtime/gum/Pack.lc b/ghc/runtime/gum/Pack.lc deleted file mode 100644 index 4a2e402..0000000 --- a/ghc/runtime/gum/Pack.lc +++ /dev/null @@ -1,1510 +0,0 @@ -% -% (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= 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 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}