2 Time-stamp: <Thu Mar 30 2000 22:53:32 Stardate: [-30]4584.56 hwloidl>
3 $Id: Pack.c,v 1.4 2000/03/31 03:09:37 hwloidl Exp $
5 Graph packing and unpacking code for sending it to another processor
6 and retrieving the original graph structure from the packet.
7 In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
8 Used in GUM and GrAnSim.
10 The GrAnSim version of the code defines routines for *simulating* the
11 packing of closures in the same way it is done in the parallel runtime
12 system. Basically GrAnSim only puts the addresses of the closures to be
13 transferred into a buffer. This buffer will then be associated with the
14 event of transferring the graph. When this event is scheduled, the
15 @UnpackGraph@ routine is called and the buffer can be discarded
18 Note that in GranSim we need many buffers, not just one per PE.
21 //@node Graph packing, , ,
22 //@section Graph packing
24 #if defined(PAR) || defined(GRAN) /* whole file */
29 //* Global variables::
30 //* ADT of Closure Queues::
31 //* Initialisation for packing::
32 //* Packing Functions::
33 //* Low level packing routines::
34 //* Unpacking routines::
35 //* Aux fcts for packing::
36 //* Printing Packet Contents::
41 //@node Includes, Prototypes, Graph packing, Graph packing
42 //@subsection Includes
47 #include "ClosureTypes.h"
51 #include "GranSimRts.h"
52 #include "ParallelRts.h"
54 # include "ParallelDebug.h"
58 /* Which RTS flag should be used to get the size of the pack buffer ? */
60 # define RTS_PACK_BUFFER_SIZE RtsFlags.ParFlags.packBufferSize
62 # define RTS_PACK_BUFFER_SIZE RtsFlags.GranFlags.packBufferSize
65 //@node Prototypes, Global variables, Includes, Graph packing
66 //@subsection Prototypes
71 //@node ADT of closure queues, Init for packing, Prototypes, Prototypes
72 //@subsubsection ADT of closure queues
74 static inline void InitClosureQueue(void);
75 static inline rtsBool QueueEmpty(void);
76 static inline void QueueClosure(StgClosure *closure);
77 static inline StgClosure *DeQueueClosure(void);
79 //@node Init for packing, Packing routines, ADT of closure queues, Prototypes
80 //@subsubsection Init for packing
82 static void InitPacking(rtsBool unpack);
84 rtsBool InitPackBuffer(void);
86 rtsPackBuffer *InstantiatePackBuffer (void);
87 static void reallocPackBuffer (void);
90 //@node Packing routines, Low level packing fcts, Init for packing, Prototypes
91 //@subsubsection Packing routines
93 static void PackClosure (StgClosure *closure);
95 //@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
96 //@subsubsection Low level packing fcts
99 static void Pack (StgClosure *data);
101 static void Pack (StgWord data);
103 static void PackGeneric(StgClosure *closure);
104 static void PackArray(StgClosure *closure);
105 static void PackPLC (StgPtr addr);
106 static void PackOffset (int offset);
107 static void PackPAP(StgPAP *pap);
108 static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
109 static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
110 static void PackFetchMe(StgClosure *closure);
112 static void GlobaliseAndPackGA (StgClosure *closure);
115 //@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
116 //@subsubsection Unpacking routines
119 void InitPendingGABuffer(nat size);
120 void CommonUp(StgClosure *src, StgClosure *dst);
121 static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure,
123 static nat FillInClosure(StgWord ***bufptrP, StgClosure *graph);
124 static void LocateNextParent(StgClosure **parentP,
125 nat *pptrP, nat *pptrsP, nat *sizeP);
126 StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
129 static StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP,
131 static StgWord **UnpackGA(StgWord **bufptr, globalAddr *ga);
132 static StgClosure *UnpackOffset(globalAddr *ga);
133 static StgClosure *UnpackPLC(globalAddr *ga);
134 static void UnpackArray(StgWord ***bufptrP, StgClosure *graph);
135 static nat UnpackPAP(StgWord ***bufptrP, StgClosure *graph);
138 void CommonUp(StgClosure *src, StgClosure *dst);
139 StgClosure *UnpackGraph(rtsPackBuffer* buffer);
142 //@node Aux fcts for packing, , Unpacking routines, Prototypes
143 //@subsubsection Aux fcts for packing
146 static void DonePacking(void);
147 static void AmPacking(StgClosure *closure);
148 static int OffsetFor(StgClosure *closure);
149 static rtsBool NotYetPacking(int offset);
150 static rtsBool RoomToPack (nat size, nat ptrs);
151 rtsBool isOffset(globalAddr *ga);
152 rtsBool isFixed(globalAddr *ga);
153 rtsBool isConstr(globalAddr *ga);
155 static void DonePacking(void);
156 static rtsBool NotYetPacking(StgClosure *closure);
159 //@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
160 //@subsection Global variables
162 Static data declarations
165 static nat pack_locn, /* ptr to first free loc in pack buffer */
167 buf_id = 1; /* identifier for buffer */
168 static nat unpacked_size;
169 static rtsBool roomInBuffer;
173 To be pedantic: in GrAnSim we're packing *addresses* of closures,
174 not the closures themselves.
176 static rtsPackBuffer *globalPackBuffer = NULL, /* for packing a graph */
177 *globalUnpackBuffer = NULL; /* for unpacking a graph */
181 Bit of a hack for testing if a closure is the root of the graph. This is
182 set in @PackNearbyGraph@ and tested in @PackClosure@.
185 static nat packed_thunks = 0;
186 static StgClosure *graph_root;
190 The offset hash table is used during packing to record the location in
191 the pack buffer of each closure which is packed.
193 //@cindex offsetTable
194 static HashTable *offsetTable;
196 //@cindex PendingGABuffer
197 static globalAddr *PendingGABuffer, *gaga;
202 //@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
203 //@subsection ADT of Closure Queues
211 //@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
212 //@subsubsection Closure Queues
216 These routines manage the closure queue.
219 static nat clq_pos, clq_size;
221 static StgClosure **ClosureQueue = NULL; /* HWL: init in main */
223 //@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
224 //@subsubsection Init routines
226 /* @InitClosureQueue@ allocates and initialises the closure queue. */
228 //@cindex InitClosureQueue
230 InitClosureQueue(void)
232 clq_pos = clq_size = 0;
234 if (ClosureQueue==NULL)
235 ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE,
239 //@node Basic routines, , Init routines, ADT of Closure Queues
240 //@subsubsection Basic routines
243 QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
247 static inline rtsBool
250 return(clq_pos >= clq_size);
253 /* QueueClosure adds its argument to the closure queue. */
255 //@cindex QueueClosure
257 QueueClosure(closure)
260 if(clq_size < RTS_PACK_BUFFER_SIZE )
261 ClosureQueue[clq_size++] = closure;
263 barf("Closure Queue Overflow (EnQueueing %p (%s))",
264 closure, info_type(closure));
267 /* DeQueueClosure returns the head of the closure queue. */
269 //@cindex DeQueueClosure
270 static inline StgClosure *
274 return(ClosureQueue[clq_pos++]);
276 return((StgClosure*)NULL);
279 /* DeQueueClosure returns the head of the closure queue. */
281 //@cindex DeQueueClosure
282 static inline StgClosure *
283 PrintQueueClosure(void)
287 fputs("Closure queue:", stderr);
288 for (i=clq_pos; i < clq_size; i++)
289 fprintf(stderr, "%p (%s), ",
290 ClosureQueue[clq_pos++], info_type(ClosureQueue[clq_pos++]));
294 //@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
295 //@subsection Initialisation for packing
297 Simple Packing Routines
299 About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
300 gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
301 words. In the simulated PackBuffer we only keep the addresses of the
302 closures that would be packed in the parallel system (see Pack). To
303 decide if a packet overflow occurs pack_buffer_size must be compared
304 versus unpacked_size (see RoomToPack). Currently, there is no multi
305 packet strategy implemented, so in the case of an overflow we just stop
306 adding closures to the closure queue. If an overflow of the simulated
307 packet occurs, we just realloc some more space for it and carry on as
313 InstantiatePackBuffer (void) {
314 extern rtsPackBuffer *globalPackBuffer;
316 globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
317 "InstantiatePackBuffer: failed to alloc packBuffer");
318 globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
319 globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
320 "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
321 /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
322 /* stgMallocWords is now simple allocate in Storage.c */
324 return (globalPackBuffer);
328 Reallocate the GranSim internal pack buffer to make room for more closure
329 pointers. This is independent of the check for packet overflow as in GUM
332 reallocPackBuffer (void) {
334 ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
336 IF_GRAN_DEBUG(packBuffer,
337 belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
338 globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
339 CurrentProc, CurrentTime[CurrentProc]));
341 globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer,
342 sizeof(StgClosure*)*(REALLOC_SZ +
343 (int)globalPackBuffer->size +
344 sizeofW(rtsPackBuffer))) ;
345 if (globalPackBuffer==(rtsPackBuffer*)NULL)
346 barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n",
347 REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
349 globalPackBuffer->size += REALLOC_SZ;
351 ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
356 /* @initPacking@ initialises the packing buffer etc. */
357 //@cindex InitPackBuffer
361 if (globalPackBuffer==(rtsPackBuffer*)NULL) {
362 if ((globalPackBuffer = (rtsPackBuffer *)
363 stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize,
364 "InitPackBuffer")) == NULL)
371 //@cindex InitPacking
373 InitPacking(rtsBool unpack)
376 globalPackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
377 /* NB: free in UnpackGraph */
380 /* allocate a GA-to-GA map (needed for ACK message) */
381 InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
383 /* allocate memory to pack the graph into */
387 /* init queue of closures seen during packing */
393 globalPackBuffer->id = buf_id++; /* buffer id are only used for debugging! */
394 pack_locn = 0; /* the index into the actual pack buffer */
395 unpacked_size = 0; /* the size of the whole graph when unpacked */
396 roomInBuffer = rtsTrue;
397 packed_thunks = 0; /* total number of thunks packed so far */
399 offsetTable = allocHashTable();
403 //@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
404 //@subsection Packing Functions
407 //* Packing Sections of Nearby Graph::
408 //* Packing Closures::
411 //@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
412 //@subsubsection Packing Sections of Nearby Graph
414 Packing Sections of Nearby Graph
416 @PackNearbyGraph@ packs a closure and associated graph into a static
417 buffer (@PackBuffer@). It returns the address of this buffer and the
418 size of the data packed into the buffer (in its second parameter,
419 @packBufferSize@). The associated graph is packed in a depth first
420 manner, hence it uses an explicit queue of closures to be packed rather
421 than simply using a recursive algorithm. Once the packet is full,
422 closures (other than primitive arrays) are packed as FetchMes, and their
423 children are not queued for packing. */
425 //@cindex PackNearbyGraph
427 /* NB: this code is shared between GranSim and GUM;
428 tso only used in GranSim */
430 PackNearbyGraph(closure, tso, packBufferSize)
435 ASSERT(RTS_PACK_BUFFER_SIZE > 0);
437 /* ToDo: check that we have enough heap for the packet
439 if (Hp + PACK_HEAP_REQUIRED > HpLim)
443 InitPacking(rtsFalse);
445 graph_root = closure;
449 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n demanded by TSO %d (%p) [PE %u]",
450 globalPackBuffer->id, globalPackBuffer, closure, where_is(closure),
451 tso->id, tso, where_is((StgClosure*)tso)));
454 belch("** PrintGraph of %p is:", closure);
455 PrintGraph(closure,0));
458 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n demanded by TSO %d (%p)",
459 globalPackBuffer->id, globalPackBuffer, closure, mytid,
463 belch("** PrintGraph of %p is:", closure);
464 belch("** pack_locn=%d", pack_locn);
465 PrintGraph(closure,0));
467 QueueClosure(closure);
469 PackClosure(DeQueueClosure());
470 } while (!QueueEmpty());
474 /* Record how much space is needed to unpack the graph */
475 globalPackBuffer->tso = tso; // ToDo: check: used in GUM or only for debugging?
476 globalPackBuffer->unpacked_size = unpacked_size;
477 globalPackBuffer->size = pack_locn;
479 /* Set the size parameter */
480 ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize);
481 *packBufferSize = pack_locn;
485 /* Record how much space is needed to unpack the graph */
486 // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG; for testing
487 globalPackBuffer->tso = tso;
488 globalPackBuffer->unpacked_size = unpacked_size;
490 // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
491 /* ToDo: Print an earlier, more meaningful message */
492 if (pack_locn==0) /* i.e. packet is empty */
493 barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
495 globalPackBuffer->size = pack_locn;
496 *packBufferSize = pack_locn;
500 DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
504 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
505 globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
506 if (RtsFlags.GranFlags.GranSimStats.Global) {
507 globalGranStats.tot_packets++;
508 globalGranStats.tot_packet_size += pack_locn;
511 IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
514 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
515 globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size);
516 PrintPacket(globalPackBuffer));
518 IF_DEBUG(sanity, // do a sanity check on the packet just constructed
519 checkPacket(globalPackBuffer));
522 return (globalPackBuffer);
525 //@cindex PackOneNode
528 /* This version is used when the node is already local */
531 PackOneNode(closure, tso, packBufferSize)
536 extern rtsPackBuffer *globalPackBuffer;
539 InitPacking(rtsFalse);
542 belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
543 closure, info_type(closure),
544 where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
548 /* Record how much space is needed to unpack the graph */
549 globalPackBuffer->tso = tso;
550 globalPackBuffer->unpacked_size = unpacked_size;
552 /* Set the size parameter */
553 ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
554 globalPackBuffer->size = pack_locn;
555 *packBufferSize = pack_locn;
557 if (RtsFlags.GranFlags.GranSimStats.Global) {
558 globalGranStats.tot_packets++;
559 globalGranStats.tot_packet_size += pack_locn;
562 PrintPacket(globalPackBuffer));
564 return (globalPackBuffer);
571 PackTSO and PackStkO are entry points for two special kinds of closure
572 which are used in the parallel RTS. Compared with other closures they
573 are rather awkward to pack because they don't follow the normal closure
574 layout (where all pointers occur before all non-pointers). Luckily,
575 they're only needed when migrating threads between processors. */
579 PackTSO(tso, packBufferSize)
583 extern rtsPackBuffer *globalPackBuffer;
585 belch("** Packing TSO %d (%p)", tso->id, tso));
587 // PackBuffer[0] = PackBuffer[1] = 0; ???
588 return(globalPackBuffer);
592 static rtsPackBuffer*
593 PackStkO(stko, packBufferSize)
597 extern rtsPackBuffer *globalPackBuffer;
599 belch("** Packing STKO %p", stko));
601 // PackBuffer[0] = PackBuffer[1] = 0;
602 return(globalPackBuffer);
606 PackFetchMe(StgClosure *closure)
608 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
613 static rtsPackBuffer*
614 PackTSO(tso, packBufferSize)
618 barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
619 tso->id, tso, packBufferSize);
623 PackStkO(stko, packBufferSize)
627 barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
628 stko, packBufferSize);
631 //@cindex PackFetchMe
633 PackFetchMe(StgClosure *closure)
640 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
642 offset = OffsetFor(closure);
643 if (!NotYetPacking(offset)) {
645 belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
646 closure, info_type(closure), offset));
652 /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
654 GlobaliseAndPackGA(closure);
657 belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
658 closure, info_type(closure),
659 globalPackBuffer->buffer[pack_locn-2],
660 globalPackBuffer->buffer[pack_locn-1],
661 globalPackBuffer->buffer[pack_locn-3]));
663 /* Pack a FetchMe closure instead of closure */
665 /* this assumes that the info ptr is always the first word in a closure*/
667 for (i = 1; i < _HS; ++i) // pack rest of fixed header
668 Pack((StgWord)*(((StgPtr)closure)+i));
670 unpacked_size += PACK_FETCHME_SIZE;
676 //@node Packing Closures, , Packing Sections of Nearby Graph, Packing Functions
677 //@subsubsection Packing Closures
681 @PackClosure@ is the heart of the normal packing code. It packs a single
682 closure into the pack buffer, skipping over any indirections and
683 globalising it as necessary, queues any child pointers for further
684 packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
685 locally if it was a thunk. Before the actual closure is packed, a
686 suitable global address (GA) is inserted in the pack buffer. There is
687 always room to pack a fetch-me to the closure (guaranteed by the
688 RoomToPack calculation), and this is packed if there is no room for the
691 Space is allocated for any primitive array children of a closure, and
692 hence a primitive array can always be packed along with it's parent
695 //@cindex PackClosure
704 StgClosure *indirectee;
707 ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
709 closure = UNWIND_IND(closure);
710 /* now closure is the thing we want to pack */
711 info = get_itbl(closure);
713 clpack_locn = OffsetFor(closure);
715 /* If the closure has been packed already, just pack an indirection to it
716 to guarantee that the graph doesn't become a tree when unpacked */
717 if (!NotYetPacking(clpack_locn)) {
718 PackOffset(clpack_locn);
722 switch (info->type) {
724 case CONSTR_CHARLIKE:
726 belch("*>^^ Packing a charlike closure %d",
727 ((StgIntCharlikeClosure*)closure)->data));
729 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
734 StgInt val = ((StgIntCharlikeClosure*)closure)->data;
736 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
738 belch("*>^^ Packing a small intlike %d as a PLC", val));
739 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
743 belch("*>^^ Packing a big intlike %d as a normal closure",
745 PackGeneric(closure);
756 /* it's a constructor (i.e. plain data) */
758 belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
759 closure, info_type(closure)));
760 PackGeneric(closure);
763 case THUNK_STATIC: // ToDo: check whether that's ok
764 case FUN_STATIC: // ToDo: check whether that's ok
766 case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
767 // evaluated on each PE if needed
769 belch("*>~~ Packing a %p (%s) as a PLC",
770 closure, info_type(closure)));
772 PackPLC((StgPtr)closure);
777 StgClosure *selectee = ((StgSelector *)closure)->selectee;
780 belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
781 closure, info_type(closure),
782 selectee, info_type(selectee)));
783 PackGeneric(closure);
784 /* inlined code; probably could use PackGeneric
785 Pack((StgWord)(*(StgPtr)closure));
786 Pack((StgWord)(selectee));
787 QueueClosure(selectee);
805 PackGeneric(closure);
811 barf("*> Packing of PAP not implemented %p (%s)",
812 closure, info_type(closure));
814 Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
815 instead. Note that since PAPs contain a chunk of stack as payload,
816 implementing packing of PAPs is a first step towards thread migration.
818 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
819 closure, info_type(closure)));
820 PackFetchMe(closure);
822 PackPAP((StgPAP *)closure);
831 case SE_CAF_BLACKHOLE:
836 /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
837 //ASSERT(pack_locn > PACK_HDR_SIZE);
840 belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
841 closure, info_type(closure)));
842 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
843 phps short-cut the GA here */
844 PackFetchMe(closure);
848 barf("*> Pack: packing of MVARs not implemented",
849 closure, info_type(closure));
851 /* MVARs may not be copied; they are sticky objects in the new RTS */
852 /* therefore we treat them just as RBHs etc (what a great system!)
854 belch("** Found an MVar at %p (%s)",
855 closure, info_type(closure))); */
857 belch("*>.. Packing an MVAR at %p (%s) as a FETCH_ME",
858 closure, info_type(closure)));
859 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
860 phps short-cut the GA here */
861 PackFetchMe(closure);
869 case MUT_ARR_PTRS_FROZEN:
872 Eventually, this should use the same packing routine as ARR_WRODS
874 GlobaliseAndPackGA(closure);
878 barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
879 closure, info_type(closure));
883 barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
884 closure, info_type(closure));
887 // check error cases only in a debugging setup
894 barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
895 closure, info_type(closure));
902 barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
903 closure, info_type(closure));
909 /* something's very wrong */
910 barf("{Pack}Daq Qagh: found %s (%p) when packing",
911 info_type(closure), closure);
917 case IND_OLDGEN_PERM:
919 barf("Pack: found IND_... after shorting out indirections %d (%s)",
920 (nat)(info->type), info_type(closure));
925 barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
926 (nat)(info->type), info_type(closure));
930 barf("Pack: strange closure %d", (nat)(info->type));
935 Pack a constructor of unknown size.
936 Similar to PackGeneric but without creating GAs.
941 PackConstr(StgClosure *closure)
944 nat size, ptrs, nonptrs, vhs, i;
947 ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
949 /* get info about basic layout of the closure */
950 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
952 ASSERT(info->type == CONSTR ||
953 info->type == CONSTR_1_0 ||
954 info->type == CONSTR_0_1 ||
955 info->type == CONSTR_2_0 ||
956 info->type == CONSTR_1_1 ||
957 info->type == CONSTR_0_2);
960 fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
961 closure, info_type(closure), size, ptrs, nonptrs));
963 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
965 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
967 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
968 closure, info_type(closure)));
969 PackFetchMe(closure);
973 /* Record the location of the GA */
976 /* Pack Constructor marker */
979 /* pack fixed and variable header */
980 for (i = 0; i < _HS + vhs; ++i)
981 Pack((StgWord)*(((StgPtr)closure)+i));
983 /* register all ptrs for further packing */
984 for (i = 0; i < ptrs; ++i)
985 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
988 for (i = 0; i < nonptrs; ++i)
989 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
994 Generic packing code.
995 This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
997 //@cindex PackGeneric
999 PackGeneric(StgClosure *closure)
1003 nat size, ptrs, nonptrs, vhs, i, m;
1006 ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
1008 /* get info about basic layout of the closure */
1009 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1011 ASSERT(!IS_BLACK_HOLE(closure));
1014 fprintf(stderr, "*>== generic packing of %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1015 closure, info_type(closure), size, ptrs, nonptrs));
1017 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1019 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1021 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1022 closure, info_type(closure)));
1023 PackFetchMe(closure);
1027 /* Record the location of the GA */
1029 /* Allocate a GA for this closure and put it into the buffer */
1030 GlobaliseAndPackGA(closure);
1032 ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1033 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1035 /* At last! A closure we can actually pack! */
1036 if (ip_MUTABLE(info) && (info->type != FETCH_ME))
1037 barf("*>// PackClosure: trying to replicate a Mutable closure!");
1040 Remember, the generic closure layout is as follows:
1041 +-------------------------------------------------+
1042 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1043 +-------------------------------------------------+
1045 /* pack fixed and variable header */
1046 for (i = 0; i < _HS + vhs; ++i)
1047 Pack((StgWord)*(((StgPtr)closure)+i));
1049 /* register all ptrs for further packing */
1050 for (i = 0; i < ptrs; ++i)
1051 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1054 for (i = 0; i < nonptrs; ++i)
1055 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1057 // ASSERT(_HS+vhs+ptrs+nonptrs==size);
1058 if ((m=_HS+vhs+ptrs+nonptrs)<size) {
1060 belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
1061 closure, info_type(closure), size-m));
1062 for (i=m; i<size; i++)
1063 Pack((StgWord)*(((StgPtr)closure)+i));
1066 unpacked_size += size;
1067 // unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1070 * Record that this is a revertable black hole so that we can fill in
1071 * its address from the fetch reply. Problem: unshared thunks may cause
1072 * space leaks this way, their GAs should be deallocated following an
1076 // IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) !? HWL
1077 if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
1078 rbh = convertToRBH(closure);
1079 ASSERT(rbh == closure); // rbh at the same position (minced version)
1084 Pack an array of words.
1085 ToDo: implement packing of MUT_ARRAYs
1090 PackArray(StgClosure *closure)
1093 nat size, ptrs, nonptrs, vhs, i, n;
1097 /* we don't really need all that get_closure_info delivers; however, for
1098 debugging it's useful to have the stuff anyway */
1100 /* get info about basic layout of the closure */
1101 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1103 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1104 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
1106 /* record offset of the closure and allocate a GA */
1108 GlobaliseAndPackGA(closure);
1110 n = ((StgArrWords *)closure)->words;
1111 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
1114 belch("*>== packing an array of %d words %p (%s) (size=%d)\n",
1115 n, closure, info_type(closure),
1116 arr_words_sizeW((StgArrWords *)closure)));
1118 /* Pack the header (2 words: info ptr and the number of words to follow) */
1119 Pack((StgWord)*(StgPtr)closure);
1120 Pack(((StgArrWords *)closure)->words);
1122 /* pack the payload of the closure (all non-ptrs) */
1124 Pack((StgWord)((StgArrWords *)closure)->payload[i]);
1126 unpacked_size += arr_words_sizeW((StgArrWords *)closure);
1131 Note that the representation of a PAP in the buffer is different from
1132 its representation in the heap. In particular, pointers to local
1133 closures are packed directly as FETCHME closures, using
1134 PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
1135 structure. To account for the difference in size we store the packed
1136 size of the closure as part of the PAP's variable header in the buffer.
1141 PackPAP(StgPAP *pap) {
1142 nat m, n, i, j, pack_start;
1143 StgPtr p, q, end/*dbg*/;
1144 const StgInfoTable* info;
1146 /* debugging only */
1147 nat size, ptrs, nonptrs, vhs;
1150 /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
1151 ASSERT(PACK_FETCHME_SIZE == 1 + sizeofW(StgFetchMe));
1152 ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
1154 /* record offset of the closure and allocate a GA */
1155 AmPacking((StgClosure *)pap);
1156 GlobaliseAndPackGA((StgClosure *)pap);
1158 /* get info about basic layout of the closure */
1159 info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
1160 ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
1162 n = (nat)(pap->n_args);
1165 belch("*>** PackPAP: packing PAP @ %p with %d words (size=%d; ptrs=%d; nonptrs=%d:",
1166 (StgClosure *)pap, n, size, ptrs, nonptrs);
1167 printClosure((StgClosure *)pap));
1169 /* Pack the PAP header */
1170 Pack((StgWord)(pap->header.info));
1171 Pack((StgWord)(pap->n_args));
1172 Pack((StgWord)(pap->fun));
1173 pack_start = pack_locn; // to compute size of PAP in buffer
1174 Pack((StgWord)0); // this will be filled in later (size of PAP in buffer)
1176 /* Pack the payload of a PAP i.e. a stack chunk */
1177 /* pointers to start of stack chunk */
1178 p = (StgPtr)(pap->payload);
1179 end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
1181 /* the loop body has been borrowed from scavenge_stack */
1184 /* If we've got a tag, pack all words in that block */
1185 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
1186 nat m = ARG_TAG(q); // first word after this block
1188 belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
1190 for (i=0; i<m+1; i++)
1191 Pack((StgWord)*(p+i));
1192 p += m+1; // m words + the tag
1196 /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
1197 ToDo: provide RTS flag to also pack these closures
1199 if (! LOOKS_LIKE_GHC_INFO(q) ) {
1200 /* distinguish static closure (PLC) from other closures (FM) */
1201 switch (get_itbl((StgClosure*)q)->type) {
1202 case CONSTR_CHARLIKE:
1204 belch("*>** PackPAP: packing a charlike closure %d",
1205 ((StgIntCharlikeClosure*)q)->data));
1207 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
1211 case CONSTR_INTLIKE:
1213 StgInt val = ((StgIntCharlikeClosure*)q)->data;
1215 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
1217 belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1218 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1223 belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
1225 Pack((StgWord)(ARGTAG_MAX+1));
1226 PackFetchMe((StgClosure *)q);
1231 case THUNK_STATIC: // ToDo: check whether that's ok
1232 case FUN_STATIC: // ToDo: check whether that's ok
1234 case CONSTR_NOCAF_STATIC:
1237 belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
1238 q, info_type((StgClosure *)q)));
1246 belch("*>** PackPAP @ %p: packing FM to %p (%s)",
1247 p, q, info_type((StgClosure*)q)));
1248 Pack((StgWord)(ARGTAG_MAX+1));
1249 PackFetchMe((StgClosure *)q);
1257 * Otherwise, q must be the info pointer of an activation
1258 * record. All activation records have 'bitmap' style layout
1261 info = get_itbl((StgClosure *)p);
1262 switch (info->type) {
1264 /* Dynamic bitmap: the mask is stored on the stack */
1267 belch("*>** PackPAP @ %p: RET_DYN",
1270 /* Pack the header as is */
1271 Pack((StgWord)(((StgRetDyn *)p)->info));
1272 Pack((StgWord)(((StgRetDyn *)p)->liveness));
1273 Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
1275 bitmap = ((StgRetDyn *)p)->liveness;
1276 p = (P_)&((StgRetDyn *)p)->payload[0];
1279 /* probably a slow-entry point return address: */
1284 belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
1287 Pack((StgWord)(((StgClosure *)p)->header.info));
1290 goto follow_srt; //??
1293 /* Using generic code here; could inline as in scavenge_stack */
1296 StgUpdateFrame *frame = (StgUpdateFrame *)p;
1297 nat type = get_itbl(frame->updatee)->type;
1299 ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
1302 belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
1303 p, frame->updatee, frame->link));
1305 Pack((StgWord)(frame->header.info));
1306 Pack((StgWord)(frame->link)); // ToDo: fix intra-stack pointer
1307 Pack((StgWord)(frame->updatee)); // ToDo: follow link
1312 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1316 belch("*>** PackPAP @ %p: STOP_FRAME",
1318 Pack((StgWord)((StgStopFrame *)p)->header.info);
1325 belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
1326 p, ((StgCatchFrame *)p)->handler));
1328 Pack((StgWord)((StgCatchFrame *)p)->header.info);
1329 Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
1330 Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
1331 Pack((StgWord)((StgCatchFrame *)p)->handler);
1338 belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
1339 p, ((StgSeqFrame *)p)->link));
1341 Pack((StgWord)((StgSeqFrame *)p)->header.info);
1342 Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
1344 // ToDo: handle bitmap
1345 bitmap = info->layout.bitmap;
1347 p = (StgPtr)&(((StgClosure *)p)->payload);
1354 belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
1355 p, info->layout.bitmap));
1358 Pack((StgWord)((StgClosure *)p)->header.info);
1360 // ToDo: handle bitmap
1361 bitmap = info->layout.bitmap;
1362 /* this assumes that the payload starts immediately after the info-ptr */
1365 while (bitmap != 0) {
1366 if ((bitmap & 1) == 0) {
1367 Pack((StgWord)(ARGTAG_MAX+1));
1368 PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1370 Pack((StgWord)*p++);
1372 bitmap = bitmap >> 1;
1376 belch("*>-- PackPAP: nothing to do for follow_srt");
1379 /* large bitmap (> 32 entries) */
1384 StgLargeBitmap *large_bitmap;
1387 belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
1388 p, info->layout.large_bitmap));
1391 Pack((StgWord)((StgClosure *)p)->header.info);
1394 large_bitmap = info->layout.large_bitmap;
1396 for (j=0; j<large_bitmap->size; j++) {
1397 bitmap = large_bitmap->bitmap[j];
1398 q = p + sizeof(W_) * 8;
1399 while (bitmap != 0) {
1400 if ((bitmap & 1) == 0) {
1401 Pack((StgWord)(ARGTAG_MAX+1));
1402 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1404 Pack((StgWord)*p++);
1406 bitmap = bitmap >> 1;
1408 if (j+1 < large_bitmap->size) {
1410 Pack((StgWord)(ARGTAG_MAX+1));
1411 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1416 /* and don't forget to follow the SRT */
1421 barf("PackPAP: weird activation record found on stack (@ %p): %d",
1422 p, (int)(info->type));
1425 // fill in size of the PAP (only the payload!) in buffer
1426 globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1427 // add the size of the whole packed closure; this relies on the fact that
1428 // the size of the unpacked PAP + size of all unpacked FMs is the same as
1429 // the size of the packed PAP!!
1430 unpacked_size += sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
1434 /* Fake the packing of a closure */
1437 PackClosure(closure)
1438 StgClosure *closure;
1440 StgInfoTable *info, *childInfo;
1441 nat size, ptrs, nonptrs, vhs;
1442 char info_hdr_ty[80];
1444 StgClosure *indirectee, *rbh;
1446 rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
1448 is_mutable = rtsFalse;
1450 /* In GranSim we don't pack and unpack closures -- we just simulate
1451 packing by updating the bitmask. So, the graph structure is unchanged
1452 i.e. we don't short out indirections here. -- HWL */
1454 /* Nothing to do with packing but good place to (sanity) check closure;
1455 if the closure is a thunk, it must be unique; otherwise we have copied
1456 work at some point before that which violates one of our main global
1457 assertions in GranSim/GUM */
1458 ASSERT(!closure_THUNK(closure) || is_unique(closure));
1461 belch("** Packing closure %p (%s)",
1462 closure, info_type(closure)));
1464 if (where_is(closure) != where_is(graph_root)) {
1466 belch("** faking a FETCHME [current PE: %d, closure's PE: %d]",
1467 where_is(graph_root), where_is(closure)));
1469 /* GUM would pack a FETCHME here; simulate that by increasing the */
1470 /* unpacked size accordingly but don't pack anything -- HWL */
1471 unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
1475 /* If the closure's not already being packed */
1476 if (!NotYetPacking(closure))
1477 /* Don't have to do anything in GrAnSim if closure is already */
1481 belch("** Closure %p is already packed and omitted now!",
1486 switch (get_itbl(closure)->type) {
1487 /* ToDo: check for sticky bit here? */
1488 /* BH-like closures which must not be moved to another PE */
1489 case CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1490 case SE_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1491 case SE_CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1492 case BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1493 case BLACKHOLE_BQ: /* # of ptrs, nptrs: 1,1 */
1494 case RBH: /* # of ptrs, nptrs: 1,1 */
1495 /* same for these parallel specific closures */
1500 belch("** Avoid packing BH-like closures (%p, %s)!",
1501 closure, info_type(closure)));
1502 /* Just ignore RBHs i.e. they stay where they are */
1505 case THUNK_SELECTOR:
1507 StgClosure *selectee = ((StgSelector *)closure)->selectee;
1510 belch("** Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
1511 closure, info_type(closure), selectee, info_type(selectee)));
1512 QueueClosure(selectee);
1514 belch("** [%p (%s) (Queueing closure) ....]",
1515 selectee, info_type(selectee)));
1520 case CONSTR_NOCAF_STATIC:
1521 /* For now we ship indirections to CAFs:
1522 * They are evaluated on each PE if needed */
1524 belch("** Nothing to pack for %p (%s)!",
1525 closure, info_type(closure)));
1526 // Pack(closure); GUM only
1529 case CONSTR_CHARLIKE:
1530 case CONSTR_INTLIKE:
1532 belch("** Nothing to pack for %s (%p)!",
1533 closure, info_type(closure)));
1534 // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1539 /* partial applications; special treatment necessary? */
1542 case CAF_UNENTERED: /* # of ptrs, nptrs: 1,3 */
1543 case CAF_ENTERED: /* # of ptrs, nptrs: 0,4 (allegedly bogus!!) */
1544 /* CAFs; special treatment necessary? */
1548 barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1549 closure, info_type(closure));
1554 case MUT_ARR_PTRS_FROZEN:
1555 /* Mutable objects; require special treatment to ship all data */
1556 is_mutable = rtsTrue;
1562 /* weak pointers and other FFI objects */
1563 barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1564 closure, info_type(closure));
1567 /* parallel objects */
1568 barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1569 closure, info_type(closure));
1572 /* Hugs objects (i.e. closures used by the interpreter) */
1573 barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1574 closure, info_type(closure));
1576 case IND: /* # of ptrs, nptrs: 1,0 */
1577 case IND_STATIC: /* # of ptrs, nptrs: 1,0 */
1578 case IND_PERM: /* # of ptrs, nptrs: 1,1 */
1579 case IND_OLDGEN: /* # of ptrs, nptrs: 1,1 */
1580 case IND_OLDGEN_PERM: /* # of ptrs, nptrs: 1,1 */
1581 /* we shouldn't find an indirection here, because we have shorted them
1582 out at the beginning of this functions already.
1586 barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1587 closure, info_type(closure));
1594 /* stack frames; should never be found when packing for now;
1595 once we support thread migration these have to be covered properly
1597 barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1598 closure, info_type(closure));
1606 /* vectored returns; should never be found when packing; */
1607 barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1608 closure, info_type(closure));
1610 case INVALID_OBJECT:
1611 barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1612 closure, info_type(closure));
1616 Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1617 a specialised version with wired in #ptr/#nptr info; currently
1618 we treat these specialised versions like the generic version)
1622 /* Otherwise it's not Fixed */
1624 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1625 will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1628 belch("** Info on closure %p (%s): size=%d; ptrs=%d",
1629 closure, info_type(closure),
1631 (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1633 // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1634 no_more_thunks_please =
1635 (RtsFlags.GranFlags.ThunksToPack>0) &&
1636 (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1639 should be covered by get_closure_info
1640 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1641 info->type == BLACKHOLE || info->type == RBH )
1642 size = ptrs = nonptrs = vhs = 0;
1644 /* Now peek ahead to see whether the closure has any primitive */
1645 /* array children */
1648 for (i = 0; i < ptrs; ++i) {
1650 W_ childSize, childPtrs, childNonPtrs, childVhs;
1652 childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
1653 &childSize, &childPtrs, &childNonPtrs,
1654 &childVhs, junk_str);
1655 if (IS_BIG_MOTHER(childInfo)) {
1656 reservedPAsize += PACK_GA_SIZE + FIXED_HS +
1657 childVhs + childNonPtrs +
1658 childPtrs * PACK_FETCHME_SIZE;
1659 PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
1660 PAptrs += childPtrs;
1664 /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1665 * is full and it isn't a primitive array. N.B. Primitive arrays are
1666 * always packed (because their parents index into them directly) */
1668 if (IS_BLACK_HOLE(closure))
1672 !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
1673 || IS_BIG_MOTHER(info)))
1677 /* At last! A closure we can actually pack! */
1679 if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1680 belch("ghuH: Replicated a Mutable closure!");
1682 if (RtsFlags.GranFlags.GranSimStats.Global &&
1683 no_more_thunks_please && will_be_rbh) {
1684 globalGranStats.tot_cuts++;
1685 if ( RtsFlags.GranFlags.Debug.pack )
1686 belch("** PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1687 RtsFlags.GranFlags.ThunksToPack, closure);
1688 } else if (will_be_rbh || (closure==graph_root) ) {
1690 globalGranStats.tot_thunks++;
1693 if (no_more_thunks_please && will_be_rbh)
1694 return; /* don't pack anything */
1696 /* actual PACKING done here -- HWL */
1698 for (i = 0; i < ptrs; ++i) {
1699 /* extract i-th pointer from closure */
1700 QueueClosure((StgClosure *)(closure->payload[i]));
1702 belch("** [%p (%s) (Queueing closure) ....]",
1703 closure->payload[i], info_type(payloadPtr(closure,i))));
1707 for packing words (GUM only) do something like this:
1709 for (i = 0; i < ptrs; ++i) {
1710 Pack(payloadWord(obj,i+j));
1713 /* Turn thunk into a revertible black hole. */
1715 rbh = convertToRBH(closure);
1716 ASSERT(rbh != NULL);
1721 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1722 //@subsection Low level packing routines
1725 @Pack@ is the basic packing routine. It just writes a word of data into
1726 the pack buffer and increments the pack location. */
1735 ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1736 globalPackBuffer->buffer[pack_locn++] = data;
1743 StgClosure *closure;
1746 nat size, ptrs, nonptrs, vhs;
1749 /* This checks the size of the GrAnSim internal pack buffer. The simulated
1750 pack buffer is checked via RoomToPack (as in GUM) */
1751 if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
1752 reallocPackBuffer();
1754 if (closure==(StgClosure*)NULL)
1755 belch("Qagh {Pack}Daq: Trying to pack 0");
1756 globalPackBuffer->buffer[pack_locn++] = closure;
1757 /* ASSERT: Data is a closure in GrAnSim here */
1758 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1759 // ToDo: is check for MIN_UPD_SIZE really needed? */
1760 unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1767 If a closure is local, make it global. Then, divide its weight for
1768 export. The GA is then packed into the pack buffer. */
1771 //@cindex GlobaliseAndPackGA
1773 GlobaliseAndPackGA(closure)
1774 StgClosure *closure;
1779 if ((ga = LAGAlookup(closure)) == NULL)
1780 ga = makeGlobal(closure, rtsTrue);
1781 ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
1782 splitWeight(&packGA, ga);
1783 ASSERT(packGA.weight > 0);
1786 fprintf(stderr, "*>## Globalising closure %p (%s) with GA ",
1787 closure, info_type(closure));
1789 fputc('\n', stderr));
1792 Pack((StgWord) packGA.weight);
1793 Pack((StgWord) packGA.payload.gc.gtid);
1794 Pack((StgWord) packGA.payload.gc.slot);
1798 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
1799 address follows instead of PE, slot. */
1807 Pack(0L); /* weight */
1808 Pack((StgWord) addr); /* address */
1812 @PackOffset@ packs a special GA value that will be interpreted as an
1813 offset to a closure in the pack buffer. This is used to avoid unfolding
1814 the graph structure into a tree. */
1822 belch("** Packing Offset %d at pack location %u",
1823 offset, pack_locn));
1825 Pack(1L); /* weight */
1827 Pack(offset); /* slot/offset */
1831 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
1832 //@subsection Unpacking routines
1835 This was formerly in the (now deceased) module Unpack.c
1837 Unpacking closures which have been exported to remote processors
1839 This module defines routines for unpacking closures in the parallel
1840 runtime system (GUM).
1842 In the case of GrAnSim, this module defines routines for *simulating* the
1843 unpacking of closures as it is done in the parallel runtime system.
1846 //@node GUM code, Local Definitions, Unpacking routines, Unpacking routines
1847 //@subsubsection GUM code
1851 //@cindex InitPendingGABuffer
1853 InitPendingGABuffer(size)
1856 if (PendingGABuffer==(globalAddr *)NULL)
1857 PendingGABuffer = (globalAddr *)
1858 stgMallocBytes(size*2*sizeof(globalAddr),
1859 "InitPendingGABuffer");
1861 /* current location in the buffer */
1862 gaga = PendingGABuffer;
1866 @CommonUp@ commons up two closures which we have discovered to be
1867 variants of the same object. One is made an indirection to the other. */
1871 CommonUp(StgClosure *src, StgClosure *dst)
1873 StgBlockingQueueElement *bqe;
1875 ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
1879 belch("*___ CommonUp %p (%s) --> %p (%s)",
1880 src, info_type(src), dst, info_type(dst)));
1882 switch (get_itbl(src)->type) {
1884 bqe = ((StgBlockingQueue *)src)->blocking_queue;
1888 bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
1892 bqe = ((StgRBH *)src)->blocking_queue;
1900 /* currently we also common up 2 CONSTRs; this should reduce heap
1901 * consumption but also does more work; not sure whether it's worth doing
1911 case MUT_ARR_PTRS_FROZEN:
1916 /* Don't common up anything else */
1919 /* NB: this also awakens the blocking queue for src */
1921 // updateWithIndirection(src, dst);
1923 ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
1924 if (bqe != END_BQ_QUEUE)
1925 awakenBlockedQueue(bqe, src);
1930 * Common up the new closure with any existing closure having the same
1933 //@cindex SetGAandCommonUp
1935 SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
1937 StgClosure *existing;
1938 StgInfoTable *ip, *oldip;
1944 ip = get_itbl(closure);
1945 if ((existing = GALAlookup(ga)) == NULL) {
1946 /* Just keep the new object */
1948 belch("*<## Unpacking new GA ((%x, %d, %x))",
1949 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight));
1951 // make an entry binding closure to ga in the RemoteGA table
1952 newGA = setRemoteGA(closure, ga, rtsTrue);
1953 if (ip->type == FETCH_ME)
1954 ((StgFetchMe *)closure)->ga = newGA;
1956 /* Two closures, one global name. Someone loses */
1957 oldip = get_itbl(existing);
1958 if ((oldip->type == FETCH_ME ||
1959 /* If we pack GAs for CONSTRs we have to check for them, too */
1960 IS_BLACK_HOLE(existing)) &&
1961 ip->type != FETCH_ME)
1964 belch("*<#- Unpacking old GA ((%x, %d, %x)); redirecting %p -> %p",
1965 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
1966 existing, closure));
1969 * What we had wasn't worth keeping, so make the old closure an
1970 * indirection to the new closure (copying BQs if necessary) and
1971 * make sure that the old entry is not the preferred one for this
1974 CommonUp(existing, closure);
1975 //GALAdeprecate(ga);
1976 /* now ga indirectly refers to the new closure */
1977 ASSERT(UNWIND_IND(GALAlookup(ga))==closure);
1980 * Either we already had something worthwhile by this name or
1981 * the new thing is just another FetchMe. However, the thing we
1982 * just unpacked has to be left as-is, or the child unpacking
1983 * code will fail. Remember that the way pointer words are
1984 * filled in depends on the info pointers of the parents being
1985 * the same as when they were packed.
1988 belch("*<#@ Unpacking old GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
1989 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
1990 existing, info_type(existing), closure, info_type(closure)));
1995 ty = get_itbl(closure)->type;
2002 CommonUp(closure, graph);
2005 /* Pool the total weight in the stored ga */
2006 (void) addWeight(ga);
2009 /* ToDo: check this assertion!!
2010 if we have unpacked a FETCH_ME, we have a GA, too
2011 ASSERT(get_itbl(*closureP)->type!=FETCH_ME ||
2012 looks_like_ga(((StgFetchMe *)*closureP)->ga));
2014 /* Sort out the global address mapping */
2016 // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
2017 //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
2018 /* Make up new GAs for single-copy closures */
2019 globalAddr *newGA = makeGlobal(closure, rtsTrue);
2021 // It's a new GA and therefore has the full weight
2022 ASSERT(newGA->weight==0);
2024 /* Create an old GA to new GA mapping */
2026 splitWeight(gaga, newGA);
2027 /* inlined splitWeight; we know that newGALA has full weight
2028 newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
2029 gaga->payload = newGA->payload;
2031 ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
2038 Copies a segment of the buffer, starting at @bufptr@, representing a closure
2039 into the heap at @graph@.
2041 //@cindex FillInClosure
2043 FillInClosure(StgWord ***bufptrP, StgClosure *graph)
2046 StgWord **bufptr = *bufptrP;
2047 nat ptrs, nonptrs, vhs, i, size;
2050 ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
2053 * Close your eyes. You don't want to see where we're looking. You
2054 * can't get closure info until you've unpacked the variable header,
2055 * but you don't know how big it is until you've got closure info.
2056 * So...we trust that the closure in the buffer is organized the
2057 * same way as they will be in the heap...at least up through the
2058 * end of the variable header.
2060 ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2062 /* Make sure that nothing sans the fixed header is filled in
2063 The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
2064 if (ip->type == FETCH_ME) {
2065 ASSERT(size>=MIN_UPD_SIZE); // size of the FM in the heap
2066 ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
2068 /* ToDo: check whether this is really needed */
2069 if (ip->type == ARR_WORDS) {
2070 UnpackArray(bufptrP, graph);
2071 return arr_words_sizeW((StgArrWords *)bufptr);
2074 if (ip->type == PAP || ip->type == AP_UPD) {
2075 return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
2079 Remember, the generic closure layout is as follows:
2080 +-------------------------------------------------+
2081 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2082 +-------------------------------------------------+
2084 /* Fill in the fixed header */
2085 for (i = 0; i < _HS; i++)
2086 ((StgPtr)graph)[i] = (StgWord)*bufptr++;
2088 /* Fill in the packed variable header */
2089 for (i = 0; i < vhs; i++)
2090 ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
2092 /* Pointers will be filled in later */
2094 /* Fill in the packed non-pointers */
2095 for (i = 0; i < nonptrs; i++)
2096 ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
2098 /* Indirections are never packed */
2099 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2102 ASSERT((ip->type==FETCH_ME && sizeofW(StgFetchMe)==size) ||
2103 _HS+vhs+ptrs+nonptrs == size);
2108 Find the next pointer field in the parent closure.
2109 If the current parent has been completely unpacked already, get the
2110 next closure from the global closure queue.
2112 //@cindex LocateNextParent
2114 LocateNextParent(parentP, pptrP, pptrsP, sizeP)
2115 StgClosure **parentP;
2116 nat *pptrP, *pptrsP, *sizeP;
2118 StgInfoTable *ip; // debugging
2122 /* pptr as an index into the current parent; find the next pointer field
2123 in the parent by increasing pptr; if that takes us off the closure
2124 (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
2127 while (*pptrP + 1 > *pptrsP) {
2128 /* *parentP has been constructed (all pointer set); so check it now */
2130 if (*parentP!=(StgClosure*)NULL &&
2131 get_itbl(*parentP)->type != FETCH_ME)
2132 checkClosure(*parentP));
2134 *parentP = DeQueueClosure();
2136 if (*parentP == NULL)
2139 ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
2144 /* *parentP points to the new (or old) parent; */
2145 /* *pptr, *pptrs and *size have been updated referring to the new parent */
2149 UnpackClosure is the heart of the unpacking routine. It is called for
2150 every closure found in the packBuffer. Any prefix such as GA, PLC marker
2151 etc has been unpacked into the *ga structure.
2152 UnpackClosure does the following:
2153 - check for the kind of the closure (PLC, Offset, std closure)
2154 - copy the contents of the closure from the buffer into the heap
2155 - update LAGA tables (in particular if we end up with 2 closures
2156 having the same GA, we make one an indirection to the other)
2157 - set the GAGA map in order to send back an ACK message
2159 At the end of this function *graphP has been updated to point to the
2160 next free word in the heap for unpacking the rest of the graph and
2161 *bufptrP points to the next word in the pack buffer to be unpacked.
2165 UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
2166 StgClosure *closure;
2168 rtsBool hasGA = rtsFalse;
2170 /* Now unpack the closure body, if there is one; three cases:
2171 - PLC: closure is just a pointer to a static closure
2172 - Offset: closure has been unpacked already
2173 - else: copy data from packet into closure
2176 closure = UnpackPLC(ga);
2177 } else if (isOffset(ga)) {
2178 closure = UnpackOffset(ga);
2180 ASSERT(LOOKS_LIKE_GA(ga));
2181 /* Now we have to build something. */
2182 hasGA = !isConstr(ga);
2183 /* the new closure will be built here */
2186 /* fill in the closure from the buffer */
2187 size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
2189 /* Add to queue for processing */
2190 QueueClosure(closure);
2192 /* common up with other graph if necessary */
2193 closure = SetGAandCommonUp(ga, closure, hasGA);
2195 /* if we unpacked a THUNK, check that it is large enough to update */
2196 ASSERT(!closure_THUNK(closure) || size>=MIN_UPD_SIZE);
2197 /* graph shall point to next free word in the heap */
2199 //graph += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
2205 @UnpackGraph@ unpacks the graph contained in a message buffer. It
2206 returns a pointer to the new graph. The @gamap@ parameter is set to
2207 point to an array of (oldGA,newGA) pairs which were created as a result
2208 of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
2211 The format of graph in the pack buffer is as defined in @Pack.lc@. */
2213 //@cindex UnpackGraph
2215 UnpackGraph(packBuffer, gamap, nGAs)
2216 rtsPackBuffer *packBuffer;
2220 StgWord **bufptr, **slotptr;
2222 StgClosure *closure, *graphroot, *graph, *parent;
2223 nat size, heapsize, bufsize,
2224 pptr = 0, pptrs = 0, pvhs = 0;
2226 /* Initialisation */
2227 InitPacking(rtsTrue); // same as in PackNearbyGraph
2228 globalUnpackBuffer = packBuffer;
2230 IF_DEBUG(sanity, // do a sanity check on the incoming packet
2231 checkPacket(packBuffer));
2233 ASSERT(gaga==PendingGABuffer);
2234 graphroot = (StgClosure *)NULL;
2236 /* Unpack the header */
2237 bufsize = packBuffer->size;
2238 heapsize = packBuffer->unpacked_size;
2239 bufptr = packBuffer->buffer;
2243 graph = (StgClosure *)allocate(heapsize);
2244 ASSERT(graph != NULL);
2247 /* iterate over the buffer contents and unpack all closures */
2248 parent = (StgClosure *)NULL;
2250 /* This is where we will ultimately save the closure's address */
2253 /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
2254 bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
2256 /* this allocates heap space, updates LAGA tables etc */
2257 closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
2260 * Set parent pointer to point to chosen closure. If we're at the top of
2261 * the graph (our parent is NULL), then we want to arrange to return the
2262 * chosen closure to our caller (possibly in place of the allocated graph
2266 graphroot = closure;
2268 ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
2270 /* Save closure pointer for resolving offsets */
2271 *slotptr = (StgWord) closure;
2273 /* Locate next parent pointer */
2274 LocateNextParent(&parent, &pptr, &pptrs, &size);
2277 gaS.weight = 0xdeadffff;
2278 gaS.payload.gc.gtid = 0xdead;
2279 gaS.payload.gc.slot = 0xdeadbeef;);
2280 } while (parent != NULL);
2282 /* we unpacked exactly as many words as there are in the buffer */
2283 ASSERT(bufsize == bufptr-(packBuffer->buffer) &&
2284 heapsize >= graph-graphroot); // should be ==
2286 *gamap = PendingGABuffer;
2287 *nGAs = (gaga - PendingGABuffer) / 2;
2289 IF_PAR_DEBUG(tables,
2290 belch("** LAGA table after unpacking closure %p:",
2294 /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
2295 ASSERT(graphroot!=NULL);
2301 /* check the unpacked graph */
2302 checkHeapChunk(graphroot,graph-sizeof(StgWord));
2304 // if we do sanity checks, then wipe the pack buffer after unpacking
2305 for (p=packBuffer->buffer; p<(packBuffer->buffer)+(packBuffer->size); )
2309 /* reset the global variable */
2310 globalUnpackBuffer = (rtsPackBuffer*)NULL;
2316 UnpackGA(StgWord **bufptr, globalAddr *ga)
2318 /* First, unpack the next GA or PLC */
2319 ga->weight = (rtsWeight) *bufptr++;
2321 if (ga->weight > 0) {
2322 ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
2323 ga->payload.gc.slot = (int) *bufptr++;
2325 ga->payload.plc = (StgPtr) *bufptr++;
2332 UnpackPLC(globalAddr *ga)
2334 /* No more to unpack; just set closure to local address */
2336 belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
2337 return ga->payload.plc;
2340 //@cindex UnpackOffset
2342 UnpackOffset(globalAddr *ga)
2344 /* globalUnpackBuffer is a global var init in UnpackGraph */
2345 ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
2346 /* No more to unpack; just set closure to cached address */
2348 belch("*<__ Unpacked indirection to %p (was offset %d)",
2349 (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
2350 ga->payload.gc.slot));
2351 return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
2355 Input: *bufptrP, *graphP ... ptrs to the pack buffer and into the heap.
2357 *bufptrP points to something that should be unpacked as a FETCH_ME:
2360 +-------------------------------
2362 +-------------------------------
2364 The first 3 words starting at *bufptrP are the GA address; the next
2365 word is the generic FM info ptr followed by the remaining FH (if any)
2366 The result after unpacking will be a FETCH_ME closure, pointed to by
2367 *graphP at the start of the fct;
2370 +------------------------+
2371 | FH of FM | ptr to a GA |
2372 +------------------------+
2374 The ptr field points into the RemoteGA table, which holds the actual GA.
2375 *bufptrP has been updated to point to the next word in the buffer.
2376 *graphP has been updated to point to the first free word at the end.
2380 UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
2381 StgClosure *closure, *foo;
2384 /* This fct relies on size of FM < size of FM in pack buffer */
2385 ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
2387 /* fill in gaS from buffer */
2388 *bufptrP = UnpackGA(*bufptrP, &gaS);
2389 /* might be an offset to a closure in the pack buffer */
2390 if (isOffset(&gaS)) {
2391 belch("*< UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
2392 gaS.payload.gc.slot, *bufptrP);
2394 closure = UnpackOffset(&gaS);
2395 /* return address of previously unpacked closure; leaves *graphP unchanged */
2399 /* we have a proper GA at hand */
2400 ASSERT(LOOKS_LIKE_GA(&gaS));
2404 barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
2405 *bufptrP, info_type(*bufptrP)));
2408 belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
2412 /* the next thing must be the IP to a FETCH_ME closure */
2413 ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
2416 /* fill in the closure from the buffer */
2417 FillInClosure(bufptrP, closure);
2419 /* the newly built closure is a FETCH_ME */
2420 ASSERT(get_itbl(closure)->type == FETCH_ME);
2422 /* common up with other graph if necessary
2423 this also assigns the contents of gaS to the ga field of the FM closure */
2424 foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
2426 ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
2429 belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
2430 *graphP, *graphP+sizeofW(StgFetchMe), closure);
2431 printClosure(closure));
2432 *graphP += sizeofW(StgFetchMe);
2437 Unpack an array of words.
2438 Could use generic unpack most of the time, but cleaner to separate it.
2439 ToDo: implement packing of MUT_ARRAYs
2442 //@cindex UnackArray
2444 UnpackArray(StgWord ***bufptrP, StgClosure *graph)
2447 StgWord **bufptr=*bufptrP;
2448 nat size, ptrs, nonptrs, vhs, i, n;
2451 /* yes, I know I am paranoid; but who's asking !? */
2453 info = get_closure_info((StgClosure*)bufptr,
2454 &size, &ptrs, &nonptrs, &vhs, str);
2455 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
2456 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
2458 n = ((StgArrWords *)bufptr)->words;
2459 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
2462 belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
2463 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2464 arr_words_sizeW((StgArrWords *)bufptr)));
2466 /* Unpack the header (2 words: info ptr and the number of words to follow) */
2467 ((StgArrWords *)graph)->header.info = *bufptr++; // assumes _HS==1; yuck!
2468 ((StgArrWords *)graph)->words = *bufptr++;
2470 /* unpack the payload of the closure (all non-ptrs) */
2472 ((StgArrWords *)graph)->payload[i] = *bufptr++;
2474 ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
2479 Unpack a PAP in the buffer into a heap closure.
2480 For each FETCHME we find in the packed PAP we have to unpack a separate
2481 FETCHME closure and insert a pointer to this closure into the PAP.
2482 We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
2483 Note that the size of a FETCHME in the buffer is exactly the same as
2484 the size of an unpacked FETCHME plus 1 word for the pointer to it.
2485 Therefore, we just allocate packed_size words in the heap for the unpacking.
2486 After this routine the heap starting from *graph looks like this:
2490 v PAP closure | FM area |
2491 +------------------------------------------------------------+
2492 | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
2493 +------------------------------------------------------------+
2495 where payload contains pointers to each of the unpacked FM_1, FM_2 ...
2496 The size of the PAP closure plus all FMs is _HS+2+packed_size.
2501 UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
2503 nat n, i, j, packed_size = 0;
2504 StgPtr p, q, end, payload_start, p_FMs;
2505 const StgInfoTable* info;
2507 StgWord **bufptr = *bufptrP;
2510 belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
2511 *bufptr, *(bufptr+1), graph));
2513 /* Unpack the PAP header (both fixed and variable) */
2514 ((StgPAP *)graph)->header.info = *bufptr++;
2515 n = ((StgPAP *)graph)->n_args = *bufptr++;
2516 ((StgPAP *)graph)->fun = *bufptr++;
2517 packed_size = *bufptr++;
2520 belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
2521 ((StgPAP *)graph)->header.info,
2522 ((StgPAP *)graph)->n_args,
2523 ((StgPAP *)graph)->fun,
2526 payload_start = bufptr;
2527 /* p points to the current word in the heap */
2528 p = ((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
2529 p_FMs = graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
2530 end = (StgPtr) payload_start+packed_size;
2532 The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
2533 FM area for unpacking all FETCHMEs encountered during unpacking.
2535 while (bufptr<end) {
2536 /* be sure that we don't write more than we allocated for this closure */
2537 ASSERT(p_FMs <= graph+_HS+2+packed_size);
2538 /* be sure that the unpacked PAP doesn't run into the FM area */
2539 ASSERT(p < graph+pap_sizeW((StgPAP*)graph));
2540 /* the loop body has been borrowed from scavenge_stack */
2541 q = *bufptr; // let q be the contents of the current pointer into the buffer
2543 /* Test whether the next thing is a FETCH_ME.
2544 In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
2546 if (q==(StgPtr)(ARGTAG_MAX+1)) {
2548 belch("*<** UnpackPAP @ %p: unpacking FM to %p",
2550 bufptr++; // skip ARGTAG_MAX+1 marker
2551 // Unpack a FM into the FM area after the PAP proper and insert pointer
2552 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2556 /* Test whether it is a PLC */
2557 if (q==(StgPtr)0) { // same as isFixed(q)
2559 belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
2561 bufptr++; // skip 0 marker
2566 /* If we've got a tag, pack all words in that block */
2567 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
2568 nat m = i+ARG_SIZE(q); // first word after this block
2570 belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
2572 for (i=0; i<m+1; i++)
2578 * Otherwise, q must be the info pointer of an activation
2579 * record. All activation records have 'bitmap' style layout
2582 info = get_itbl((StgClosure *)q);
2583 switch (info->type) {
2585 /* Dynamic bitmap: the mask is stored on the stack */
2588 belch("*<** UnpackPAP @ %p: RET_DYN",
2591 /* Pack the header as is */
2592 ((StgRetDyn *)p)->info = *bufptr++;
2593 ((StgRetDyn *)p)->liveness = *bufptr;
2594 ((StgRetDyn *)p)->ret_addr= *bufptr;
2596 //bitmap = ((StgRetDyn *)p)->liveness;
2597 //p = (P_)&((StgRetDyn *)p)->payload[0];
2600 /* probably a slow-entry point return address: */
2605 belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
2608 ((StgClosure *)p)->header.info = *bufptr;
2611 goto follow_srt; //??
2614 /* Using generic code here; could inline as in scavenge_stack */
2617 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2618 //nat type = get_itbl(frame->updatee)->type;
2620 //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
2623 belch("*<** UnackPAP @ %p: UPDATE_FRAME",
2626 ((StgUpdateFrame *)p)->header.info = *bufptr;
2627 ((StgUpdateFrame *)p)->link= *bufptr++; // ToDo: fix intra-stack pointer
2628 ((StgUpdateFrame *)p)->updatee = *bufptr; // ToDo: follow link
2633 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2637 belch("*<** UnpackPAP @ %p: STOP_FRAME",
2639 ((StgStopFrame *)p)->header.info = *bufptr;
2646 belch("*<** UnpackPAP @ %p: CATCH_FRAME",
2649 ((StgCatchFrame *)p)->header.info = *bufptr++;
2650 ((StgCatchFrame *)p)->link = *bufptr++;
2651 ((StgCatchFrame *)p)->exceptions_blocked = *bufptr++;
2652 ((StgCatchFrame *)p)->handler = *bufptr++;
2659 belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
2662 ((StgSeqFrame *)p)->header.info = *bufptr++;
2663 ((StgSeqFrame *)p)->link = *bufptr++;
2665 // ToDo: handle bitmap
2666 bitmap = info->layout.bitmap;
2668 p = (StgPtr)&(((StgClosure *)p)->payload);
2675 belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
2679 ((StgClosure *)p)->header.info = *bufptr++;
2681 // ToDo: handle bitmap
2682 bitmap = info->layout.bitmap;
2683 /* this assumes that the payload starts immediately after the info-ptr */
2686 while (bitmap != 0) {
2687 if ((bitmap & 1) == 0) {
2688 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2692 bitmap = bitmap >> 1;
2696 belch("*<-- UnpackPAP: nothing to do for follow_srt");
2699 /* large bitmap (> 32 entries) */
2704 StgLargeBitmap *large_bitmap;
2708 belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
2709 p, info->layout.large_bitmap));
2712 ((StgClosure *)p)->header.info = *bufptr++;
2715 large_bitmap = info->layout.large_bitmap;
2717 for (j=0; j<large_bitmap->size; j++) {
2718 bitmap = large_bitmap->bitmap[j];
2719 q = p + sizeof(W_) * 8;
2720 while (bitmap != 0) {
2721 if ((bitmap & 1) == 0) {
2722 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2726 bitmap = bitmap >> 1;
2728 if (j+1 < large_bitmap->size) {
2730 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2735 /* and don't forget to follow the SRT */
2740 barf("UnpackPAP: weird activation record found on stack: %d",
2745 belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
2746 (StgClosure *)graph);
2747 printClosure((StgClosure *)graph));
2749 IF_DEBUG(sanity, /* check sanity of unpacked PAP */
2750 checkClosure(graph));
2753 return _HS+2+packed_size;
2758 //@node GranSim Code, , Local Definitions, Unpacking routines
2759 //@subsubsection GranSim Code
2762 For GrAnSim: No actual unpacking should be necessary. We just
2763 have to walk over the graph and set the bitmasks appropriately.
2764 Since we use RBHs similarly to GUM but without an ACK message/event
2765 we have to revert the RBH from within the UnpackGraph routine (good luck!)
2771 CommonUp(StgClosure *src, StgClosure *dst)
2773 barf("CommonUp: should never be entered in a GranSim setup");
2778 rtsPackBuffer* buffer;
2780 nat size, ptrs, nonptrs, vhs,
2782 StgClosure *closure, *graphroot, *graph;
2784 StgWord bufsize, unpackedsize,
2785 pptr = 0, pptrs = 0, pvhs;
2787 char str[240], str1[80];
2791 graphroot = buffer->buffer[0];
2795 /* Unpack the header */
2796 unpackedsize = buffer->unpacked_size;
2797 bufsize = buffer->size;
2800 belch("<<< Unpacking <<%d>> (buffer @ %p):\n (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
2801 buffer->id, buffer, graphroot, where_is(graphroot),
2802 bufsize, tso->id, tso,
2803 where_is((StgClosure *)tso)));
2806 closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
2808 /* Actually only ip is needed; rest is useful for TESTING -- HWL */
2809 ip = get_closure_info(closure,
2810 &size, &ptrs, &nonptrs, &vhs, str);
2813 sprintf(str, "** (%p): Changing bitmask[%s]: 0x%x ",
2814 closure, (closure_HNF(closure) ? "NF" : "__"),
2817 if (get_itbl(closure)->type == RBH) {
2818 /* if it's an RBH, we have to revert it into a normal closure, thereby
2819 awakening the blocking queue; not that this is code currently not
2820 needed in GUM, but it should be added with the new features in
2821 GdH (and the implementation of an NACK message)
2823 // closure->header.gran.procs = PE_NUMBER(CurrentProc);
2824 SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc)); /* Move node */
2827 strcat(str, " (converting RBH) "));
2829 convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
2832 belch(":: closure %p (%s) is a RBH; after reverting: IP=%p",
2833 closure, info_type(closure), get_itbl(closure)));
2834 } else if (IS_BLACK_HOLE(closure)) {
2836 belch(":: closure %p (%s) is a BH; copying node to %d",
2837 closure, info_type(closure), CurrentProc));
2838 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
2839 } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
2840 if (closure_HNF(closure)) {
2842 belch(":: closure %p (%s) is a HNF; copying node to %d",
2843 closure, info_type(closure), CurrentProc));
2844 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
2847 belch(":: closure %p (%s) is no (R)BH or HNF; moving node to %d",
2848 closure, info_type(closure), CurrentProc));
2849 closure->header.gran.procs = PE_NUMBER(CurrentProc); /* Move node */
2854 sprintf(str1, "0x%x", PROCS(closure)); strcat(str, str1));
2855 IF_GRAN_DEBUG(pack, belch(str));
2857 } while (bufptr<buffer->size) ; /* (parent != NULL); */
2859 /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
2860 free(buffer->buffer);
2864 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
2870 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
2871 //@subsection Aux fcts for packing
2876 //* Types of Global Addresses::
2880 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
2881 //@subsubsection Offset table
2884 DonePacking is called when we've finished packing. It releases memory
2887 //@cindex DonePacking
2894 freeHashTable(offsetTable, NULL);
2899 AmPacking records that the closure is being packed. Note the abuse of
2900 the data field in the hash table -- this saves calling @malloc@! */
2906 StgClosure *closure;
2908 insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
2912 OffsetFor returns an offset for a closure which is already being packed. */
2918 StgClosure *closure;
2920 return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
2924 NotYetPacking determines whether the closure's already being packed.
2925 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no. */
2927 //@cindex NotYetPacking
2930 NotYetPacking(offset)
2933 return(offset == 0); // ToDo: what if root is found again?? FIX
2945 NotYetPacking searches through the whole pack buffer for closure. */
2948 NotYetPacking(closure)
2949 StgClosure *closure;
2951 rtsBool found = rtsFalse;
2953 for (i=0; (i<pack_locn) && !found; i++)
2954 found = globalPackBuffer->buffer[i]==closure;
2960 //@node Packet size, Types of Global Addresses, Offset table, Aux fcts for packing
2961 //@subsubsection Packet size
2964 RoomToPack determines whether there's room to pack the closure into
2965 the pack buffer based on
2967 o how full the buffer is already,
2968 o the closures' size and number of pointers (which must be packed as GAs),
2969 o the size and number of pointers held by any primitive arrays that it
2972 It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
2976 //@cindex RoomToPack
2978 RoomToPack(size, ptrs)
2983 (pack_locn + // where we are in the buffer right now
2984 size + // space needed for the current closure
2985 ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE // space for queued closures
2987 RTS_PACK_BUFFER_SIZE))
2990 belch("*>** pack buffer full"));
2991 roomInBuffer = rtsFalse;
2995 (unpacked_size + size +
2996 ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
2999 belch("*>** pack buffer full"));
3000 roomInBuffer = rtsFalse;
3003 return (roomInBuffer);
3006 //@node Types of Global Addresses, Closure Info, Packet size, Aux fcts for packing
3007 //@subsubsection Types of Global Addresses
3010 Types of Global Addresses
3012 These routines determine whether a GA is one of a number of special types
3019 isOffset(globalAddr *ga)
3021 return (ga->weight == 1 && ga->payload.gc.gtid == 0);
3026 isFixed(globalAddr *ga)
3028 return (ga->weight == 0);
3033 isConstr(globalAddr *ga)
3035 return (ga->weight == 2);
3039 //@node Closure Info, , Types of Global Addresses, Aux fcts for packing
3040 //@subsubsection Closure Info
3045 @get_closure_info@ determines the size, number of pointers etc. for this
3046 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
3048 [Can someone please keep this function up to date. I keep needing it
3049 (or something similar) for interpretive code, and it keeps
3050 bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95] */
3054 // {Parallel.h}Daq ngoqvam vIroQpu'
3056 # if defined(GRAN) || defined(PAR)
3057 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
3058 //@cindex get_closure_info
3060 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
3062 nat *size, *ptrs, *nonptrs, *vhs;
3067 info = get_itbl(node);
3068 /* the switch shouldn't be necessary, really; just use default case */
3069 switch (info->type) {
3074 *size = sizeW_fromITBL(info);
3075 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3076 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3077 *vhs = (nat) 0; // unknown
3078 info_hdr_type(node, info_hdr_ty);
3084 *size = sizeW_fromITBL(info);
3085 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3086 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3087 *vhs = (nat) 0; // unknown
3088 info_hdr_type(node, info_hdr_ty);
3094 *size = sizeW_fromITBL(info);
3095 *ptrs = (nat) 2; // (info->layout.payload.ptrs);
3096 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3097 *vhs = (nat) 0; // unknown
3098 info_hdr_type(node, info_hdr_ty);
3104 *size = sizeW_fromITBL(info);
3105 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3106 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3107 *vhs = (nat) 0; // unknown
3108 info_hdr_type(node, info_hdr_ty);
3114 *size = sizeW_fromITBL(info);
3115 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3116 *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
3117 *vhs = (nat) 0; // unknown
3118 info_hdr_type(node, info_hdr_ty);
3123 StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
3124 *size = sizeW_fromITBL(rip);
3125 *ptrs = (nat) (rip->layout.payload.ptrs);
3126 *nonptrs = (nat) (rip->layout.payload.nptrs);
3127 *vhs = (nat) 0; // unknown
3128 info_hdr_type(node, info_hdr_ty);
3129 return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
3133 *size = sizeW_fromITBL(info);
3134 *ptrs = (nat) (info->layout.payload.ptrs);
3135 *nonptrs = (nat) (info->layout.payload.nptrs);
3136 *vhs = (nat) 0; // unknown
3137 info_hdr_type(node, info_hdr_ty);
3142 //@cindex IS_BLACK_HOLE
3144 IS_BLACK_HOLE(StgClosure* node)
3147 info = get_itbl(node);
3148 return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
3151 //@cindex IS_INDIRECTION
3153 IS_INDIRECTION(StgClosure* node)
3156 info = get_itbl(node);
3157 switch (info->type) {
3161 case IND_OLDGEN_PERM:
3163 /* relies on indirectee being at same place for all these closure types */
3164 return (((StgInd*)node) -> indirectee);
3172 IS_THUNK(StgClosure* node)
3175 info = get_itbl(node);
3176 return ((info->type == THUNK ||
3177 info->type == THUNK_STATIC ||
3178 info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
3189 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
3191 W_ *size, *ptrs, *nonptrs, *vhs;
3194 P_ ip = (P_) INFO_PTR(closure);
3196 if (closure==NULL) {
3197 fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
3198 *size = *ptrs = *nonptrs = *vhs = 0;
3199 strcpy(type,"ERROR in get_closure_info");
3201 } else if (closure==PrelBase_Z91Z93_closure) {
3202 /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
3203 *size = *ptrs = *nonptrs = *vhs = 0;
3204 strcpy(type,"PrelBase_Z91Z93_closure");
3208 ip = (P_) INFO_PTR(closure);
3210 switch (INFO_TYPE(ip)) {
3211 case INFO_SPEC_U_TYPE:
3212 case INFO_SPEC_S_TYPE:
3213 case INFO_SPEC_N_TYPE:
3214 *size = SPEC_CLOSURE_SIZE(closure);
3215 *ptrs = SPEC_CLOSURE_NoPTRS(closure);
3216 *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
3217 *vhs = 0 /*SPEC_VHS*/;
3218 strcpy(type,"SPEC");
3221 case INFO_GEN_U_TYPE:
3222 case INFO_GEN_S_TYPE:
3223 case INFO_GEN_N_TYPE:
3224 *size = GEN_CLOSURE_SIZE(closure);
3225 *ptrs = GEN_CLOSURE_NoPTRS(closure);
3226 *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
3232 *size = DYN_CLOSURE_SIZE(closure);
3233 *ptrs = DYN_CLOSURE_NoPTRS(closure);
3234 *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
3239 case INFO_TUPLE_TYPE:
3240 *size = TUPLE_CLOSURE_SIZE(closure);
3241 *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
3242 *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
3244 strcpy(type,"TUPLE");
3247 case INFO_DATA_TYPE:
3248 *size = DATA_CLOSURE_SIZE(closure);
3249 *ptrs = DATA_CLOSURE_NoPTRS(closure);
3250 *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
3252 strcpy(type,"DATA");
3255 case INFO_IMMUTUPLE_TYPE:
3256 case INFO_MUTUPLE_TYPE:
3257 *size = MUTUPLE_CLOSURE_SIZE(closure);
3258 *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
3259 *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
3261 strcpy(type,"(IM)MUTUPLE");
3264 case INFO_STATIC_TYPE:
3265 *size = STATIC_CLOSURE_SIZE(closure);
3266 *ptrs = STATIC_CLOSURE_NoPTRS(closure);
3267 *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
3269 strcpy(type,"STATIC");
3274 *size = IND_CLOSURE_SIZE(closure);
3275 *ptrs = IND_CLOSURE_NoPTRS(closure);
3276 *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
3278 strcpy(type,"CAF|IND");
3281 case INFO_CONST_TYPE:
3282 *size = CONST_CLOSURE_SIZE(closure);
3283 *ptrs = CONST_CLOSURE_NoPTRS(closure);
3284 *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
3286 strcpy(type,"CONST");
3289 case INFO_SPEC_RBH_TYPE:
3290 *size = SPEC_RBH_CLOSURE_SIZE(closure);
3291 *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
3292 *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
3294 *nonptrs -= (2 - *ptrs);
3298 *vhs = SPEC_RBH_VHS;
3299 strcpy(type,"SPEC_RBH");
3302 case INFO_GEN_RBH_TYPE:
3303 *size = GEN_RBH_CLOSURE_SIZE(closure);
3304 *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
3305 *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
3307 *nonptrs -= (2 - *ptrs);
3312 strcpy(type,"GEN_RBH");
3315 case INFO_CHARLIKE_TYPE:
3316 *size = CHARLIKE_CLOSURE_SIZE(closure);
3317 *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
3318 *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
3319 *vhs = CHARLIKE_VHS;
3320 strcpy(type,"CHARLIKE");
3323 case INFO_INTLIKE_TYPE:
3324 *size = INTLIKE_CLOSURE_SIZE(closure);
3325 *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
3326 *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
3328 strcpy(type,"INTLIKE");
3332 case INFO_FETCHME_TYPE:
3333 *size = FETCHME_CLOSURE_SIZE(closure);
3334 *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
3335 *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
3337 strcpy(type,"FETCHME");
3340 case INFO_FMBQ_TYPE:
3341 *size = FMBQ_CLOSURE_SIZE(closure);
3342 *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
3343 *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
3345 strcpy(type,"FMBQ");
3350 *size = BQ_CLOSURE_SIZE(closure);
3351 *ptrs = BQ_CLOSURE_NoPTRS(closure);
3352 *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
3358 *size = BH_CLOSURE_SIZE(closure);
3359 *ptrs = BH_CLOSURE_NoPTRS(closure);
3360 *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
3366 *size = 0; /* TSO_CLOSURE_SIZE(closure); */
3367 *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
3368 *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
3373 case INFO_STKO_TYPE:
3378 strcpy(type,"STKO");
3382 fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
3383 INFO_TYPE(ip), (StgWord) closure);
3392 // Use allocate in Storage.c instead
3394 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
3395 is available, but it will not perform garbage collection.
3396 ToDo: check whether we can use an existing STG allocation routine -- HWL
3400 //@cindex AllocateHeap
3407 /* Allocate a new closure */
3408 if (Hp + size > HpLim)
3411 newClosure = Hp + 1;
3420 //@cindex doGlobalGC
3424 fprintf(stderr,"Splat -- we just hit global GC!\n");
3425 stg_exit(EXIT_FAILURE);
3426 //fishing = rtsFalse;
3427 outstandingFishes--;
3432 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
3433 //@subsection Printing Packet Contents
3435 Printing Packet Contents
3438 #if defined(DEBUG) || defined(GRAN_CHECK)
3440 //@cindex PrintPacket
3444 PrintPacket(packBuffer)
3445 rtsPackBuffer *packBuffer;
3447 StgClosure *parent, *graphroot, *closure_start;
3448 const StgInfoTable *ip;
3450 StgWord **buffer, **bufptr, **slotptr;
3453 nat pptr = 0, pptrs = 0, pvhs;
3456 nat size, ptrs, nonptrs, vhs;
3459 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3460 unpacking components replaced by printing fcts
3461 Long live higher-order fcts!
3463 /* Initialisation */
3464 //InitPackBuffer(); /* in case it isn't already init'd */
3466 // ASSERT(gaga==PendingGABuffer);
3467 graphroot = (StgClosure *)NULL;
3469 /* Unpack the header */
3470 bufsize = packBuffer->size;
3471 bufptr = packBuffer->buffer;
3473 fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
3474 packBuffer->id, packBuffer);
3475 fprintf(stderr, "*. size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
3476 packBuffer->size, packBuffer->unpacked_size,
3477 packBuffer->tso, packBuffer->buffer);
3479 parent = (StgClosure *)NULL;
3482 /* This is where we will ultimately save the closure's address */
3484 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3486 /* First, unpack the next GA or PLC */
3487 ga.weight = (rtsWeight) *bufptr++;
3489 if (ga.weight > 0) {
3490 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3491 ga.payload.gc.slot = (int) *bufptr++;
3493 ga.payload.plc = (StgPtr) *bufptr++;
3495 /* Now unpack the closure body, if there is one */
3497 fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
3498 // closure = ga.payload.plc;
3499 } else if (isOffset(&ga)) {
3500 fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
3501 // closure = (StgClosure *) buffer[ga.payload.gc.slot];
3503 /* Print normal closures */
3505 ASSERT(bufsize > 0);
3507 fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
3508 ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
3510 closure_start = bufptr;
3511 ip = get_closure_info((StgClosure *)bufptr,
3512 &size, &ptrs, &nonptrs, &vhs, str);
3514 /* ToDo: check whether this is really needed */
3515 if (ip->type == FETCH_ME) {
3517 ptrs = nonptrs = vhs = 0;
3519 /* ToDo: check whether this is really needed */
3520 if (ip->type == ARR_WORDS) {
3522 nonptrs = ((StgArrWords *)bufptr)->words;
3523 size = arr_words_sizeW((StgArrWords *)bufptr);
3526 /* special code for printing a PAP in a buffer */
3527 if (ip->type == PAP || ip->type == AP_UPD) {
3530 nonptrs = ((StgPAP *)bufptr)->payload[0];
3531 size = _HS+vhs+ptrs+nonptrs;
3535 Remember, the generic closure layout is as follows:
3536 +-------------------------------------------------+
3537 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
3538 +-------------------------------------------------+
3540 /* Print fixed header */
3541 fprintf(stderr, "FH [");
3542 for (i = 0; i < _HS; i++)
3543 fprintf(stderr, " %p", *bufptr++);
3545 if (ip->type == FETCH_ME)
3546 size = ptrs = nonptrs = vhs = 0;
3548 // VH is always empty in the new RTS
3550 ip->type == PAP || ip->type == AP_UPD);
3551 /* Print variable header */
3552 fprintf(stderr, "] VH [");
3553 for (i = 0; i < vhs; i++)
3554 fprintf(stderr, " %p", *bufptr++);
3556 //fprintf(stderr, "] %d PTRS [", ptrs);
3557 /* Pointers will be filled in later */
3559 fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
3560 /* Print non-pointers */
3561 for (i = 0; i < nonptrs; i++)
3562 fprintf(stderr, " %p", *bufptr++);
3564 fprintf(stderr, "] (%s)\n", str);
3566 /* Indirections are never packed */
3567 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
3569 /* Add to queue for processing
3570 When just printing the packet we do not have an unpacked closure
3571 in hand, so we feed it the packet entry;
3572 again, this assumes that at least the fixed header of the closure
3573 has the same layout in the packet; also we may not overwrite entries
3574 in the packet (done in Unpack), but for printing that's a bad idea
3576 QueueClosure((StgClosure *)closure_start);
3578 /* No Common up needed for printing */
3580 /* No Sort out the global address mapping for printing */
3582 } /* normal closure case */
3584 /* Locate next parent pointer */
3586 while (pptr + 1 > pptrs) {
3587 parent = DeQueueClosure();
3592 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
3597 } while (parent != NULL);
3598 fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
3599 packBuffer->id, packBuffer->size, size);
3604 Doing a sanity check on a packet.
3605 This does a full iteration over the packet, as in PrintPacket.
3607 //@cindex checkPacket
3609 checkPacket(packBuffer)
3610 rtsPackBuffer *packBuffer;
3612 StgClosure *parent, *graphroot, *closure_start;
3613 const StgInfoTable *ip;
3615 StgWord **buffer, **bufptr, **slotptr;
3618 nat pptr = 0, pptrs = 0, pvhs;
3620 nat size, ptrs, nonptrs, vhs;
3623 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3624 unpacking components replaced by printing fcts
3625 Long live higher-order fcts!
3627 /* Initialisation */
3628 //InitPackBuffer(); /* in case it isn't already init'd */
3630 // ASSERT(gaga==PendingGABuffer);
3631 graphroot = (StgClosure *)NULL;
3633 /* Unpack the header */
3634 bufsize = packBuffer->size;
3635 bufptr = packBuffer->buffer;
3636 parent = (StgClosure *)NULL;
3637 ASSERT(bufsize > 0);
3639 /* This is where we will ultimately save the closure's address */
3641 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3642 ASSERT(locn<=bufsize);
3644 /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
3645 ga.weight = (rtsWeight) *bufptr++;
3646 if (ga.weight > 0) {
3647 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3648 ga.payload.gc.slot = (int) *bufptr++;
3650 ga.payload.plc = (StgPtr) *bufptr++;
3652 /* Now unpack the closure body, if there is one */
3655 ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
3656 } else if (isOffset(&ga)) {
3657 ASSERT(ga.payload.gc.slot<=bufsize);
3659 /* normal closure */
3660 ASSERT(LOOKS_LIKE_GA(&ga));
3662 closure_start = bufptr;
3663 ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
3664 ip = get_closure_info((StgClosure *)bufptr,
3665 &size, &ptrs, &nonptrs, &vhs, str);
3667 /* ToDo: check whether this is really needed */
3668 if (ip->type == FETCH_ME) {
3670 ptrs = nonptrs = vhs = 0;
3672 /* ToDo: check whether this is really needed */
3673 if (ip->type == ARR_WORDS) {
3675 nonptrs = ((StgArrWords *)bufptr)->words+1; // payload+words
3676 size = arr_words_sizeW((StgArrWords *)bufptr);
3677 ASSERT(size==_HS+vhs+nonptrs);
3679 /* special code for printing a PAP in a buffer */
3680 if (ip->type == PAP || ip->type == AP_UPD) {
3683 nonptrs = ((StgPAP *)bufptr)->payload[0];
3684 size = _HS+vhs+ptrs+nonptrs;
3687 /* no checks on contents of closure (pointers aren't packed anyway) */
3688 ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
3689 bufptr += _HS+vhs+nonptrs;
3691 /* Add to queue for processing */
3692 QueueClosure((StgClosure *)closure_start);
3694 /* No Common up needed for checking */
3696 /* No Sort out the global address mapping for checking */
3698 } /* normal closure case */
3700 /* Locate next parent pointer */
3702 while (pptr + 1 > pptrs) {
3703 parent = DeQueueClosure();
3708 //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
3709 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
3714 } while (parent != NULL);
3715 /* we unpacked exactly as many words as there are in the buffer */
3716 ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
3721 rtsPackBuffer *buffer;
3723 // extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
3724 // extern char *display_info_type(P_ infoptr); /* defined in Threads.lc */
3727 nat size, ptrs, nonptrs, vhs;
3728 char info_hdr_ty[80];
3729 char str1[80], str2[80], junk_str[80];
3731 /* globalAddr ga; */
3733 nat bufsize, unpacked_size ;
3735 nat pptr = 0, pptrs = 0, pvhs;
3737 nat unpack_locn = 0;
3738 nat gastart = unpack_locn;
3739 nat closurestart = unpack_locn;
3742 StgClosure *closure, *p;
3746 fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
3747 fprintf(stderr, " size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
3748 buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
3749 fputs(" contents: ", stderr);
3750 for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
3751 closure = buffer->buffer[unpack_locn];
3752 fprintf(stderr, ", %p (%s)",
3753 closure, info_type(closure));
3755 fputc('\n', stderr);
3758 /* traverse all elements of the graph; omitted for now, but might be usefule */
3763 /* Unpack the header */
3764 unpacked_size = buffer->unpacked_size;
3765 bufsize = buffer->size;
3767 fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
3768 buffer, bufsize, unpacked_size,
3769 tso->id, tso, where_is((StgClosure*)tso));
3772 closurestart = unpack_locn;
3773 closure = buffer->buffer[unpack_locn++];
3775 fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
3777 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
3779 fprintf(stderr, "(%s|%s) ", str1, str2);
3781 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
3782 IS_BLACK_HOLE(closure))
3783 size = ptrs = nonptrs = vhs = 0;
3785 if (closure_THUNK(closure)) {
3786 if (closure_UNPOINTED(closure))
3787 fputs("UNPOINTED ", stderr);
3789 fputs("POINTED ", stderr);
3791 if (IS_BLACK_HOLE(closure)) {
3792 fputs("BLACK HOLE\n", stderr);
3795 fprintf(stderr, "FH [");
3796 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
3797 fprintf(stderr, " %p", *p);
3801 fprintf(stderr, "] VH [%p", closure->payload[_HS]);
3803 for (i = 1; i < vhs; i++)
3804 fprintf(stderr, " %p", closure->payload[_HS+i]);
3807 fprintf(stderr, "] PTRS %u", ptrs);
3811 fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
3813 for (i = 1; i < nonptrs; i++)
3814 fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
3820 } while (unpack_locn<bufsize) ; /* (parent != NULL); */
3822 fprintf(stderr, "--- End ---\n\n");
3826 #endif /* DEBUG || GRAN_CHECK */
3828 #endif /* PAR || GRAN -- whole file */
3830 //@node End of file, , Printing Packet Contents, Graph packing
3831 //@subsection End of file
3834 //* AllocateHeap:: @cindex\s-+AllocateHeap
3835 //* AmPacking:: @cindex\s-+AmPacking
3836 //* CommonUp:: @cindex\s-+CommonUp
3837 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
3838 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
3839 //* DonePacking:: @cindex\s-+DonePacking
3840 //* FillInClosure:: @cindex\s-+FillInClosure
3841 //* IS_BLACK_HOLE:: @cindex\s-+IS_BLACK_HOLE
3842 //* IS_INDIRECTION:: @cindex\s-+IS_INDIRECTION
3843 //* InitClosureQueue:: @cindex\s-+InitClosureQueue
3844 //* InitPendingGABuffer:: @cindex\s-+InitPendingGABuffer
3845 //* LocateNextParent:: @cindex\s-+LocateNextParent
3846 //* NotYetPacking:: @cindex\s-+NotYetPacking
3847 //* OffsetFor:: @cindex\s-+OffsetFor
3848 //* Pack:: @cindex\s-+Pack
3849 //* PackArray:: @cindex\s-+PackArray
3850 //* PackClosure:: @cindex\s-+PackClosure
3851 //* PackFetchMe:: @cindex\s-+PackFetchMe
3852 //* PackGeneric:: @cindex\s-+PackGeneric
3853 //* PackNearbyGraph:: @cindex\s-+PackNearbyGraph
3854 //* PackOneNode:: @cindex\s-+PackOneNode
3855 //* PackPAP:: @cindex\s-+PackPAP
3856 //* PackPLC:: @cindex\s-+PackPLC
3857 //* PackStkO:: @cindex\s-+PackStkO
3858 //* PackTSO:: @cindex\s-+PackTSO
3859 //* PendingGABuffer:: @cindex\s-+PendingGABuffer
3860 //* PrintPacket:: @cindex\s-+PrintPacket
3861 //* QueueClosure:: @cindex\s-+QueueClosure
3862 //* QueueEmpty:: @cindex\s-+QueueEmpty
3863 //* RoomToPack:: @cindex\s-+RoomToPack
3864 //* SetGAandCommonUp:: @cindex\s-+SetGAandCommonUp
3865 //* UnpackGA:: @cindex\s-+UnpackGA
3866 //* UnpackGraph:: @cindex\s-+UnpackGraph
3867 //* UnpackOffset:: @cindex\s-+UnpackOffset
3868 //* UnpackPLC:: @cindex\s-+UnpackPLC
3869 //* doGlobalGC:: @cindex\s-+doGlobalGC
3870 //* get_closure_info:: @cindex\s-+get_closure_info
3871 //* InitPackBuffer:: @cindex\s-+initPackBuffer
3872 //* isFixed:: @cindex\s-+isFixed
3873 //* isOffset:: @cindex\s-+isOffset
3874 //* offsetTable:: @cindex\s-+offsetTable