2 Time-stamp: <Thu Mar 30 2000 22:53:32 Stardate: [-30]4584.56 hwloidl>
3 $Id: Pack.c,v 1.5 2000/08/07 23:37:24 qrczak 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 StgChar val = ((StgIntCharlikeClosure*)closure)->data;
728 if ((val <= MAX_CHARLIKE) && (val >= MIN_CHARLIKE)) {
730 belch("*>^^ Packing a small charlike %d as a PLC", val));
731 PackPLC((StgPtr)CHARLIKE_CLOSURE(val));
734 belch("*>^^ Packing a big charlike %d as a normal closure",
736 PackGeneric(closure);
743 StgInt val = ((StgIntCharlikeClosure*)closure)->data;
745 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
747 belch("*>^^ Packing a small intlike %d as a PLC", val));
748 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
751 belch("*>^^ Packing a big intlike %d as a normal closure",
753 PackGeneric(closure);
764 /* it's a constructor (i.e. plain data) */
766 belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
767 closure, info_type(closure)));
768 PackGeneric(closure);
771 case THUNK_STATIC: // ToDo: check whether that's ok
772 case FUN_STATIC: // ToDo: check whether that's ok
774 case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
775 // evaluated on each PE if needed
777 belch("*>~~ Packing a %p (%s) as a PLC",
778 closure, info_type(closure)));
780 PackPLC((StgPtr)closure);
785 StgClosure *selectee = ((StgSelector *)closure)->selectee;
788 belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
789 closure, info_type(closure),
790 selectee, info_type(selectee)));
791 PackGeneric(closure);
792 /* inlined code; probably could use PackGeneric
793 Pack((StgWord)(*(StgPtr)closure));
794 Pack((StgWord)(selectee));
795 QueueClosure(selectee);
813 PackGeneric(closure);
819 barf("*> Packing of PAP not implemented %p (%s)",
820 closure, info_type(closure));
822 Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
823 instead. Note that since PAPs contain a chunk of stack as payload,
824 implementing packing of PAPs is a first step towards thread migration.
826 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
827 closure, info_type(closure)));
828 PackFetchMe(closure);
830 PackPAP((StgPAP *)closure);
839 case SE_CAF_BLACKHOLE:
844 /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
845 //ASSERT(pack_locn > PACK_HDR_SIZE);
848 belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
849 closure, info_type(closure)));
850 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
851 phps short-cut the GA here */
852 PackFetchMe(closure);
856 barf("*> Pack: packing of MVARs not implemented",
857 closure, info_type(closure));
859 /* MVARs may not be copied; they are sticky objects in the new RTS */
860 /* therefore we treat them just as RBHs etc (what a great system!)
862 belch("** Found an MVar at %p (%s)",
863 closure, info_type(closure))); */
865 belch("*>.. Packing an MVAR at %p (%s) as a FETCH_ME",
866 closure, info_type(closure)));
867 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
868 phps short-cut the GA here */
869 PackFetchMe(closure);
877 case MUT_ARR_PTRS_FROZEN:
880 Eventually, this should use the same packing routine as ARR_WRODS
882 GlobaliseAndPackGA(closure);
886 barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
887 closure, info_type(closure));
891 barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
892 closure, info_type(closure));
895 // check error cases only in a debugging setup
902 barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
903 closure, info_type(closure));
910 barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
911 closure, info_type(closure));
917 /* something's very wrong */
918 barf("{Pack}Daq Qagh: found %s (%p) when packing",
919 info_type(closure), closure);
925 case IND_OLDGEN_PERM:
927 barf("Pack: found IND_... after shorting out indirections %d (%s)",
928 (nat)(info->type), info_type(closure));
933 barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
934 (nat)(info->type), info_type(closure));
938 barf("Pack: strange closure %d", (nat)(info->type));
943 Pack a constructor of unknown size.
944 Similar to PackGeneric but without creating GAs.
949 PackConstr(StgClosure *closure)
952 nat size, ptrs, nonptrs, vhs, i;
955 ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
957 /* get info about basic layout of the closure */
958 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
960 ASSERT(info->type == CONSTR ||
961 info->type == CONSTR_1_0 ||
962 info->type == CONSTR_0_1 ||
963 info->type == CONSTR_2_0 ||
964 info->type == CONSTR_1_1 ||
965 info->type == CONSTR_0_2);
968 fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
969 closure, info_type(closure), size, ptrs, nonptrs));
971 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
973 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
975 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
976 closure, info_type(closure)));
977 PackFetchMe(closure);
981 /* Record the location of the GA */
984 /* Pack Constructor marker */
987 /* pack fixed and variable header */
988 for (i = 0; i < _HS + vhs; ++i)
989 Pack((StgWord)*(((StgPtr)closure)+i));
991 /* register all ptrs for further packing */
992 for (i = 0; i < ptrs; ++i)
993 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
996 for (i = 0; i < nonptrs; ++i)
997 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1002 Generic packing code.
1003 This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
1005 //@cindex PackGeneric
1007 PackGeneric(StgClosure *closure)
1011 nat size, ptrs, nonptrs, vhs, i, m;
1014 ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
1016 /* get info about basic layout of the closure */
1017 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1019 ASSERT(!IS_BLACK_HOLE(closure));
1022 fprintf(stderr, "*>== generic packing of %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1023 closure, info_type(closure), size, ptrs, nonptrs));
1025 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1027 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1029 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1030 closure, info_type(closure)));
1031 PackFetchMe(closure);
1035 /* Record the location of the GA */
1037 /* Allocate a GA for this closure and put it into the buffer */
1038 GlobaliseAndPackGA(closure);
1040 ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1041 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1043 /* At last! A closure we can actually pack! */
1044 if (ip_MUTABLE(info) && (info->type != FETCH_ME))
1045 barf("*>// PackClosure: trying to replicate a Mutable closure!");
1048 Remember, the generic closure layout is as follows:
1049 +-------------------------------------------------+
1050 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1051 +-------------------------------------------------+
1053 /* pack fixed and variable header */
1054 for (i = 0; i < _HS + vhs; ++i)
1055 Pack((StgWord)*(((StgPtr)closure)+i));
1057 /* register all ptrs for further packing */
1058 for (i = 0; i < ptrs; ++i)
1059 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1062 for (i = 0; i < nonptrs; ++i)
1063 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1065 // ASSERT(_HS+vhs+ptrs+nonptrs==size);
1066 if ((m=_HS+vhs+ptrs+nonptrs)<size) {
1068 belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
1069 closure, info_type(closure), size-m));
1070 for (i=m; i<size; i++)
1071 Pack((StgWord)*(((StgPtr)closure)+i));
1074 unpacked_size += size;
1075 // unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1078 * Record that this is a revertable black hole so that we can fill in
1079 * its address from the fetch reply. Problem: unshared thunks may cause
1080 * space leaks this way, their GAs should be deallocated following an
1084 // IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) !? HWL
1085 if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
1086 rbh = convertToRBH(closure);
1087 ASSERT(rbh == closure); // rbh at the same position (minced version)
1092 Pack an array of words.
1093 ToDo: implement packing of MUT_ARRAYs
1098 PackArray(StgClosure *closure)
1101 nat size, ptrs, nonptrs, vhs, i, n;
1105 /* we don't really need all that get_closure_info delivers; however, for
1106 debugging it's useful to have the stuff anyway */
1108 /* get info about basic layout of the closure */
1109 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1111 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1112 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
1114 /* record offset of the closure and allocate a GA */
1116 GlobaliseAndPackGA(closure);
1118 n = ((StgArrWords *)closure)->words;
1119 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
1122 belch("*>== packing an array of %d words %p (%s) (size=%d)\n",
1123 n, closure, info_type(closure),
1124 arr_words_sizeW((StgArrWords *)closure)));
1126 /* Pack the header (2 words: info ptr and the number of words to follow) */
1127 Pack((StgWord)*(StgPtr)closure);
1128 Pack(((StgArrWords *)closure)->words);
1130 /* pack the payload of the closure (all non-ptrs) */
1132 Pack((StgWord)((StgArrWords *)closure)->payload[i]);
1134 unpacked_size += arr_words_sizeW((StgArrWords *)closure);
1139 Note that the representation of a PAP in the buffer is different from
1140 its representation in the heap. In particular, pointers to local
1141 closures are packed directly as FETCHME closures, using
1142 PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
1143 structure. To account for the difference in size we store the packed
1144 size of the closure as part of the PAP's variable header in the buffer.
1149 PackPAP(StgPAP *pap) {
1150 nat m, n, i, j, pack_start;
1151 StgPtr p, q, end/*dbg*/;
1152 const StgInfoTable* info;
1154 /* debugging only */
1155 nat size, ptrs, nonptrs, vhs;
1158 /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
1159 ASSERT(PACK_FETCHME_SIZE == 1 + sizeofW(StgFetchMe));
1160 ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
1162 /* record offset of the closure and allocate a GA */
1163 AmPacking((StgClosure *)pap);
1164 GlobaliseAndPackGA((StgClosure *)pap);
1166 /* get info about basic layout of the closure */
1167 info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
1168 ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
1170 n = (nat)(pap->n_args);
1173 belch("*>** PackPAP: packing PAP @ %p with %d words (size=%d; ptrs=%d; nonptrs=%d:",
1174 (StgClosure *)pap, n, size, ptrs, nonptrs);
1175 printClosure((StgClosure *)pap));
1177 /* Pack the PAP header */
1178 Pack((StgWord)(pap->header.info));
1179 Pack((StgWord)(pap->n_args));
1180 Pack((StgWord)(pap->fun));
1181 pack_start = pack_locn; // to compute size of PAP in buffer
1182 Pack((StgWord)0); // this will be filled in later (size of PAP in buffer)
1184 /* Pack the payload of a PAP i.e. a stack chunk */
1185 /* pointers to start of stack chunk */
1186 p = (StgPtr)(pap->payload);
1187 end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
1189 /* the loop body has been borrowed from scavenge_stack */
1192 /* If we've got a tag, pack all words in that block */
1193 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
1194 nat m = ARG_TAG(q); // first word after this block
1196 belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
1198 for (i=0; i<m+1; i++)
1199 Pack((StgWord)*(p+i));
1200 p += m+1; // m words + the tag
1204 /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
1205 ToDo: provide RTS flag to also pack these closures
1207 if (! LOOKS_LIKE_GHC_INFO(q) ) {
1208 /* distinguish static closure (PLC) from other closures (FM) */
1209 switch (get_itbl((StgClosure*)q)->type) {
1210 case CONSTR_CHARLIKE:
1212 StgChar val = ((StgIntCharlikeClosure*)q)->data;
1214 if ((val <= MAX_CHARLIKE) && (val >= MIN_CHARLIKE)) {
1216 belch("*>** PackPAP: Packing ptr to a small charlike %d as a PLC", val));
1217 PackPLC((StgPtr)CHARLIKE_CLOSURE(val));
1220 belch("*>** PackPAP: Packing a ptr to a big charlike %d as a FM",
1222 Pack((StgWord)(ARGTAG_MAX+1));
1223 PackFetchMe((StgClosure *)q);
1229 case CONSTR_INTLIKE:
1231 StgInt val = ((StgIntCharlikeClosure*)q)->data;
1233 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
1235 belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1236 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1239 belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
1241 Pack((StgWord)(ARGTAG_MAX+1));
1242 PackFetchMe((StgClosure *)q);
1247 case THUNK_STATIC: // ToDo: check whether that's ok
1248 case FUN_STATIC: // ToDo: check whether that's ok
1250 case CONSTR_NOCAF_STATIC:
1253 belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
1254 q, info_type((StgClosure *)q)));
1262 belch("*>** PackPAP @ %p: packing FM to %p (%s)",
1263 p, q, info_type((StgClosure*)q)));
1264 Pack((StgWord)(ARGTAG_MAX+1));
1265 PackFetchMe((StgClosure *)q);
1273 * Otherwise, q must be the info pointer of an activation
1274 * record. All activation records have 'bitmap' style layout
1277 info = get_itbl((StgClosure *)p);
1278 switch (info->type) {
1280 /* Dynamic bitmap: the mask is stored on the stack */
1283 belch("*>** PackPAP @ %p: RET_DYN",
1286 /* Pack the header as is */
1287 Pack((StgWord)(((StgRetDyn *)p)->info));
1288 Pack((StgWord)(((StgRetDyn *)p)->liveness));
1289 Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
1291 bitmap = ((StgRetDyn *)p)->liveness;
1292 p = (P_)&((StgRetDyn *)p)->payload[0];
1295 /* probably a slow-entry point return address: */
1300 belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
1303 Pack((StgWord)(((StgClosure *)p)->header.info));
1306 goto follow_srt; //??
1309 /* Using generic code here; could inline as in scavenge_stack */
1312 StgUpdateFrame *frame = (StgUpdateFrame *)p;
1313 nat type = get_itbl(frame->updatee)->type;
1315 ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
1318 belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
1319 p, frame->updatee, frame->link));
1321 Pack((StgWord)(frame->header.info));
1322 Pack((StgWord)(frame->link)); // ToDo: fix intra-stack pointer
1323 Pack((StgWord)(frame->updatee)); // ToDo: follow link
1328 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1332 belch("*>** PackPAP @ %p: STOP_FRAME",
1334 Pack((StgWord)((StgStopFrame *)p)->header.info);
1341 belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
1342 p, ((StgCatchFrame *)p)->handler));
1344 Pack((StgWord)((StgCatchFrame *)p)->header.info);
1345 Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
1346 Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
1347 Pack((StgWord)((StgCatchFrame *)p)->handler);
1354 belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
1355 p, ((StgSeqFrame *)p)->link));
1357 Pack((StgWord)((StgSeqFrame *)p)->header.info);
1358 Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
1360 // ToDo: handle bitmap
1361 bitmap = info->layout.bitmap;
1363 p = (StgPtr)&(((StgClosure *)p)->payload);
1370 belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
1371 p, info->layout.bitmap));
1374 Pack((StgWord)((StgClosure *)p)->header.info);
1376 // ToDo: handle bitmap
1377 bitmap = info->layout.bitmap;
1378 /* this assumes that the payload starts immediately after the info-ptr */
1381 while (bitmap != 0) {
1382 if ((bitmap & 1) == 0) {
1383 Pack((StgWord)(ARGTAG_MAX+1));
1384 PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1386 Pack((StgWord)*p++);
1388 bitmap = bitmap >> 1;
1392 belch("*>-- PackPAP: nothing to do for follow_srt");
1395 /* large bitmap (> 32 entries) */
1400 StgLargeBitmap *large_bitmap;
1403 belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
1404 p, info->layout.large_bitmap));
1407 Pack((StgWord)((StgClosure *)p)->header.info);
1410 large_bitmap = info->layout.large_bitmap;
1412 for (j=0; j<large_bitmap->size; j++) {
1413 bitmap = large_bitmap->bitmap[j];
1414 q = p + sizeof(W_) * 8;
1415 while (bitmap != 0) {
1416 if ((bitmap & 1) == 0) {
1417 Pack((StgWord)(ARGTAG_MAX+1));
1418 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1420 Pack((StgWord)*p++);
1422 bitmap = bitmap >> 1;
1424 if (j+1 < large_bitmap->size) {
1426 Pack((StgWord)(ARGTAG_MAX+1));
1427 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1432 /* and don't forget to follow the SRT */
1437 barf("PackPAP: weird activation record found on stack (@ %p): %d",
1438 p, (int)(info->type));
1441 // fill in size of the PAP (only the payload!) in buffer
1442 globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1443 // add the size of the whole packed closure; this relies on the fact that
1444 // the size of the unpacked PAP + size of all unpacked FMs is the same as
1445 // the size of the packed PAP!!
1446 unpacked_size += sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
1450 /* Fake the packing of a closure */
1453 PackClosure(closure)
1454 StgClosure *closure;
1456 StgInfoTable *info, *childInfo;
1457 nat size, ptrs, nonptrs, vhs;
1458 char info_hdr_ty[80];
1460 StgClosure *indirectee, *rbh;
1462 rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
1464 is_mutable = rtsFalse;
1466 /* In GranSim we don't pack and unpack closures -- we just simulate
1467 packing by updating the bitmask. So, the graph structure is unchanged
1468 i.e. we don't short out indirections here. -- HWL */
1470 /* Nothing to do with packing but good place to (sanity) check closure;
1471 if the closure is a thunk, it must be unique; otherwise we have copied
1472 work at some point before that which violates one of our main global
1473 assertions in GranSim/GUM */
1474 ASSERT(!closure_THUNK(closure) || is_unique(closure));
1477 belch("** Packing closure %p (%s)",
1478 closure, info_type(closure)));
1480 if (where_is(closure) != where_is(graph_root)) {
1482 belch("** faking a FETCHME [current PE: %d, closure's PE: %d]",
1483 where_is(graph_root), where_is(closure)));
1485 /* GUM would pack a FETCHME here; simulate that by increasing the */
1486 /* unpacked size accordingly but don't pack anything -- HWL */
1487 unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
1491 /* If the closure's not already being packed */
1492 if (!NotYetPacking(closure))
1493 /* Don't have to do anything in GrAnSim if closure is already */
1497 belch("** Closure %p is already packed and omitted now!",
1502 switch (get_itbl(closure)->type) {
1503 /* ToDo: check for sticky bit here? */
1504 /* BH-like closures which must not be moved to another PE */
1505 case CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1506 case SE_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1507 case SE_CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1508 case BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1509 case BLACKHOLE_BQ: /* # of ptrs, nptrs: 1,1 */
1510 case RBH: /* # of ptrs, nptrs: 1,1 */
1511 /* same for these parallel specific closures */
1516 belch("** Avoid packing BH-like closures (%p, %s)!",
1517 closure, info_type(closure)));
1518 /* Just ignore RBHs i.e. they stay where they are */
1521 case THUNK_SELECTOR:
1523 StgClosure *selectee = ((StgSelector *)closure)->selectee;
1526 belch("** Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
1527 closure, info_type(closure), selectee, info_type(selectee)));
1528 QueueClosure(selectee);
1530 belch("** [%p (%s) (Queueing closure) ....]",
1531 selectee, info_type(selectee)));
1536 case CONSTR_NOCAF_STATIC:
1537 /* For now we ship indirections to CAFs:
1538 * They are evaluated on each PE if needed */
1540 belch("** Nothing to pack for %p (%s)!",
1541 closure, info_type(closure)));
1542 // Pack(closure); GUM only
1545 case CONSTR_CHARLIKE:
1546 case CONSTR_INTLIKE:
1548 belch("** Nothing to pack for %s (%p)!",
1549 closure, info_type(closure)));
1550 // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1555 /* partial applications; special treatment necessary? */
1558 case CAF_UNENTERED: /* # of ptrs, nptrs: 1,3 */
1559 case CAF_ENTERED: /* # of ptrs, nptrs: 0,4 (allegedly bogus!!) */
1560 /* CAFs; special treatment necessary? */
1564 barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1565 closure, info_type(closure));
1570 case MUT_ARR_PTRS_FROZEN:
1571 /* Mutable objects; require special treatment to ship all data */
1572 is_mutable = rtsTrue;
1578 /* weak pointers and other FFI objects */
1579 barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1580 closure, info_type(closure));
1583 /* parallel objects */
1584 barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1585 closure, info_type(closure));
1588 /* Hugs objects (i.e. closures used by the interpreter) */
1589 barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1590 closure, info_type(closure));
1592 case IND: /* # of ptrs, nptrs: 1,0 */
1593 case IND_STATIC: /* # of ptrs, nptrs: 1,0 */
1594 case IND_PERM: /* # of ptrs, nptrs: 1,1 */
1595 case IND_OLDGEN: /* # of ptrs, nptrs: 1,1 */
1596 case IND_OLDGEN_PERM: /* # of ptrs, nptrs: 1,1 */
1597 /* we shouldn't find an indirection here, because we have shorted them
1598 out at the beginning of this functions already.
1602 barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1603 closure, info_type(closure));
1610 /* stack frames; should never be found when packing for now;
1611 once we support thread migration these have to be covered properly
1613 barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1614 closure, info_type(closure));
1622 /* vectored returns; should never be found when packing; */
1623 barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1624 closure, info_type(closure));
1626 case INVALID_OBJECT:
1627 barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1628 closure, info_type(closure));
1632 Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1633 a specialised version with wired in #ptr/#nptr info; currently
1634 we treat these specialised versions like the generic version)
1638 /* Otherwise it's not Fixed */
1640 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1641 will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1644 belch("** Info on closure %p (%s): size=%d; ptrs=%d",
1645 closure, info_type(closure),
1647 (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1649 // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1650 no_more_thunks_please =
1651 (RtsFlags.GranFlags.ThunksToPack>0) &&
1652 (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1655 should be covered by get_closure_info
1656 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1657 info->type == BLACKHOLE || info->type == RBH )
1658 size = ptrs = nonptrs = vhs = 0;
1660 /* Now peek ahead to see whether the closure has any primitive */
1661 /* array children */
1664 for (i = 0; i < ptrs; ++i) {
1666 W_ childSize, childPtrs, childNonPtrs, childVhs;
1668 childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
1669 &childSize, &childPtrs, &childNonPtrs,
1670 &childVhs, junk_str);
1671 if (IS_BIG_MOTHER(childInfo)) {
1672 reservedPAsize += PACK_GA_SIZE + FIXED_HS +
1673 childVhs + childNonPtrs +
1674 childPtrs * PACK_FETCHME_SIZE;
1675 PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
1676 PAptrs += childPtrs;
1680 /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1681 * is full and it isn't a primitive array. N.B. Primitive arrays are
1682 * always packed (because their parents index into them directly) */
1684 if (IS_BLACK_HOLE(closure))
1688 !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
1689 || IS_BIG_MOTHER(info)))
1693 /* At last! A closure we can actually pack! */
1695 if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1696 belch("ghuH: Replicated a Mutable closure!");
1698 if (RtsFlags.GranFlags.GranSimStats.Global &&
1699 no_more_thunks_please && will_be_rbh) {
1700 globalGranStats.tot_cuts++;
1701 if ( RtsFlags.GranFlags.Debug.pack )
1702 belch("** PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1703 RtsFlags.GranFlags.ThunksToPack, closure);
1704 } else if (will_be_rbh || (closure==graph_root) ) {
1706 globalGranStats.tot_thunks++;
1709 if (no_more_thunks_please && will_be_rbh)
1710 return; /* don't pack anything */
1712 /* actual PACKING done here -- HWL */
1714 for (i = 0; i < ptrs; ++i) {
1715 /* extract i-th pointer from closure */
1716 QueueClosure((StgClosure *)(closure->payload[i]));
1718 belch("** [%p (%s) (Queueing closure) ....]",
1719 closure->payload[i], info_type(payloadPtr(closure,i))));
1723 for packing words (GUM only) do something like this:
1725 for (i = 0; i < ptrs; ++i) {
1726 Pack(payloadWord(obj,i+j));
1729 /* Turn thunk into a revertible black hole. */
1731 rbh = convertToRBH(closure);
1732 ASSERT(rbh != NULL);
1737 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1738 //@subsection Low level packing routines
1741 @Pack@ is the basic packing routine. It just writes a word of data into
1742 the pack buffer and increments the pack location. */
1751 ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1752 globalPackBuffer->buffer[pack_locn++] = data;
1759 StgClosure *closure;
1762 nat size, ptrs, nonptrs, vhs;
1765 /* This checks the size of the GrAnSim internal pack buffer. The simulated
1766 pack buffer is checked via RoomToPack (as in GUM) */
1767 if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
1768 reallocPackBuffer();
1770 if (closure==(StgClosure*)NULL)
1771 belch("Qagh {Pack}Daq: Trying to pack 0");
1772 globalPackBuffer->buffer[pack_locn++] = closure;
1773 /* ASSERT: Data is a closure in GrAnSim here */
1774 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1775 // ToDo: is check for MIN_UPD_SIZE really needed? */
1776 unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1783 If a closure is local, make it global. Then, divide its weight for
1784 export. The GA is then packed into the pack buffer. */
1787 //@cindex GlobaliseAndPackGA
1789 GlobaliseAndPackGA(closure)
1790 StgClosure *closure;
1795 if ((ga = LAGAlookup(closure)) == NULL)
1796 ga = makeGlobal(closure, rtsTrue);
1797 ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
1798 splitWeight(&packGA, ga);
1799 ASSERT(packGA.weight > 0);
1802 fprintf(stderr, "*>## Globalising closure %p (%s) with GA ",
1803 closure, info_type(closure));
1805 fputc('\n', stderr));
1808 Pack((StgWord) packGA.weight);
1809 Pack((StgWord) packGA.payload.gc.gtid);
1810 Pack((StgWord) packGA.payload.gc.slot);
1814 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
1815 address follows instead of PE, slot. */
1823 Pack(0L); /* weight */
1824 Pack((StgWord) addr); /* address */
1828 @PackOffset@ packs a special GA value that will be interpreted as an
1829 offset to a closure in the pack buffer. This is used to avoid unfolding
1830 the graph structure into a tree. */
1838 belch("** Packing Offset %d at pack location %u",
1839 offset, pack_locn));
1841 Pack(1L); /* weight */
1843 Pack(offset); /* slot/offset */
1847 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
1848 //@subsection Unpacking routines
1851 This was formerly in the (now deceased) module Unpack.c
1853 Unpacking closures which have been exported to remote processors
1855 This module defines routines for unpacking closures in the parallel
1856 runtime system (GUM).
1858 In the case of GrAnSim, this module defines routines for *simulating* the
1859 unpacking of closures as it is done in the parallel runtime system.
1862 //@node GUM code, Local Definitions, Unpacking routines, Unpacking routines
1863 //@subsubsection GUM code
1867 //@cindex InitPendingGABuffer
1869 InitPendingGABuffer(size)
1872 if (PendingGABuffer==(globalAddr *)NULL)
1873 PendingGABuffer = (globalAddr *)
1874 stgMallocBytes(size*2*sizeof(globalAddr),
1875 "InitPendingGABuffer");
1877 /* current location in the buffer */
1878 gaga = PendingGABuffer;
1882 @CommonUp@ commons up two closures which we have discovered to be
1883 variants of the same object. One is made an indirection to the other. */
1887 CommonUp(StgClosure *src, StgClosure *dst)
1889 StgBlockingQueueElement *bqe;
1891 ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
1895 belch("*___ CommonUp %p (%s) --> %p (%s)",
1896 src, info_type(src), dst, info_type(dst)));
1898 switch (get_itbl(src)->type) {
1900 bqe = ((StgBlockingQueue *)src)->blocking_queue;
1904 bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
1908 bqe = ((StgRBH *)src)->blocking_queue;
1916 /* currently we also common up 2 CONSTRs; this should reduce heap
1917 * consumption but also does more work; not sure whether it's worth doing
1927 case MUT_ARR_PTRS_FROZEN:
1932 /* Don't common up anything else */
1935 /* NB: this also awakens the blocking queue for src */
1937 // updateWithIndirection(src, dst);
1939 ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
1940 if (bqe != END_BQ_QUEUE)
1941 awakenBlockedQueue(bqe, src);
1946 * Common up the new closure with any existing closure having the same
1949 //@cindex SetGAandCommonUp
1951 SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
1953 StgClosure *existing;
1954 StgInfoTable *ip, *oldip;
1960 ip = get_itbl(closure);
1961 if ((existing = GALAlookup(ga)) == NULL) {
1962 /* Just keep the new object */
1964 belch("*<## Unpacking new GA ((%x, %d, %x))",
1965 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight));
1967 // make an entry binding closure to ga in the RemoteGA table
1968 newGA = setRemoteGA(closure, ga, rtsTrue);
1969 if (ip->type == FETCH_ME)
1970 ((StgFetchMe *)closure)->ga = newGA;
1972 /* Two closures, one global name. Someone loses */
1973 oldip = get_itbl(existing);
1974 if ((oldip->type == FETCH_ME ||
1975 /* If we pack GAs for CONSTRs we have to check for them, too */
1976 IS_BLACK_HOLE(existing)) &&
1977 ip->type != FETCH_ME)
1980 belch("*<#- Unpacking old GA ((%x, %d, %x)); redirecting %p -> %p",
1981 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
1982 existing, closure));
1985 * What we had wasn't worth keeping, so make the old closure an
1986 * indirection to the new closure (copying BQs if necessary) and
1987 * make sure that the old entry is not the preferred one for this
1990 CommonUp(existing, closure);
1991 //GALAdeprecate(ga);
1992 /* now ga indirectly refers to the new closure */
1993 ASSERT(UNWIND_IND(GALAlookup(ga))==closure);
1996 * Either we already had something worthwhile by this name or
1997 * the new thing is just another FetchMe. However, the thing we
1998 * just unpacked has to be left as-is, or the child unpacking
1999 * code will fail. Remember that the way pointer words are
2000 * filled in depends on the info pointers of the parents being
2001 * the same as when they were packed.
2004 belch("*<#@ Unpacking old GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
2005 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2006 existing, info_type(existing), closure, info_type(closure)));
2011 ty = get_itbl(closure)->type;
2018 CommonUp(closure, graph);
2021 /* Pool the total weight in the stored ga */
2022 (void) addWeight(ga);
2025 /* ToDo: check this assertion!!
2026 if we have unpacked a FETCH_ME, we have a GA, too
2027 ASSERT(get_itbl(*closureP)->type!=FETCH_ME ||
2028 looks_like_ga(((StgFetchMe *)*closureP)->ga));
2030 /* Sort out the global address mapping */
2032 // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
2033 //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
2034 /* Make up new GAs for single-copy closures */
2035 globalAddr *newGA = makeGlobal(closure, rtsTrue);
2037 // It's a new GA and therefore has the full weight
2038 ASSERT(newGA->weight==0);
2040 /* Create an old GA to new GA mapping */
2042 splitWeight(gaga, newGA);
2043 /* inlined splitWeight; we know that newGALA has full weight
2044 newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
2045 gaga->payload = newGA->payload;
2047 ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
2054 Copies a segment of the buffer, starting at @bufptr@, representing a closure
2055 into the heap at @graph@.
2057 //@cindex FillInClosure
2059 FillInClosure(StgWord ***bufptrP, StgClosure *graph)
2062 StgWord **bufptr = *bufptrP;
2063 nat ptrs, nonptrs, vhs, i, size;
2066 ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
2069 * Close your eyes. You don't want to see where we're looking. You
2070 * can't get closure info until you've unpacked the variable header,
2071 * but you don't know how big it is until you've got closure info.
2072 * So...we trust that the closure in the buffer is organized the
2073 * same way as they will be in the heap...at least up through the
2074 * end of the variable header.
2076 ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2078 /* Make sure that nothing sans the fixed header is filled in
2079 The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
2080 if (ip->type == FETCH_ME) {
2081 ASSERT(size>=MIN_UPD_SIZE); // size of the FM in the heap
2082 ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
2084 /* ToDo: check whether this is really needed */
2085 if (ip->type == ARR_WORDS) {
2086 UnpackArray(bufptrP, graph);
2087 return arr_words_sizeW((StgArrWords *)bufptr);
2090 if (ip->type == PAP || ip->type == AP_UPD) {
2091 return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
2095 Remember, the generic closure layout is as follows:
2096 +-------------------------------------------------+
2097 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2098 +-------------------------------------------------+
2100 /* Fill in the fixed header */
2101 for (i = 0; i < _HS; i++)
2102 ((StgPtr)graph)[i] = (StgWord)*bufptr++;
2104 /* Fill in the packed variable header */
2105 for (i = 0; i < vhs; i++)
2106 ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
2108 /* Pointers will be filled in later */
2110 /* Fill in the packed non-pointers */
2111 for (i = 0; i < nonptrs; i++)
2112 ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
2114 /* Indirections are never packed */
2115 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2118 ASSERT((ip->type==FETCH_ME && sizeofW(StgFetchMe)==size) ||
2119 _HS+vhs+ptrs+nonptrs == size);
2124 Find the next pointer field in the parent closure.
2125 If the current parent has been completely unpacked already, get the
2126 next closure from the global closure queue.
2128 //@cindex LocateNextParent
2130 LocateNextParent(parentP, pptrP, pptrsP, sizeP)
2131 StgClosure **parentP;
2132 nat *pptrP, *pptrsP, *sizeP;
2134 StgInfoTable *ip; // debugging
2138 /* pptr as an index into the current parent; find the next pointer field
2139 in the parent by increasing pptr; if that takes us off the closure
2140 (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
2143 while (*pptrP + 1 > *pptrsP) {
2144 /* *parentP has been constructed (all pointer set); so check it now */
2146 if (*parentP!=(StgClosure*)NULL &&
2147 get_itbl(*parentP)->type != FETCH_ME)
2148 checkClosure(*parentP));
2150 *parentP = DeQueueClosure();
2152 if (*parentP == NULL)
2155 ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
2160 /* *parentP points to the new (or old) parent; */
2161 /* *pptr, *pptrs and *size have been updated referring to the new parent */
2165 UnpackClosure is the heart of the unpacking routine. It is called for
2166 every closure found in the packBuffer. Any prefix such as GA, PLC marker
2167 etc has been unpacked into the *ga structure.
2168 UnpackClosure does the following:
2169 - check for the kind of the closure (PLC, Offset, std closure)
2170 - copy the contents of the closure from the buffer into the heap
2171 - update LAGA tables (in particular if we end up with 2 closures
2172 having the same GA, we make one an indirection to the other)
2173 - set the GAGA map in order to send back an ACK message
2175 At the end of this function *graphP has been updated to point to the
2176 next free word in the heap for unpacking the rest of the graph and
2177 *bufptrP points to the next word in the pack buffer to be unpacked.
2181 UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
2182 StgClosure *closure;
2184 rtsBool hasGA = rtsFalse;
2186 /* Now unpack the closure body, if there is one; three cases:
2187 - PLC: closure is just a pointer to a static closure
2188 - Offset: closure has been unpacked already
2189 - else: copy data from packet into closure
2192 closure = UnpackPLC(ga);
2193 } else if (isOffset(ga)) {
2194 closure = UnpackOffset(ga);
2196 ASSERT(LOOKS_LIKE_GA(ga));
2197 /* Now we have to build something. */
2198 hasGA = !isConstr(ga);
2199 /* the new closure will be built here */
2202 /* fill in the closure from the buffer */
2203 size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
2205 /* Add to queue for processing */
2206 QueueClosure(closure);
2208 /* common up with other graph if necessary */
2209 closure = SetGAandCommonUp(ga, closure, hasGA);
2211 /* if we unpacked a THUNK, check that it is large enough to update */
2212 ASSERT(!closure_THUNK(closure) || size>=MIN_UPD_SIZE);
2213 /* graph shall point to next free word in the heap */
2215 //graph += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
2221 @UnpackGraph@ unpacks the graph contained in a message buffer. It
2222 returns a pointer to the new graph. The @gamap@ parameter is set to
2223 point to an array of (oldGA,newGA) pairs which were created as a result
2224 of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
2227 The format of graph in the pack buffer is as defined in @Pack.lc@. */
2229 //@cindex UnpackGraph
2231 UnpackGraph(packBuffer, gamap, nGAs)
2232 rtsPackBuffer *packBuffer;
2236 StgWord **bufptr, **slotptr;
2238 StgClosure *closure, *graphroot, *graph, *parent;
2239 nat size, heapsize, bufsize,
2240 pptr = 0, pptrs = 0, pvhs = 0;
2242 /* Initialisation */
2243 InitPacking(rtsTrue); // same as in PackNearbyGraph
2244 globalUnpackBuffer = packBuffer;
2246 IF_DEBUG(sanity, // do a sanity check on the incoming packet
2247 checkPacket(packBuffer));
2249 ASSERT(gaga==PendingGABuffer);
2250 graphroot = (StgClosure *)NULL;
2252 /* Unpack the header */
2253 bufsize = packBuffer->size;
2254 heapsize = packBuffer->unpacked_size;
2255 bufptr = packBuffer->buffer;
2259 graph = (StgClosure *)allocate(heapsize);
2260 ASSERT(graph != NULL);
2263 /* iterate over the buffer contents and unpack all closures */
2264 parent = (StgClosure *)NULL;
2266 /* This is where we will ultimately save the closure's address */
2269 /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
2270 bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
2272 /* this allocates heap space, updates LAGA tables etc */
2273 closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
2276 * Set parent pointer to point to chosen closure. If we're at the top of
2277 * the graph (our parent is NULL), then we want to arrange to return the
2278 * chosen closure to our caller (possibly in place of the allocated graph
2282 graphroot = closure;
2284 ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
2286 /* Save closure pointer for resolving offsets */
2287 *slotptr = (StgWord) closure;
2289 /* Locate next parent pointer */
2290 LocateNextParent(&parent, &pptr, &pptrs, &size);
2293 gaS.weight = 0xdeadffff;
2294 gaS.payload.gc.gtid = 0xdead;
2295 gaS.payload.gc.slot = 0xdeadbeef;);
2296 } while (parent != NULL);
2298 /* we unpacked exactly as many words as there are in the buffer */
2299 ASSERT(bufsize == bufptr-(packBuffer->buffer) &&
2300 heapsize >= graph-graphroot); // should be ==
2302 *gamap = PendingGABuffer;
2303 *nGAs = (gaga - PendingGABuffer) / 2;
2305 IF_PAR_DEBUG(tables,
2306 belch("** LAGA table after unpacking closure %p:",
2310 /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
2311 ASSERT(graphroot!=NULL);
2317 /* check the unpacked graph */
2318 checkHeapChunk(graphroot,graph-sizeof(StgWord));
2320 // if we do sanity checks, then wipe the pack buffer after unpacking
2321 for (p=packBuffer->buffer; p<(packBuffer->buffer)+(packBuffer->size); )
2325 /* reset the global variable */
2326 globalUnpackBuffer = (rtsPackBuffer*)NULL;
2332 UnpackGA(StgWord **bufptr, globalAddr *ga)
2334 /* First, unpack the next GA or PLC */
2335 ga->weight = (rtsWeight) *bufptr++;
2337 if (ga->weight > 0) {
2338 ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
2339 ga->payload.gc.slot = (int) *bufptr++;
2341 ga->payload.plc = (StgPtr) *bufptr++;
2348 UnpackPLC(globalAddr *ga)
2350 /* No more to unpack; just set closure to local address */
2352 belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
2353 return ga->payload.plc;
2356 //@cindex UnpackOffset
2358 UnpackOffset(globalAddr *ga)
2360 /* globalUnpackBuffer is a global var init in UnpackGraph */
2361 ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
2362 /* No more to unpack; just set closure to cached address */
2364 belch("*<__ Unpacked indirection to %p (was offset %d)",
2365 (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
2366 ga->payload.gc.slot));
2367 return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
2371 Input: *bufptrP, *graphP ... ptrs to the pack buffer and into the heap.
2373 *bufptrP points to something that should be unpacked as a FETCH_ME:
2376 +-------------------------------
2378 +-------------------------------
2380 The first 3 words starting at *bufptrP are the GA address; the next
2381 word is the generic FM info ptr followed by the remaining FH (if any)
2382 The result after unpacking will be a FETCH_ME closure, pointed to by
2383 *graphP at the start of the fct;
2386 +------------------------+
2387 | FH of FM | ptr to a GA |
2388 +------------------------+
2390 The ptr field points into the RemoteGA table, which holds the actual GA.
2391 *bufptrP has been updated to point to the next word in the buffer.
2392 *graphP has been updated to point to the first free word at the end.
2396 UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
2397 StgClosure *closure, *foo;
2400 /* This fct relies on size of FM < size of FM in pack buffer */
2401 ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
2403 /* fill in gaS from buffer */
2404 *bufptrP = UnpackGA(*bufptrP, &gaS);
2405 /* might be an offset to a closure in the pack buffer */
2406 if (isOffset(&gaS)) {
2407 belch("*< UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
2408 gaS.payload.gc.slot, *bufptrP);
2410 closure = UnpackOffset(&gaS);
2411 /* return address of previously unpacked closure; leaves *graphP unchanged */
2415 /* we have a proper GA at hand */
2416 ASSERT(LOOKS_LIKE_GA(&gaS));
2420 barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
2421 *bufptrP, info_type(*bufptrP)));
2424 belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
2428 /* the next thing must be the IP to a FETCH_ME closure */
2429 ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
2432 /* fill in the closure from the buffer */
2433 FillInClosure(bufptrP, closure);
2435 /* the newly built closure is a FETCH_ME */
2436 ASSERT(get_itbl(closure)->type == FETCH_ME);
2438 /* common up with other graph if necessary
2439 this also assigns the contents of gaS to the ga field of the FM closure */
2440 foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
2442 ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
2445 belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
2446 *graphP, *graphP+sizeofW(StgFetchMe), closure);
2447 printClosure(closure));
2448 *graphP += sizeofW(StgFetchMe);
2453 Unpack an array of words.
2454 Could use generic unpack most of the time, but cleaner to separate it.
2455 ToDo: implement packing of MUT_ARRAYs
2458 //@cindex UnackArray
2460 UnpackArray(StgWord ***bufptrP, StgClosure *graph)
2463 StgWord **bufptr=*bufptrP;
2464 nat size, ptrs, nonptrs, vhs, i, n;
2467 /* yes, I know I am paranoid; but who's asking !? */
2469 info = get_closure_info((StgClosure*)bufptr,
2470 &size, &ptrs, &nonptrs, &vhs, str);
2471 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
2472 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
2474 n = ((StgArrWords *)bufptr)->words;
2475 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
2478 belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
2479 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2480 arr_words_sizeW((StgArrWords *)bufptr)));
2482 /* Unpack the header (2 words: info ptr and the number of words to follow) */
2483 ((StgArrWords *)graph)->header.info = *bufptr++; // assumes _HS==1; yuck!
2484 ((StgArrWords *)graph)->words = *bufptr++;
2486 /* unpack the payload of the closure (all non-ptrs) */
2488 ((StgArrWords *)graph)->payload[i] = *bufptr++;
2490 ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
2495 Unpack a PAP in the buffer into a heap closure.
2496 For each FETCHME we find in the packed PAP we have to unpack a separate
2497 FETCHME closure and insert a pointer to this closure into the PAP.
2498 We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
2499 Note that the size of a FETCHME in the buffer is exactly the same as
2500 the size of an unpacked FETCHME plus 1 word for the pointer to it.
2501 Therefore, we just allocate packed_size words in the heap for the unpacking.
2502 After this routine the heap starting from *graph looks like this:
2506 v PAP closure | FM area |
2507 +------------------------------------------------------------+
2508 | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
2509 +------------------------------------------------------------+
2511 where payload contains pointers to each of the unpacked FM_1, FM_2 ...
2512 The size of the PAP closure plus all FMs is _HS+2+packed_size.
2517 UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
2519 nat n, i, j, packed_size = 0;
2520 StgPtr p, q, end, payload_start, p_FMs;
2521 const StgInfoTable* info;
2523 StgWord **bufptr = *bufptrP;
2526 belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
2527 *bufptr, *(bufptr+1), graph));
2529 /* Unpack the PAP header (both fixed and variable) */
2530 ((StgPAP *)graph)->header.info = *bufptr++;
2531 n = ((StgPAP *)graph)->n_args = *bufptr++;
2532 ((StgPAP *)graph)->fun = *bufptr++;
2533 packed_size = *bufptr++;
2536 belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
2537 ((StgPAP *)graph)->header.info,
2538 ((StgPAP *)graph)->n_args,
2539 ((StgPAP *)graph)->fun,
2542 payload_start = bufptr;
2543 /* p points to the current word in the heap */
2544 p = ((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
2545 p_FMs = graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
2546 end = (StgPtr) payload_start+packed_size;
2548 The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
2549 FM area for unpacking all FETCHMEs encountered during unpacking.
2551 while (bufptr<end) {
2552 /* be sure that we don't write more than we allocated for this closure */
2553 ASSERT(p_FMs <= graph+_HS+2+packed_size);
2554 /* be sure that the unpacked PAP doesn't run into the FM area */
2555 ASSERT(p < graph+pap_sizeW((StgPAP*)graph));
2556 /* the loop body has been borrowed from scavenge_stack */
2557 q = *bufptr; // let q be the contents of the current pointer into the buffer
2559 /* Test whether the next thing is a FETCH_ME.
2560 In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
2562 if (q==(StgPtr)(ARGTAG_MAX+1)) {
2564 belch("*<** UnpackPAP @ %p: unpacking FM to %p",
2566 bufptr++; // skip ARGTAG_MAX+1 marker
2567 // Unpack a FM into the FM area after the PAP proper and insert pointer
2568 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2572 /* Test whether it is a PLC */
2573 if (q==(StgPtr)0) { // same as isFixed(q)
2575 belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
2577 bufptr++; // skip 0 marker
2582 /* If we've got a tag, pack all words in that block */
2583 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
2584 nat m = i+ARG_SIZE(q); // first word after this block
2586 belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
2588 for (i=0; i<m+1; i++)
2594 * Otherwise, q must be the info pointer of an activation
2595 * record. All activation records have 'bitmap' style layout
2598 info = get_itbl((StgClosure *)q);
2599 switch (info->type) {
2601 /* Dynamic bitmap: the mask is stored on the stack */
2604 belch("*<** UnpackPAP @ %p: RET_DYN",
2607 /* Pack the header as is */
2608 ((StgRetDyn *)p)->info = *bufptr++;
2609 ((StgRetDyn *)p)->liveness = *bufptr;
2610 ((StgRetDyn *)p)->ret_addr= *bufptr;
2612 //bitmap = ((StgRetDyn *)p)->liveness;
2613 //p = (P_)&((StgRetDyn *)p)->payload[0];
2616 /* probably a slow-entry point return address: */
2621 belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
2624 ((StgClosure *)p)->header.info = *bufptr;
2627 goto follow_srt; //??
2630 /* Using generic code here; could inline as in scavenge_stack */
2633 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2634 //nat type = get_itbl(frame->updatee)->type;
2636 //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
2639 belch("*<** UnackPAP @ %p: UPDATE_FRAME",
2642 ((StgUpdateFrame *)p)->header.info = *bufptr;
2643 ((StgUpdateFrame *)p)->link= *bufptr++; // ToDo: fix intra-stack pointer
2644 ((StgUpdateFrame *)p)->updatee = *bufptr; // ToDo: follow link
2649 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
2653 belch("*<** UnpackPAP @ %p: STOP_FRAME",
2655 ((StgStopFrame *)p)->header.info = *bufptr;
2662 belch("*<** UnpackPAP @ %p: CATCH_FRAME",
2665 ((StgCatchFrame *)p)->header.info = *bufptr++;
2666 ((StgCatchFrame *)p)->link = *bufptr++;
2667 ((StgCatchFrame *)p)->exceptions_blocked = *bufptr++;
2668 ((StgCatchFrame *)p)->handler = *bufptr++;
2675 belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
2678 ((StgSeqFrame *)p)->header.info = *bufptr++;
2679 ((StgSeqFrame *)p)->link = *bufptr++;
2681 // ToDo: handle bitmap
2682 bitmap = info->layout.bitmap;
2684 p = (StgPtr)&(((StgClosure *)p)->payload);
2691 belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
2695 ((StgClosure *)p)->header.info = *bufptr++;
2697 // ToDo: handle bitmap
2698 bitmap = info->layout.bitmap;
2699 /* this assumes that the payload starts immediately after the info-ptr */
2702 while (bitmap != 0) {
2703 if ((bitmap & 1) == 0) {
2704 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2708 bitmap = bitmap >> 1;
2712 belch("*<-- UnpackPAP: nothing to do for follow_srt");
2715 /* large bitmap (> 32 entries) */
2720 StgLargeBitmap *large_bitmap;
2724 belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
2725 p, info->layout.large_bitmap));
2728 ((StgClosure *)p)->header.info = *bufptr++;
2731 large_bitmap = info->layout.large_bitmap;
2733 for (j=0; j<large_bitmap->size; j++) {
2734 bitmap = large_bitmap->bitmap[j];
2735 q = p + sizeof(W_) * 8;
2736 while (bitmap != 0) {
2737 if ((bitmap & 1) == 0) {
2738 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2742 bitmap = bitmap >> 1;
2744 if (j+1 < large_bitmap->size) {
2746 *p++ = UnpackFetchMe(&bufptr, &p_FMs);
2751 /* and don't forget to follow the SRT */
2756 barf("UnpackPAP: weird activation record found on stack: %d",
2761 belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
2762 (StgClosure *)graph);
2763 printClosure((StgClosure *)graph));
2765 IF_DEBUG(sanity, /* check sanity of unpacked PAP */
2766 checkClosure(graph));
2769 return _HS+2+packed_size;
2774 //@node GranSim Code, , Local Definitions, Unpacking routines
2775 //@subsubsection GranSim Code
2778 For GrAnSim: No actual unpacking should be necessary. We just
2779 have to walk over the graph and set the bitmasks appropriately.
2780 Since we use RBHs similarly to GUM but without an ACK message/event
2781 we have to revert the RBH from within the UnpackGraph routine (good luck!)
2787 CommonUp(StgClosure *src, StgClosure *dst)
2789 barf("CommonUp: should never be entered in a GranSim setup");
2794 rtsPackBuffer* buffer;
2796 nat size, ptrs, nonptrs, vhs,
2798 StgClosure *closure, *graphroot, *graph;
2800 StgWord bufsize, unpackedsize,
2801 pptr = 0, pptrs = 0, pvhs;
2803 char str[240], str1[80];
2807 graphroot = buffer->buffer[0];
2811 /* Unpack the header */
2812 unpackedsize = buffer->unpacked_size;
2813 bufsize = buffer->size;
2816 belch("<<< Unpacking <<%d>> (buffer @ %p):\n (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
2817 buffer->id, buffer, graphroot, where_is(graphroot),
2818 bufsize, tso->id, tso,
2819 where_is((StgClosure *)tso)));
2822 closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
2824 /* Actually only ip is needed; rest is useful for TESTING -- HWL */
2825 ip = get_closure_info(closure,
2826 &size, &ptrs, &nonptrs, &vhs, str);
2829 sprintf(str, "** (%p): Changing bitmask[%s]: 0x%x ",
2830 closure, (closure_HNF(closure) ? "NF" : "__"),
2833 if (get_itbl(closure)->type == RBH) {
2834 /* if it's an RBH, we have to revert it into a normal closure, thereby
2835 awakening the blocking queue; not that this is code currently not
2836 needed in GUM, but it should be added with the new features in
2837 GdH (and the implementation of an NACK message)
2839 // closure->header.gran.procs = PE_NUMBER(CurrentProc);
2840 SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc)); /* Move node */
2843 strcat(str, " (converting RBH) "));
2845 convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
2848 belch(":: closure %p (%s) is a RBH; after reverting: IP=%p",
2849 closure, info_type(closure), get_itbl(closure)));
2850 } else if (IS_BLACK_HOLE(closure)) {
2852 belch(":: closure %p (%s) is a BH; copying node to %d",
2853 closure, info_type(closure), CurrentProc));
2854 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
2855 } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
2856 if (closure_HNF(closure)) {
2858 belch(":: closure %p (%s) is a HNF; copying node to %d",
2859 closure, info_type(closure), CurrentProc));
2860 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
2863 belch(":: closure %p (%s) is no (R)BH or HNF; moving node to %d",
2864 closure, info_type(closure), CurrentProc));
2865 closure->header.gran.procs = PE_NUMBER(CurrentProc); /* Move node */
2870 sprintf(str1, "0x%x", PROCS(closure)); strcat(str, str1));
2871 IF_GRAN_DEBUG(pack, belch(str));
2873 } while (bufptr<buffer->size) ; /* (parent != NULL); */
2875 /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
2876 free(buffer->buffer);
2880 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
2886 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
2887 //@subsection Aux fcts for packing
2892 //* Types of Global Addresses::
2896 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
2897 //@subsubsection Offset table
2900 DonePacking is called when we've finished packing. It releases memory
2903 //@cindex DonePacking
2910 freeHashTable(offsetTable, NULL);
2915 AmPacking records that the closure is being packed. Note the abuse of
2916 the data field in the hash table -- this saves calling @malloc@! */
2922 StgClosure *closure;
2924 insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
2928 OffsetFor returns an offset for a closure which is already being packed. */
2934 StgClosure *closure;
2936 return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
2940 NotYetPacking determines whether the closure's already being packed.
2941 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no. */
2943 //@cindex NotYetPacking
2946 NotYetPacking(offset)
2949 return(offset == 0); // ToDo: what if root is found again?? FIX
2961 NotYetPacking searches through the whole pack buffer for closure. */
2964 NotYetPacking(closure)
2965 StgClosure *closure;
2967 rtsBool found = rtsFalse;
2969 for (i=0; (i<pack_locn) && !found; i++)
2970 found = globalPackBuffer->buffer[i]==closure;
2976 //@node Packet size, Types of Global Addresses, Offset table, Aux fcts for packing
2977 //@subsubsection Packet size
2980 RoomToPack determines whether there's room to pack the closure into
2981 the pack buffer based on
2983 o how full the buffer is already,
2984 o the closures' size and number of pointers (which must be packed as GAs),
2985 o the size and number of pointers held by any primitive arrays that it
2988 It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
2992 //@cindex RoomToPack
2994 RoomToPack(size, ptrs)
2999 (pack_locn + // where we are in the buffer right now
3000 size + // space needed for the current closure
3001 ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE // space for queued closures
3003 RTS_PACK_BUFFER_SIZE))
3006 belch("*>** pack buffer full"));
3007 roomInBuffer = rtsFalse;
3011 (unpacked_size + size +
3012 ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
3015 belch("*>** pack buffer full"));
3016 roomInBuffer = rtsFalse;
3019 return (roomInBuffer);
3022 //@node Types of Global Addresses, Closure Info, Packet size, Aux fcts for packing
3023 //@subsubsection Types of Global Addresses
3026 Types of Global Addresses
3028 These routines determine whether a GA is one of a number of special types
3035 isOffset(globalAddr *ga)
3037 return (ga->weight == 1 && ga->payload.gc.gtid == 0);
3042 isFixed(globalAddr *ga)
3044 return (ga->weight == 0);
3049 isConstr(globalAddr *ga)
3051 return (ga->weight == 2);
3055 //@node Closure Info, , Types of Global Addresses, Aux fcts for packing
3056 //@subsubsection Closure Info
3061 @get_closure_info@ determines the size, number of pointers etc. for this
3062 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
3064 [Can someone please keep this function up to date. I keep needing it
3065 (or something similar) for interpretive code, and it keeps
3066 bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95] */
3070 // {Parallel.h}Daq ngoqvam vIroQpu'
3072 # if defined(GRAN) || defined(PAR)
3073 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
3074 //@cindex get_closure_info
3076 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
3078 nat *size, *ptrs, *nonptrs, *vhs;
3083 info = get_itbl(node);
3084 /* the switch shouldn't be necessary, really; just use default case */
3085 switch (info->type) {
3090 *size = sizeW_fromITBL(info);
3091 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3092 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3093 *vhs = (nat) 0; // unknown
3094 info_hdr_type(node, info_hdr_ty);
3100 *size = sizeW_fromITBL(info);
3101 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3102 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3103 *vhs = (nat) 0; // unknown
3104 info_hdr_type(node, info_hdr_ty);
3110 *size = sizeW_fromITBL(info);
3111 *ptrs = (nat) 2; // (info->layout.payload.ptrs);
3112 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3113 *vhs = (nat) 0; // unknown
3114 info_hdr_type(node, info_hdr_ty);
3120 *size = sizeW_fromITBL(info);
3121 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3122 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3123 *vhs = (nat) 0; // unknown
3124 info_hdr_type(node, info_hdr_ty);
3130 *size = sizeW_fromITBL(info);
3131 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3132 *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
3133 *vhs = (nat) 0; // unknown
3134 info_hdr_type(node, info_hdr_ty);
3139 StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
3140 *size = sizeW_fromITBL(rip);
3141 *ptrs = (nat) (rip->layout.payload.ptrs);
3142 *nonptrs = (nat) (rip->layout.payload.nptrs);
3143 *vhs = (nat) 0; // unknown
3144 info_hdr_type(node, info_hdr_ty);
3145 return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
3149 *size = sizeW_fromITBL(info);
3150 *ptrs = (nat) (info->layout.payload.ptrs);
3151 *nonptrs = (nat) (info->layout.payload.nptrs);
3152 *vhs = (nat) 0; // unknown
3153 info_hdr_type(node, info_hdr_ty);
3158 //@cindex IS_BLACK_HOLE
3160 IS_BLACK_HOLE(StgClosure* node)
3163 info = get_itbl(node);
3164 return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
3167 //@cindex IS_INDIRECTION
3169 IS_INDIRECTION(StgClosure* node)
3172 info = get_itbl(node);
3173 switch (info->type) {
3177 case IND_OLDGEN_PERM:
3179 /* relies on indirectee being at same place for all these closure types */
3180 return (((StgInd*)node) -> indirectee);
3188 IS_THUNK(StgClosure* node)
3191 info = get_itbl(node);
3192 return ((info->type == THUNK ||
3193 info->type == THUNK_STATIC ||
3194 info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
3205 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
3207 W_ *size, *ptrs, *nonptrs, *vhs;
3210 P_ ip = (P_) INFO_PTR(closure);
3212 if (closure==NULL) {
3213 fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
3214 *size = *ptrs = *nonptrs = *vhs = 0;
3215 strcpy(type,"ERROR in get_closure_info");
3217 } else if (closure==PrelBase_Z91Z93_closure) {
3218 /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
3219 *size = *ptrs = *nonptrs = *vhs = 0;
3220 strcpy(type,"PrelBase_Z91Z93_closure");
3224 ip = (P_) INFO_PTR(closure);
3226 switch (INFO_TYPE(ip)) {
3227 case INFO_SPEC_U_TYPE:
3228 case INFO_SPEC_S_TYPE:
3229 case INFO_SPEC_N_TYPE:
3230 *size = SPEC_CLOSURE_SIZE(closure);
3231 *ptrs = SPEC_CLOSURE_NoPTRS(closure);
3232 *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
3233 *vhs = 0 /*SPEC_VHS*/;
3234 strcpy(type,"SPEC");
3237 case INFO_GEN_U_TYPE:
3238 case INFO_GEN_S_TYPE:
3239 case INFO_GEN_N_TYPE:
3240 *size = GEN_CLOSURE_SIZE(closure);
3241 *ptrs = GEN_CLOSURE_NoPTRS(closure);
3242 *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
3248 *size = DYN_CLOSURE_SIZE(closure);
3249 *ptrs = DYN_CLOSURE_NoPTRS(closure);
3250 *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
3255 case INFO_TUPLE_TYPE:
3256 *size = TUPLE_CLOSURE_SIZE(closure);
3257 *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
3258 *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
3260 strcpy(type,"TUPLE");
3263 case INFO_DATA_TYPE:
3264 *size = DATA_CLOSURE_SIZE(closure);
3265 *ptrs = DATA_CLOSURE_NoPTRS(closure);
3266 *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
3268 strcpy(type,"DATA");
3271 case INFO_IMMUTUPLE_TYPE:
3272 case INFO_MUTUPLE_TYPE:
3273 *size = MUTUPLE_CLOSURE_SIZE(closure);
3274 *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
3275 *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
3277 strcpy(type,"(IM)MUTUPLE");
3280 case INFO_STATIC_TYPE:
3281 *size = STATIC_CLOSURE_SIZE(closure);
3282 *ptrs = STATIC_CLOSURE_NoPTRS(closure);
3283 *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
3285 strcpy(type,"STATIC");
3290 *size = IND_CLOSURE_SIZE(closure);
3291 *ptrs = IND_CLOSURE_NoPTRS(closure);
3292 *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
3294 strcpy(type,"CAF|IND");
3297 case INFO_CONST_TYPE:
3298 *size = CONST_CLOSURE_SIZE(closure);
3299 *ptrs = CONST_CLOSURE_NoPTRS(closure);
3300 *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
3302 strcpy(type,"CONST");
3305 case INFO_SPEC_RBH_TYPE:
3306 *size = SPEC_RBH_CLOSURE_SIZE(closure);
3307 *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
3308 *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
3310 *nonptrs -= (2 - *ptrs);
3314 *vhs = SPEC_RBH_VHS;
3315 strcpy(type,"SPEC_RBH");
3318 case INFO_GEN_RBH_TYPE:
3319 *size = GEN_RBH_CLOSURE_SIZE(closure);
3320 *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
3321 *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
3323 *nonptrs -= (2 - *ptrs);
3328 strcpy(type,"GEN_RBH");
3331 case INFO_CHARLIKE_TYPE:
3332 *size = CHARLIKE_CLOSURE_SIZE(closure);
3333 *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
3334 *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
3335 *vhs = CHARLIKE_VHS;
3336 strcpy(type,"CHARLIKE");
3339 case INFO_INTLIKE_TYPE:
3340 *size = INTLIKE_CLOSURE_SIZE(closure);
3341 *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
3342 *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
3344 strcpy(type,"INTLIKE");
3348 case INFO_FETCHME_TYPE:
3349 *size = FETCHME_CLOSURE_SIZE(closure);
3350 *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
3351 *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
3353 strcpy(type,"FETCHME");
3356 case INFO_FMBQ_TYPE:
3357 *size = FMBQ_CLOSURE_SIZE(closure);
3358 *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
3359 *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
3361 strcpy(type,"FMBQ");
3366 *size = BQ_CLOSURE_SIZE(closure);
3367 *ptrs = BQ_CLOSURE_NoPTRS(closure);
3368 *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
3374 *size = BH_CLOSURE_SIZE(closure);
3375 *ptrs = BH_CLOSURE_NoPTRS(closure);
3376 *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
3382 *size = 0; /* TSO_CLOSURE_SIZE(closure); */
3383 *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
3384 *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
3389 case INFO_STKO_TYPE:
3394 strcpy(type,"STKO");
3398 fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
3399 INFO_TYPE(ip), (StgWord) closure);
3408 // Use allocate in Storage.c instead
3410 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
3411 is available, but it will not perform garbage collection.
3412 ToDo: check whether we can use an existing STG allocation routine -- HWL
3416 //@cindex AllocateHeap
3423 /* Allocate a new closure */
3424 if (Hp + size > HpLim)
3427 newClosure = Hp + 1;
3436 //@cindex doGlobalGC
3440 fprintf(stderr,"Splat -- we just hit global GC!\n");
3441 stg_exit(EXIT_FAILURE);
3442 //fishing = rtsFalse;
3443 outstandingFishes--;
3448 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
3449 //@subsection Printing Packet Contents
3451 Printing Packet Contents
3454 #if defined(DEBUG) || defined(GRAN_CHECK)
3456 //@cindex PrintPacket
3460 PrintPacket(packBuffer)
3461 rtsPackBuffer *packBuffer;
3463 StgClosure *parent, *graphroot, *closure_start;
3464 const StgInfoTable *ip;
3466 StgWord **buffer, **bufptr, **slotptr;
3469 nat pptr = 0, pptrs = 0, pvhs;
3472 nat size, ptrs, nonptrs, vhs;
3475 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3476 unpacking components replaced by printing fcts
3477 Long live higher-order fcts!
3479 /* Initialisation */
3480 //InitPackBuffer(); /* in case it isn't already init'd */
3482 // ASSERT(gaga==PendingGABuffer);
3483 graphroot = (StgClosure *)NULL;
3485 /* Unpack the header */
3486 bufsize = packBuffer->size;
3487 bufptr = packBuffer->buffer;
3489 fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
3490 packBuffer->id, packBuffer);
3491 fprintf(stderr, "*. size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
3492 packBuffer->size, packBuffer->unpacked_size,
3493 packBuffer->tso, packBuffer->buffer);
3495 parent = (StgClosure *)NULL;
3498 /* This is where we will ultimately save the closure's address */
3500 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3502 /* First, unpack the next GA or PLC */
3503 ga.weight = (rtsWeight) *bufptr++;
3505 if (ga.weight > 0) {
3506 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3507 ga.payload.gc.slot = (int) *bufptr++;
3509 ga.payload.plc = (StgPtr) *bufptr++;
3511 /* Now unpack the closure body, if there is one */
3513 fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
3514 // closure = ga.payload.plc;
3515 } else if (isOffset(&ga)) {
3516 fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
3517 // closure = (StgClosure *) buffer[ga.payload.gc.slot];
3519 /* Print normal closures */
3521 ASSERT(bufsize > 0);
3523 fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
3524 ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
3526 closure_start = bufptr;
3527 ip = get_closure_info((StgClosure *)bufptr,
3528 &size, &ptrs, &nonptrs, &vhs, str);
3530 /* ToDo: check whether this is really needed */
3531 if (ip->type == FETCH_ME) {
3533 ptrs = nonptrs = vhs = 0;
3535 /* ToDo: check whether this is really needed */
3536 if (ip->type == ARR_WORDS) {
3538 nonptrs = ((StgArrWords *)bufptr)->words;
3539 size = arr_words_sizeW((StgArrWords *)bufptr);
3542 /* special code for printing a PAP in a buffer */
3543 if (ip->type == PAP || ip->type == AP_UPD) {
3546 nonptrs = ((StgPAP *)bufptr)->payload[0];
3547 size = _HS+vhs+ptrs+nonptrs;
3551 Remember, the generic closure layout is as follows:
3552 +-------------------------------------------------+
3553 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
3554 +-------------------------------------------------+
3556 /* Print fixed header */
3557 fprintf(stderr, "FH [");
3558 for (i = 0; i < _HS; i++)
3559 fprintf(stderr, " %p", *bufptr++);
3561 if (ip->type == FETCH_ME)
3562 size = ptrs = nonptrs = vhs = 0;
3564 // VH is always empty in the new RTS
3566 ip->type == PAP || ip->type == AP_UPD);
3567 /* Print variable header */
3568 fprintf(stderr, "] VH [");
3569 for (i = 0; i < vhs; i++)
3570 fprintf(stderr, " %p", *bufptr++);
3572 //fprintf(stderr, "] %d PTRS [", ptrs);
3573 /* Pointers will be filled in later */
3575 fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
3576 /* Print non-pointers */
3577 for (i = 0; i < nonptrs; i++)
3578 fprintf(stderr, " %p", *bufptr++);
3580 fprintf(stderr, "] (%s)\n", str);
3582 /* Indirections are never packed */
3583 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
3585 /* Add to queue for processing
3586 When just printing the packet we do not have an unpacked closure
3587 in hand, so we feed it the packet entry;
3588 again, this assumes that at least the fixed header of the closure
3589 has the same layout in the packet; also we may not overwrite entries
3590 in the packet (done in Unpack), but for printing that's a bad idea
3592 QueueClosure((StgClosure *)closure_start);
3594 /* No Common up needed for printing */
3596 /* No Sort out the global address mapping for printing */
3598 } /* normal closure case */
3600 /* Locate next parent pointer */
3602 while (pptr + 1 > pptrs) {
3603 parent = DeQueueClosure();
3608 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
3613 } while (parent != NULL);
3614 fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
3615 packBuffer->id, packBuffer->size, size);
3620 Doing a sanity check on a packet.
3621 This does a full iteration over the packet, as in PrintPacket.
3623 //@cindex checkPacket
3625 checkPacket(packBuffer)
3626 rtsPackBuffer *packBuffer;
3628 StgClosure *parent, *graphroot, *closure_start;
3629 const StgInfoTable *ip;
3631 StgWord **buffer, **bufptr, **slotptr;
3634 nat pptr = 0, pptrs = 0, pvhs;
3636 nat size, ptrs, nonptrs, vhs;
3639 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3640 unpacking components replaced by printing fcts
3641 Long live higher-order fcts!
3643 /* Initialisation */
3644 //InitPackBuffer(); /* in case it isn't already init'd */
3646 // ASSERT(gaga==PendingGABuffer);
3647 graphroot = (StgClosure *)NULL;
3649 /* Unpack the header */
3650 bufsize = packBuffer->size;
3651 bufptr = packBuffer->buffer;
3652 parent = (StgClosure *)NULL;
3653 ASSERT(bufsize > 0);
3655 /* This is where we will ultimately save the closure's address */
3657 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3658 ASSERT(locn<=bufsize);
3660 /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
3661 ga.weight = (rtsWeight) *bufptr++;
3662 if (ga.weight > 0) {
3663 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3664 ga.payload.gc.slot = (int) *bufptr++;
3666 ga.payload.plc = (StgPtr) *bufptr++;
3668 /* Now unpack the closure body, if there is one */
3671 ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
3672 } else if (isOffset(&ga)) {
3673 ASSERT(ga.payload.gc.slot<=bufsize);
3675 /* normal closure */
3676 ASSERT(LOOKS_LIKE_GA(&ga));
3678 closure_start = bufptr;
3679 ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
3680 ip = get_closure_info((StgClosure *)bufptr,
3681 &size, &ptrs, &nonptrs, &vhs, str);
3683 /* ToDo: check whether this is really needed */
3684 if (ip->type == FETCH_ME) {
3686 ptrs = nonptrs = vhs = 0;
3688 /* ToDo: check whether this is really needed */
3689 if (ip->type == ARR_WORDS) {
3691 nonptrs = ((StgArrWords *)bufptr)->words+1; // payload+words
3692 size = arr_words_sizeW((StgArrWords *)bufptr);
3693 ASSERT(size==_HS+vhs+nonptrs);
3695 /* special code for printing a PAP in a buffer */
3696 if (ip->type == PAP || ip->type == AP_UPD) {
3699 nonptrs = ((StgPAP *)bufptr)->payload[0];
3700 size = _HS+vhs+ptrs+nonptrs;
3703 /* no checks on contents of closure (pointers aren't packed anyway) */
3704 ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
3705 bufptr += _HS+vhs+nonptrs;
3707 /* Add to queue for processing */
3708 QueueClosure((StgClosure *)closure_start);
3710 /* No Common up needed for checking */
3712 /* No Sort out the global address mapping for checking */
3714 } /* normal closure case */
3716 /* Locate next parent pointer */
3718 while (pptr + 1 > pptrs) {
3719 parent = DeQueueClosure();
3724 //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
3725 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
3730 } while (parent != NULL);
3731 /* we unpacked exactly as many words as there are in the buffer */
3732 ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
3737 rtsPackBuffer *buffer;
3739 // extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
3740 // extern char *display_info_type(P_ infoptr); /* defined in Threads.lc */
3743 nat size, ptrs, nonptrs, vhs;
3744 char info_hdr_ty[80];
3745 char str1[80], str2[80], junk_str[80];
3747 /* globalAddr ga; */
3749 nat bufsize, unpacked_size ;
3751 nat pptr = 0, pptrs = 0, pvhs;
3753 nat unpack_locn = 0;
3754 nat gastart = unpack_locn;
3755 nat closurestart = unpack_locn;
3758 StgClosure *closure, *p;
3762 fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
3763 fprintf(stderr, " size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
3764 buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
3765 fputs(" contents: ", stderr);
3766 for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
3767 closure = buffer->buffer[unpack_locn];
3768 fprintf(stderr, ", %p (%s)",
3769 closure, info_type(closure));
3771 fputc('\n', stderr);
3774 /* traverse all elements of the graph; omitted for now, but might be usefule */
3779 /* Unpack the header */
3780 unpacked_size = buffer->unpacked_size;
3781 bufsize = buffer->size;
3783 fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
3784 buffer, bufsize, unpacked_size,
3785 tso->id, tso, where_is((StgClosure*)tso));
3788 closurestart = unpack_locn;
3789 closure = buffer->buffer[unpack_locn++];
3791 fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
3793 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
3795 fprintf(stderr, "(%s|%s) ", str1, str2);
3797 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
3798 IS_BLACK_HOLE(closure))
3799 size = ptrs = nonptrs = vhs = 0;
3801 if (closure_THUNK(closure)) {
3802 if (closure_UNPOINTED(closure))
3803 fputs("UNPOINTED ", stderr);
3805 fputs("POINTED ", stderr);
3807 if (IS_BLACK_HOLE(closure)) {
3808 fputs("BLACK HOLE\n", stderr);
3811 fprintf(stderr, "FH [");
3812 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
3813 fprintf(stderr, " %p", *p);
3817 fprintf(stderr, "] VH [%p", closure->payload[_HS]);
3819 for (i = 1; i < vhs; i++)
3820 fprintf(stderr, " %p", closure->payload[_HS+i]);
3823 fprintf(stderr, "] PTRS %u", ptrs);
3827 fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
3829 for (i = 1; i < nonptrs; i++)
3830 fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
3836 } while (unpack_locn<bufsize) ; /* (parent != NULL); */
3838 fprintf(stderr, "--- End ---\n\n");
3842 #endif /* DEBUG || GRAN_CHECK */
3844 #endif /* PAR || GRAN -- whole file */
3846 //@node End of file, , Printing Packet Contents, Graph packing
3847 //@subsection End of file
3850 //* AllocateHeap:: @cindex\s-+AllocateHeap
3851 //* AmPacking:: @cindex\s-+AmPacking
3852 //* CommonUp:: @cindex\s-+CommonUp
3853 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
3854 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
3855 //* DonePacking:: @cindex\s-+DonePacking
3856 //* FillInClosure:: @cindex\s-+FillInClosure
3857 //* IS_BLACK_HOLE:: @cindex\s-+IS_BLACK_HOLE
3858 //* IS_INDIRECTION:: @cindex\s-+IS_INDIRECTION
3859 //* InitClosureQueue:: @cindex\s-+InitClosureQueue
3860 //* InitPendingGABuffer:: @cindex\s-+InitPendingGABuffer
3861 //* LocateNextParent:: @cindex\s-+LocateNextParent
3862 //* NotYetPacking:: @cindex\s-+NotYetPacking
3863 //* OffsetFor:: @cindex\s-+OffsetFor
3864 //* Pack:: @cindex\s-+Pack
3865 //* PackArray:: @cindex\s-+PackArray
3866 //* PackClosure:: @cindex\s-+PackClosure
3867 //* PackFetchMe:: @cindex\s-+PackFetchMe
3868 //* PackGeneric:: @cindex\s-+PackGeneric
3869 //* PackNearbyGraph:: @cindex\s-+PackNearbyGraph
3870 //* PackOneNode:: @cindex\s-+PackOneNode
3871 //* PackPAP:: @cindex\s-+PackPAP
3872 //* PackPLC:: @cindex\s-+PackPLC
3873 //* PackStkO:: @cindex\s-+PackStkO
3874 //* PackTSO:: @cindex\s-+PackTSO
3875 //* PendingGABuffer:: @cindex\s-+PendingGABuffer
3876 //* PrintPacket:: @cindex\s-+PrintPacket
3877 //* QueueClosure:: @cindex\s-+QueueClosure
3878 //* QueueEmpty:: @cindex\s-+QueueEmpty
3879 //* RoomToPack:: @cindex\s-+RoomToPack
3880 //* SetGAandCommonUp:: @cindex\s-+SetGAandCommonUp
3881 //* UnpackGA:: @cindex\s-+UnpackGA
3882 //* UnpackGraph:: @cindex\s-+UnpackGraph
3883 //* UnpackOffset:: @cindex\s-+UnpackOffset
3884 //* UnpackPLC:: @cindex\s-+UnpackPLC
3885 //* doGlobalGC:: @cindex\s-+doGlobalGC
3886 //* get_closure_info:: @cindex\s-+get_closure_info
3887 //* InitPackBuffer:: @cindex\s-+initPackBuffer
3888 //* isFixed:: @cindex\s-+isFixed
3889 //* isOffset:: @cindex\s-+isOffset
3890 //* offsetTable:: @cindex\s-+offsetTable