2 Time-stamp: <2009-12-02 12:26:34 simonmar>
4 Graph packing and unpacking code for sending it to another processor
5 and retrieving the original graph structure from the packet.
6 In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
7 Used in GUM and GrAnSim.
9 The GrAnSim version of the code defines routines for *simulating* the
10 packing of closures in the same way it is done in the parallel runtime
11 system. Basically GrAnSim only puts the addresses of the closures to be
12 transferred into a buffer. This buffer will then be associated with the
13 event of transferring the graph. When this event is scheduled, the
14 @UnpackGraph@ routine is called and the buffer can be discarded
17 Note that in GranSim we need many buffers, not just one per PE.
20 //@node Graph packing, , ,
21 //@section Graph packing
23 #if defined(PAR) || defined(GRAN) /* whole file */
28 //* Global variables::
29 //* ADT of Closure Queues::
30 //* Initialisation for packing::
31 //* Packing Functions::
32 //* Low level packing routines::
33 //* Unpacking routines::
34 //* Aux fcts for packing::
35 //* Printing Packet Contents::
40 //@node Includes, Prototypes, Graph packing, Graph packing
41 //@subsection Includes
46 #include "ClosureTypes.h"
50 #include "GranSimRts.h"
51 #include "ParallelRts.h"
53 # include "sm/Sanity.h"
55 # include "ParallelDebug.h"
59 /* Which RTS flag should be used to get the size of the pack buffer ? */
61 # define RTS_PACK_BUFFER_SIZE RtsFlags.ParFlags.packBufferSize
63 # define RTS_PACK_BUFFER_SIZE RtsFlags.GranFlags.packBufferSize
66 //@node Prototypes, Global variables, Includes, Graph packing
67 //@subsection Prototypes
72 //@node ADT of closure queues, Init for packing, Prototypes, Prototypes
73 //@subsubsection ADT of closure queues
75 static inline void InitClosureQueue(void);
76 static inline rtsBool QueueEmpty(void);
77 static inline void QueueClosure(StgClosure *closure);
78 static inline StgClosure *DeQueueClosure(void);
80 //@node Init for packing, Packing routines, ADT of closure queues, Prototypes
81 //@subsubsection Init for packing
83 static void InitPacking(rtsBool unpack);
85 rtsBool InitPackBuffer(void);
87 rtsPackBuffer *InstantiatePackBuffer (void);
88 static void reallocPackBuffer (void);
91 //@node Packing routines, Low level packing fcts, Init for packing, Prototypes
92 //@subsubsection Packing routines
94 static void PackClosure (StgClosure *closure);
96 //@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
97 //@subsubsection Low level packing fcts
100 static void Pack (StgClosure *data);
102 static void Pack (StgWord data);
104 static void PackGeneric(StgClosure *closure);
105 static void PackArray(StgClosure *closure);
106 static void PackPLC (StgPtr addr);
107 static void PackOffset (int offset);
108 static void PackPAP(StgPAP *pap);
109 static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
110 static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
111 static void PackFetchMe(StgClosure *closure);
113 static void GlobaliseAndPackGA (StgClosure *closure);
116 //@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
117 //@subsubsection Unpacking routines
120 void InitPendingGABuffer(nat size);
121 void CommonUp(StgClosure *src, StgClosure *dst);
122 static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure,
124 static nat FillInClosure(StgWord ***bufptrP, StgClosure *graph);
125 static void LocateNextParent(StgClosure **parentP,
126 nat *pptrP, nat *pptrsP, nat *sizeP);
127 StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
130 static StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP,
132 static StgWord **UnpackGA(StgWord **bufptr, globalAddr *ga);
133 static StgClosure *UnpackOffset(globalAddr *ga);
134 static StgClosure *UnpackPLC(globalAddr *ga);
135 static void UnpackArray(StgWord ***bufptrP, StgClosure *graph);
136 static nat UnpackPAP(StgWord ***bufptrP, StgClosure *graph);
139 void CommonUp(StgClosure *src, StgClosure *dst);
140 StgClosure *UnpackGraph(rtsPackBuffer* buffer);
143 //@node Aux fcts for packing, , Unpacking routines, Prototypes
144 //@subsubsection Aux fcts for packing
147 static void DonePacking(void);
148 static void AmPacking(StgClosure *closure);
149 static int OffsetFor(StgClosure *closure);
150 static rtsBool NotYetPacking(int offset);
151 static inline rtsBool RoomToPack (nat size, nat ptrs);
152 static inline rtsBool isOffset(globalAddr *ga);
153 static inline rtsBool isFixed(globalAddr *ga);
154 static inline rtsBool isConstr(globalAddr *ga);
155 static inline rtsBool isUnglobalised(globalAddr *ga);
157 static void DonePacking(void);
158 static rtsBool NotYetPacking(StgClosure *closure);
161 //@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
162 //@subsection Global variables
164 Static data declarations
167 static nat pack_locn, /* ptr to first free loc in pack buffer */
169 buf_id = 1; /* identifier for buffer */
170 static nat unpacked_size;
171 static rtsBool roomInBuffer;
173 static GlobalTaskId dest_gtid=0; /* destination for message to send */
178 To be pedantic: in GrAnSim we're packing *addresses* of closures,
179 not the closures themselves.
181 static rtsPackBuffer *globalPackBuffer = NULL, /* for packing a graph */
182 *globalUnpackBuffer = NULL; /* for unpacking a graph */
186 Bit of a hack for testing if a closure is the root of the graph. This is
187 set in @PackNearbyGraph@ and tested in @PackClosure@.
190 static nat packed_thunks = 0;
191 static StgClosure *graph_root;
195 The offset hash table is used during packing to record the location in
196 the pack buffer of each closure which is packed.
198 //@cindex offsetTable
199 static HashTable *offsetTable;
201 //@cindex PendingGABuffer
202 static globalAddr *PendingGABuffer, *gaga;
207 //@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
208 //@subsection ADT of Closure Queues
216 //@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
217 //@subsubsection Closure Queues
221 These routines manage the closure queue.
224 static nat clq_pos, clq_size;
226 static StgClosure **ClosureQueue = NULL; /* HWL: init in main */
229 static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
232 //@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
233 //@subsubsection Init routines
235 /* @InitClosureQueue@ allocates and initialises the closure queue. */
237 //@cindex InitClosureQueue
239 InitClosureQueue(void)
241 clq_pos = clq_size = 0;
243 if (ClosureQueue==NULL)
244 ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE,
248 //@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
249 //@subsubsection Basic routines
252 QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
256 static inline rtsBool
259 return(clq_pos >= clq_size);
262 /* QueueClosure adds its argument to the closure queue. */
264 //@cindex QueueClosure
266 QueueClosure(closure)
269 if(clq_size < RTS_PACK_BUFFER_SIZE ) {
270 IF_PAR_DEBUG(paranoia,
271 belch(">__> <<%d>> Q: %p (%s); %d elems in q",
272 globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
273 ClosureQueue[clq_size++] = closure;
275 barf("Closure Queue Overflow (EnQueueing %p (%s))",
276 closure, info_type(closure));
280 /* DeQueueClosure returns the head of the closure queue. */
282 //@cindex DeQueueClosure
283 static inline StgClosure *
287 IF_PAR_DEBUG(paranoia,
288 belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
289 globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]),
291 return(ClosureQueue[clq_pos++]);
293 return((StgClosure*)NULL);
297 /* DeQueueClosure returns the head of the closure queue. */
300 //@cindex PrintQueueClosure
302 PrintQueueClosure(void)
306 fputs("Closure queue:", stderr);
307 for (i=clq_pos; i < clq_size; i++)
308 fprintf(stderr, "%p (%s), ",
309 (StgClosure *)ClosureQueue[clq_pos++],
310 info_type(ClosureQueue[clq_pos++]));
315 //@node Types of Global Addresses, , Basic routines, ADT of Closure Queues
316 //@subsubsection Types of Global Addresses
319 Types of Global Addresses
321 These routines determine whether a GA is one of a number of special types
327 static inline rtsBool
328 isOffset(globalAddr *ga)
330 return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
334 static inline rtsBool
335 isFixed(globalAddr *ga)
337 return (ga->weight == 0U);
341 static inline rtsBool
342 isConstr(globalAddr *ga)
344 return (ga->weight == 2U);
347 //@cindex isUnglobalised
348 static inline rtsBool
349 isUnglobalised(globalAddr *ga)
351 return (ga->weight == 2U);
355 //@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
356 //@subsection Initialisation for packing
358 Simple Packing Routines
360 About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
361 gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
362 words. In the simulated PackBuffer we only keep the addresses of the
363 closures that would be packed in the parallel system (see Pack). To
364 decide if a packet overflow occurs pack_buffer_size must be compared
365 versus unpacked_size (see RoomToPack). Currently, there is no multi
366 packet strategy implemented, so in the case of an overflow we just stop
367 adding closures to the closure queue. If an overflow of the simulated
368 packet occurs, we just realloc some more space for it and carry on as
374 InstantiatePackBuffer (void) {
375 extern rtsPackBuffer *globalPackBuffer;
377 globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
378 "InstantiatePackBuffer: failed to alloc packBuffer");
379 globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
380 globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
381 "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
382 /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
383 /* stgMallocWords is now simple allocate in Storage.c */
385 return (globalPackBuffer);
389 Reallocate the GranSim internal pack buffer to make room for more closure
390 pointers. This is independent of the check for packet overflow as in GUM
393 reallocPackBuffer (void) {
395 ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
397 IF_GRAN_DEBUG(packBuffer,
398 belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
399 globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
400 CurrentProc, CurrentTime[CurrentProc]));
402 globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer,
403 sizeof(StgClosure*)*(REALLOC_SZ +
404 (int)globalPackBuffer->size +
405 sizeofW(rtsPackBuffer))) ;
406 if (globalPackBuffer==(rtsPackBuffer*)NULL)
407 barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n",
408 REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
410 globalPackBuffer->size += REALLOC_SZ;
412 ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
417 /* @initPacking@ initialises the packing buffer etc. */
418 //@cindex InitPackBuffer
422 if (globalPackBuffer==(rtsPackBuffer*)NULL) {
423 if ((globalPackBuffer = (rtsPackBuffer *)
424 stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
425 "InitPackBuffer")) == NULL)
432 //@cindex InitPacking
434 InitPacking(rtsBool unpack)
437 globalPackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
438 /* NB: free in UnpackGraph */
441 /* allocate a GA-to-GA map (needed for ACK message) */
442 InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
444 /* allocate memory to pack the graph into */
448 /* init queue of closures seen during packing */
454 globalPackBuffer->id = buf_id++; /* buffer id are only used for debugging! */
455 pack_locn = 0; /* the index into the actual pack buffer */
456 unpacked_size = 0; /* the size of the whole graph when unpacked */
457 roomInBuffer = rtsTrue;
458 packed_thunks = 0; /* total number of thunks packed so far */
460 offsetTable = allocHashTable();
464 //@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
465 //@subsection Packing Functions
468 //* Packing Sections of Nearby Graph::
469 //* Packing Closures::
472 //@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
473 //@subsubsection Packing Sections of Nearby Graph
475 Packing Sections of Nearby Graph
477 @PackNearbyGraph@ packs a closure and associated graph into a static
478 buffer (@PackBuffer@). It returns the address of this buffer and the
479 size of the data packed into the buffer (in its second parameter,
480 @packBufferSize@). The associated graph is packed in a depth first
481 manner, hence it uses an explicit queue of closures to be packed rather
482 than simply using a recursive algorithm. Once the packet is full,
483 closures (other than primitive arrays) are packed as FetchMes, and their
484 children are not queued for packing. */
486 //@cindex PackNearbyGraph
488 /* NB: this code is shared between GranSim and GUM;
489 tso only used in GranSim */
491 PackNearbyGraph(closure, tso, packBufferSize, dest)
498 graphFingerPrint[0] = '\0');
500 ASSERT(RTS_PACK_BUFFER_SIZE > 0);
501 ASSERT(_HS==1); // HWL HACK; compile time constant
503 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
504 PAR_TICKY_PACK_NEARBY_GRAPH_START();
507 /* ToDo: check that we have enough heap for the packet
509 if (Hp + PACK_HEAP_REQUIRED > HpLim)
512 InitPacking(rtsFalse);
514 dest_gtid=dest; //-1 to disable
516 graph_root = closure;
520 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n demanded by TSO %d (%p) [PE %u]",
521 globalPackBuffer->id, globalPackBuffer, closure, where_is(closure),
522 tso->id, tso, where_is((StgClosure*)tso)));
525 belch("** PrintGraph of %p is:", closure);
526 PrintGraph(closure,0));
529 GraphFingerPrint(closure, graphFingerPrint);
530 ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
531 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n demanded by TSO %d (%p); Finger-print is\n {%s}",
532 globalPackBuffer->id, globalPackBuffer, closure, mytid,
533 tso->id, tso, graphFingerPrint));
536 belch("** PrintGraph of %p is:", closure);
537 belch("** pack_locn=%d", pack_locn);
538 PrintGraph(closure,0));
540 QueueClosure(closure);
542 PackClosure(DeQueueClosure());
543 } while (!QueueEmpty());
547 /* Record how much space the graph needs in packet and in heap */
548 globalPackBuffer->tso = tso; // currently unused, I think (debugging?)
549 globalPackBuffer->unpacked_size = unpacked_size;
550 globalPackBuffer->size = pack_locn;
552 /* Check for buffer overflow (again) */
553 ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
554 IF_DEBUG(sanity, // write magic end-of-buffer word
555 globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
556 *packBufferSize = pack_locn;
560 /* Record how much space is needed to unpack the graph */
561 // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG; for testing
562 globalPackBuffer->tso = tso;
563 globalPackBuffer->unpacked_size = unpacked_size;
565 // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
566 /* ToDo: Print an earlier, more meaningful message */
567 if (pack_locn==0) /* i.e. packet is empty */
568 barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
570 globalPackBuffer->size = pack_locn;
571 *packBufferSize = pack_locn;
575 DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
579 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
580 globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
581 if (RtsFlags.GranFlags.GranSimStats.Global) {
582 globalGranStats.tot_packets++;
583 globalGranStats.tot_packet_size += pack_locn;
586 IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
589 belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
590 globalPackBuffer->id, closure, info_type(closure),
591 globalPackBuffer->size, packed_thunks,
592 globalPackBuffer->unpacked_size));;
594 IF_DEBUG(sanity, // do a sanity check on the packet just constructed
595 checkPacket(globalPackBuffer));
598 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
599 PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
602 return (globalPackBuffer);
605 //@cindex PackOneNode
608 /* This version is used when the node is already local */
611 PackOneNode(closure, tso, packBufferSize)
616 extern rtsPackBuffer *globalPackBuffer;
619 InitPacking(rtsFalse);
622 belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
623 closure, info_type(closure),
624 where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
628 /* Record how much space is needed to unpack the graph */
629 globalPackBuffer->tso = tso;
630 globalPackBuffer->unpacked_size = unpacked_size;
632 /* Set the size parameter */
633 ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
634 globalPackBuffer->size = pack_locn;
635 *packBufferSize = pack_locn;
637 if (RtsFlags.GranFlags.GranSimStats.Global) {
638 globalGranStats.tot_packets++;
639 globalGranStats.tot_packet_size += pack_locn;
642 PrintPacket(globalPackBuffer));
644 return (globalPackBuffer);
651 PackTSO and PackStkO are entry points for two special kinds of closure
652 which are used in the parallel RTS. Compared with other closures they
653 are rather awkward to pack because they don't follow the normal closure
654 layout (where all pointers occur before all non-pointers). Luckily,
655 they're only needed when migrating threads between processors. */
659 PackTSO(tso, packBufferSize)
663 extern rtsPackBuffer *globalPackBuffer;
665 belch("** Packing TSO %d (%p)", tso->id, tso));
667 // PackBuffer[0] = PackBuffer[1] = 0; ???
668 return(globalPackBuffer);
672 static rtsPackBuffer*
673 PackStkO(stko, packBufferSize)
677 extern rtsPackBuffer *globalPackBuffer;
679 belch("** Packing STKO %p", stko));
681 // PackBuffer[0] = PackBuffer[1] = 0;
682 return(globalPackBuffer);
686 PackFetchMe(StgClosure *closure)
688 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
693 static rtsPackBuffer*
694 PackTSO(tso, packBufferSize)
698 barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
699 tso->id, tso, packBufferSize);
703 PackStkO(stko, packBufferSize)
707 barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
708 stko, packBufferSize);
711 //@cindex PackFetchMe
713 PackFetchMe(StgClosure *closure)
723 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
725 offset = OffsetFor(closure);
726 if (!NotYetPacking(offset)) {
728 belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
729 closure, info_type(closure), offset));
731 // unpacked_size += 0; // unpacked_size unchanged (closure is shared!!)
735 /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
737 /* FMs must be always globalised */
738 GlobaliseAndPackGA(closure);
741 belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
742 closure, info_type(closure),
743 globalPackBuffer->buffer[pack_locn-2],
744 globalPackBuffer->buffer[pack_locn-1],
745 globalPackBuffer->buffer[pack_locn-3]));
747 /* Pack a FetchMe closure instead of closure */
748 ip = &stg_FETCH_ME_info;
749 /* this assumes that the info ptr is always the first word in a closure*/
751 for (i = 1; i < _HS; ++i) // pack rest of fixed header
752 Pack((StgWord)*(((StgPtr)closure)+i));
754 unpacked_size += sizeofW(StgFetchMe);
755 /* size of FETCHME in packed is the same as that constant */
756 ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
757 /* In the pack buffer the pointer to a GA (in the FetchMe closure)
758 is expanded to the full GA; this is a compile-time const */
759 //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
767 PackRemoteRef(StgClosure *closure)
773 offset = OffsetFor(closure);
774 if (!NotYetPacking(offset)) {
780 /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
783 /* basically we just Globalise, but for sticky things we can't have multiple GAs,
784 so we must prevent the GAs being split.
786 In returning things to the true sticky owner, this case is already handled, but for
787 anything else we just give up at the moment... This needs to be fixed!
790 ga = LAGAlookup(closure); // surely this ga must exist?
792 // ***************************************************************************
793 // ***************************************************************************
794 // REMOTE_REF HACK - dual is in SetGAandCommonUp
795 // - prevents the weight from ever reaching zero
797 ga->weight=0x06660666; //anything apart from 0 really...
798 // ***************************************************************************
799 // ***************************************************************************
801 if((ga != NULL)&&(ga->weight / 2 <= 2))
802 barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
803 closure, info_type(closure),
804 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);
806 GlobaliseAndPackGA(closure);
809 belch("*>.. Packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
810 closure, info_type(closure),
811 globalPackBuffer->buffer[pack_locn-2],
812 globalPackBuffer->buffer[pack_locn-1],
813 globalPackBuffer->buffer[pack_locn-3]));
815 /* Pack a REMOTE_REF closure instead of closure */
816 ip = &stg_REMOTE_REF_info;
817 /* this assumes that the info ptr is always the first word in a closure*/
819 for (i = 1; i < _HS; ++i) // pack rest of fixed header
820 Pack((StgWord)*(((StgPtr)closure)+i));
822 unpacked_size += PACK_FETCHME_SIZE;
826 //@node Packing Closures, , Packing Sections of Nearby Graph, Packing Functions
827 //@subsubsection Packing Closures
831 @PackClosure@ is the heart of the normal packing code. It packs a single
832 closure into the pack buffer, skipping over any indirections and
833 globalising it as necessary, queues any child pointers for further
834 packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
835 locally if it was a thunk. Before the actual closure is packed, a
836 suitable global address (GA) is inserted in the pack buffer. There is
837 always room to pack a fetch-me to the closure (guaranteed by the
838 RoomToPack calculation), and this is packed if there is no room for the
841 Space is allocated for any primitive array children of a closure, and
842 hence a primitive array can always be packed along with it's parent
845 //@cindex PackClosure
856 ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
858 closure = UNWIND_IND(closure);
859 /* now closure is the thing we want to pack */
860 info = get_itbl(closure);
862 clpack_locn = OffsetFor(closure);
864 /* If the closure has been packed already, just pack an indirection to it
865 to guarantee that the graph doesn't become a tree when unpacked */
866 if (!NotYetPacking(clpack_locn)) {
867 PackOffset(clpack_locn);
871 switch (info->type) {
873 case CONSTR_CHARLIKE:
875 belch("*>^^ Packing a charlike closure %d",
876 ((StgIntCharlikeClosure*)closure)->data));
878 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
879 // NB: unpacked_size of a PLC is 0
884 StgInt val = ((StgIntCharlikeClosure*)closure)->data;
886 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
888 belch("*>^^ Packing a small intlike %d as a PLC",
890 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
891 // NB: unpacked_size of a PLC is 0
895 belch("*>^^ Packing a big intlike %d as a normal closure",
897 PackGeneric(closure);
908 /* it's a constructor (i.e. plain data) */
910 belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
911 closure, info_type(closure)));
912 PackGeneric(closure);
915 case THUNK_STATIC: // ToDo: check whether that's ok
916 case FUN_STATIC: // ToDo: check whether that's ok
918 case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
919 // evaluated on each PE if needed
921 belch("*>~~ Packing a %p (%s) as a PLC",
922 closure, info_type(closure)));
924 PackPLC((StgPtr)closure);
925 // NB: unpacked_size of a PLC is 0
930 StgClosure *selectee = ((StgSelector *)closure)->selectee;
933 belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
934 closure, info_type(closure),
935 selectee, info_type(selectee)));
936 PackGeneric(closure);
937 /* inlined code; probably could use PackGeneric
938 Pack((StgWord)(*(StgPtr)closure));
939 Pack((StgWord)(selectee));
940 QueueClosure(selectee);
958 PackGeneric(closure);
964 barf("*> Packing of PAP not implemented %p (%s)",
965 closure, info_type(closure));
967 Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
968 instead. Note that since PAPs contain a chunk of stack as payload,
969 implementing packing of PAPs is a first step towards thread migration.
971 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
972 closure, info_type(closure)));
973 PackFetchMe(closure);
975 PackPAP((StgPAP *)closure);
982 case SE_CAF_BLACKHOLE:
987 /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
988 //ASSERT(pack_locn > PACK_HDR_SIZE);
991 belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
992 closure, info_type(closure)));
993 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
994 phps short-cut the GA here */
995 PackFetchMe(closure);
1001 belch("*>.. Packing %p (%s) as a REMOTE_REF",
1002 closure, info_type(closure)));
1003 PackRemoteRef(closure);
1004 /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
1013 belch("*>.. Packing %p (%s) as a RemoteRef",
1014 closure, info_type(closure)));
1015 PackRemoteRef(closure);
1017 barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)",
1018 closure, info_type(closure));
1027 case MUT_ARR_PTRS_FROZEN:
1030 Eventually, this should use the same packing routine as ARR_WRODS
1032 GlobaliseAndPackGA(closure);
1036 barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
1037 closure, info_type(closure));
1041 barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
1042 closure, info_type(closure));
1045 // check error cases only in a debugging setup
1052 barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
1053 closure, info_type(closure));
1060 barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
1061 closure, info_type(closure));
1066 /* something's very wrong */
1067 barf("{Pack}Daq Qagh: found %s (%p) when packing",
1068 info_type(closure), closure);
1074 case IND_OLDGEN_PERM:
1076 barf("Pack: found IND_... after shorting out indirections %d (%s)",
1077 (nat)(info->type), info_type(closure));
1082 barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
1083 (nat)(info->type), info_type(closure));
1087 barf("Pack: strange closure %d", (nat)(info->type));
1092 Pack a constructor of unknown size.
1093 Similar to PackGeneric but without creating GAs.
1096 //@cindex PackConstr
1098 PackConstr(StgClosure *closure)
1101 nat size, ptrs, nonptrs, vhs, i;
1104 ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
1106 /* get info about basic layout of the closure */
1107 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1109 ASSERT(info->type == CONSTR ||
1110 info->type == CONSTR_1_0 ||
1111 info->type == CONSTR_0_1 ||
1112 info->type == CONSTR_2_0 ||
1113 info->type == CONSTR_1_1 ||
1114 info->type == CONSTR_0_2);
1117 fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1118 closure, info_type(closure), size, ptrs, nonptrs));
1120 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1122 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1124 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1125 closure, info_type(closure)));
1126 PackFetchMe(closure);
1130 /* Record the location of the GA */
1133 /* Pack Constructor marker */
1136 /* pack fixed and variable header */
1137 for (i = 0; i < _HS + vhs; ++i)
1138 Pack((StgWord)*(((StgPtr)closure)+i));
1140 /* register all ptrs for further packing */
1141 for (i = 0; i < ptrs; ++i)
1142 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1145 for (i = 0; i < nonptrs; ++i)
1146 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1151 Generic packing code.
1152 This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
1154 //@cindex PackGeneric
1156 PackGeneric(StgClosure *closure)
1160 nat size, ptrs, nonptrs, vhs, i, m;
1163 ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
1165 /* get info about basic layout of the closure */
1166 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1168 ASSERT(!IS_BLACK_HOLE(closure));
1171 fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
1172 closure, info_type(closure), size, ptrs, nonptrs));
1174 /* packing strategies: how many thunks to add to a packet;
1175 default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
1176 if (RtsFlags.ParFlags.thunksToPack &&
1177 packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
1178 closure_THUNK(closure)) {
1180 belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
1181 packed_thunks, closure, info_type(closure)));
1182 PackFetchMe(closure);
1186 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1188 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1190 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1191 closure, info_type(closure)));
1192 PackFetchMe(closure);
1196 /* Record the location of the GA */
1198 /* Allocate a GA for this closure and put it into the buffer */
1199 /* Checks for globalisation scheme; default: globalise everything thunks */
1200 if ( RtsFlags.ParFlags.globalising == 0 ||
1201 (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1202 GlobaliseAndPackGA(closure);
1204 Pack((StgWord)2); // marker for unglobalised closure
1207 ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1208 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1210 /* At last! A closure we can actually pack! */
1211 if (ip_MUTABLE(info) && ((info->type != FETCH_ME)||(info->type != REMOTE_REF)))
1212 barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
1213 closure, info_type(closure));
1216 Remember, the generic closure layout is as follows:
1217 +-------------------------------------------------+
1218 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1219 +-------------------------------------------------+
1221 /* pack fixed and variable header */
1222 for (i = 0; i < _HS + vhs; ++i)
1223 Pack((StgWord)*(((StgPtr)closure)+i));
1225 /* register all ptrs for further packing */
1226 for (i = 0; i < ptrs; ++i)
1227 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1230 for (i = 0; i < nonptrs; ++i)
1231 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1233 // ASSERT(_HS+vhs+ptrs+nonptrs==size);
1234 if ((m=_HS+vhs+ptrs+nonptrs)<size) {
1236 belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
1237 closure, info_type(closure), size-m));
1238 for (i=m; i<size; i++)
1239 Pack((StgWord)*(((StgPtr)closure)+i));
1242 unpacked_size += size;
1243 //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1246 * Record that this is a revertable black hole so that we can fill in
1247 * its address from the fetch reply. Problem: unshared thunks may cause
1248 * space leaks this way, their GAs should be deallocated following an
1252 if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
1253 rbh = convertToRBH(closure);
1254 ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
1255 ASSERT(rbh == closure); // rbh at the same position (minced version)
1257 } else if ( closure==graph_root ) {
1258 packed_thunks++; // root of graph is counted as a thunk
1262 Pack an array of words.
1263 ToDo: implement packing of MUT_ARRAYs
1268 PackArray(StgClosure *closure)
1271 nat size, ptrs, nonptrs, vhs;
1275 /* get info about basic layout of the closure */
1276 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1278 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1279 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
1281 n = arr_words_words(((StgArrWords *)closure));
1282 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
1285 belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
1286 closure, info_type(closure), n,
1287 arr_words_sizeW((StgArrWords *)closure)));
1289 /* check that we have enough room in the pack buffer */
1290 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1292 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1293 closure, info_type(closure)));
1294 PackFetchMe(closure);
1298 /* global stats about arrays sent */
1299 if (RtsFlags.ParFlags.ParStats.Global &&
1300 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
1301 globalParStats.tot_arrs++;
1302 globalParStats.tot_arr_size += arr_words_words(((StgArrWords *)closure));
1305 /* record offset of the closure and allocate a GA */
1307 /* Checks for globalisation scheme; default: globalise everything thunks */
1308 if ( RtsFlags.ParFlags.globalising == 0 ||
1309 (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1310 GlobaliseAndPackGA(closure);
1312 Pack((StgWord)2); // marker for unglobalised closure
1314 /* Pack the header (2 words: info ptr and the number of words to follow) */
1315 Pack((StgWord)*(StgPtr)closure);
1316 Pack(arr_words_words(((StgArrWords *)closure)));
1318 /* pack the payload of the closure (all non-ptrs) */
1320 Pack((StgWord)((StgArrWords *)closure)->payload[i]);
1322 unpacked_size += arr_words_sizeW((StgArrWords *)closure);
1327 Note that the representation of a PAP in the buffer is different from
1328 its representation in the heap. In particular, pointers to local
1329 closures are packed directly as FETCHME closures, using
1330 PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
1331 structure. To account for the difference in size we store the packed
1332 size of the closure as part of the PAP's variable header in the buffer.
1337 PackPAP(StgPAP *pap) {
1338 nat n, i, j, pack_start;
1340 const StgInfoTable* info;
1342 /* debugging only */
1344 nat size, ptrs, nonptrs, vhs;
1346 nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
1348 /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
1349 //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
1350 ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
1352 unpacked_size_before_PAP = unpacked_size);
1354 n = (nat)(pap->n_args);
1356 /* get info about basic layout of the closure */
1357 info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
1358 ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
1361 belch("*>** %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:",
1362 (StgClosure *)pap, info_type((StgClosure *)pap),
1363 n, size, ptrs, nonptrs);
1364 printClosure((StgClosure *)pap));
1366 /* check that we have enough room in the pack buffer */
1367 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1369 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1370 (StgClosure *)pap, info_type((StgClosure *)pap)));
1371 PackFetchMe((StgClosure *)pap);
1375 /* record offset of the closure and allocate a GA */
1376 AmPacking((StgClosure *)pap);
1377 /* Checks for globalisation scheme; default: globalise everything thunks */
1378 if ( RtsFlags.ParFlags.globalising == 0 ||
1379 (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
1380 GlobaliseAndPackGA((StgClosure *)pap);
1382 Pack((StgWord)2); // marker for unglobalised closure
1384 /* Pack the PAP header */
1385 Pack((StgWord)(pap->header.info));
1386 Pack((StgWord)(pap->n_args));
1387 Pack((StgWord)(pap->fun));
1388 pack_start = pack_locn; // to compute size of PAP in buffer
1389 Pack((StgWord)0); // this will be filled in later (size of PAP in buffer)
1391 /* Pack the payload of a PAP i.e. a stack chunk */
1392 /* pointers to start of stack chunk */
1393 p = (StgPtr)(pap->payload);
1394 end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
1396 /* the loop body has been borrowed from scavenge_stack */
1399 /* If we've got a tag, pack all words in that block */
1400 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
1401 nat m = ARG_TAG((W_)q); // first word after this block
1403 belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
1405 for (i=0; i<m+1; i++)
1406 Pack((StgWord)*(p+i));
1407 p += m+1; // m words + the tag
1411 /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
1412 ToDo: provide RTS flag to also pack these closures
1414 if (! LOOKS_LIKE_GHC_INFO(q) ) {
1415 /* distinguish static closure (PLC) from other closures (FM) */
1416 switch (get_itbl((StgClosure*)q)->type) {
1417 case CONSTR_CHARLIKE:
1419 belch("*>** PackPAP: packing a charlike closure %d",
1420 ((StgIntCharlikeClosure*)q)->data));
1422 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
1426 case CONSTR_INTLIKE:
1428 StgInt val = ((StgIntCharlikeClosure*)q)->data;
1430 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
1432 belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1433 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1438 belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
1440 Pack((StgWord)(ARGTAG_MAX+1));
1441 PackFetchMe((StgClosure *)q);
1443 IF_DEBUG(sanity, FMs_in_PAP++);
1447 case THUNK_STATIC: // ToDo: check whether that's ok
1448 case FUN_STATIC: // ToDo: check whether that's ok
1450 case CONSTR_NOCAF_STATIC:
1453 belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
1454 q, info_type((StgClosure *)q)));
1462 belch("*>** PackPAP @ %p: packing FM to %p (%s)",
1463 p, q, info_type((StgClosure*)q)));
1464 Pack((StgWord)(ARGTAG_MAX+1));
1465 PackFetchMe((StgClosure *)q);
1467 IF_DEBUG(sanity, FMs_in_PAP++);
1474 * Otherwise, q must be the info pointer of an activation
1475 * record. All activation records have 'bitmap' style layout
1478 info = get_itbl((StgClosure *)p);
1479 switch (info->type) {
1481 /* Dynamic bitmap: the mask is stored on the stack */
1484 belch("*>** PackPAP @ %p: RET_DYN",
1487 /* Pack the header as is */
1488 Pack((StgWord)(((StgRetDyn *)p)->info));
1489 Pack((StgWord)(((StgRetDyn *)p)->liveness));
1490 Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
1492 bitmap = ((StgRetDyn *)p)->liveness;
1493 p = (P_)&((StgRetDyn *)p)->payload[0];
1496 /* probably a slow-entry point return address: */
1501 belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
1504 Pack((StgWord)(((StgClosure *)p)->header.info));
1507 goto follow_srt; //??
1510 /* Using generic code here; could inline as in scavenge_stack */
1513 StgUpdateFrame *frame = (StgUpdateFrame *)p;
1514 nat type = get_itbl(frame->updatee)->type;
1516 ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
1519 belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
1520 p, frame->updatee, frame->link));
1522 Pack((StgWord)(frame->header.info));
1523 Pack((StgWord)(frame->link)); // ToDo: fix intra-stack pointer
1524 Pack((StgWord)(frame->updatee)); // ToDo: follow link
1529 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1533 belch("*>** PackPAP @ %p: STOP_FRAME",
1535 Pack((StgWord)((StgStopFrame *)p)->header.info);
1542 belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
1543 p, ((StgCatchFrame *)p)->handler));
1545 Pack((StgWord)((StgCatchFrame *)p)->header.info);
1546 Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
1547 Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
1548 Pack((StgWord)((StgCatchFrame *)p)->handler);
1555 belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
1556 p, ((StgSeqFrame *)p)->link));
1558 Pack((StgWord)((StgSeqFrame *)p)->header.info);
1559 Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
1561 // ToDo: handle bitmap
1562 bitmap = info->layout.bitmap;
1564 p = (StgPtr)&(((StgClosure *)p)->payload);
1571 belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
1572 p, info->layout.bitmap));
1575 Pack((StgWord)((StgClosure *)p)->header.info);
1577 // ToDo: handle bitmap
1578 bitmap = info->layout.bitmap;
1579 /* this assumes that the payload starts immediately after the info-ptr */
1582 while (bitmap != 0) {
1583 if ((bitmap & 1) == 0) {
1584 Pack((StgWord)(ARGTAG_MAX+1));
1585 PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1586 IF_DEBUG(sanity, FMs_in_PAP++);
1588 Pack((StgWord)*p++);
1590 bitmap = bitmap >> 1;
1595 belch("*>-- PackPAP: nothing to do for follow_srt"));
1598 /* large bitmap (> 32 entries) */
1603 StgLargeBitmap *large_bitmap;
1606 belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
1607 p, info->layout.large_bitmap));
1610 Pack((StgWord)((StgClosure *)p)->header.info);
1613 large_bitmap = info->layout.large_bitmap;
1615 for (j=0; j<large_bitmap->size; j++) {
1616 bitmap = large_bitmap->bitmap[j];
1617 q = p + BITS_IN(W_);
1618 while (bitmap != 0) {
1619 if ((bitmap & 1) == 0) {
1620 Pack((StgWord)(ARGTAG_MAX+1));
1621 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1622 IF_DEBUG(sanity, FMs_in_PAP++);
1624 Pack((StgWord)*p++);
1626 bitmap = bitmap >> 1;
1628 if (j+1 < large_bitmap->size) {
1630 Pack((StgWord)(ARGTAG_MAX+1));
1631 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1632 IF_DEBUG(sanity, FMs_in_PAP++);
1637 /* and don't forget to follow the SRT */
1642 barf("PackPAP: weird activation record found on stack (@ %p): %d",
1643 p, (int)(info->type));
1646 // fill in size of the PAP (only the payload!) in buffer
1647 globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1649 We can use the generic pap_sizeW macro to compute the size of the
1650 unpacked PAP because whenever we pack a new FETCHME as part of the
1651 PAP's payload we also adjust unpacked_size accordingly (smart, aren't we?)
1653 NB: the current PAP (un-)packing code relies on the fact that
1654 the size of the unpacked PAP + size of all unpacked FMs is the same as
1655 the size of the packed PAP!!
1657 unpacked_size += pap_sizeW(pap); // sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
1659 ASSERT(unpacked_size-unpacked_size_before_PAP==pap_sizeW(pap)+FMs_in_PAP*sizeofW(StgFetchMe)));
1663 /* Fake the packing of a closure */
1666 PackClosure(closure)
1667 StgClosure *closure;
1669 StgInfoTable *info, *childInfo;
1670 nat size, ptrs, nonptrs, vhs;
1671 char info_hdr_ty[80];
1673 StgClosure *indirectee, *rbh;
1675 rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
1677 is_mutable = rtsFalse;
1679 /* In GranSim we don't pack and unpack closures -- we just simulate
1680 packing by updating the bitmask. So, the graph structure is unchanged
1681 i.e. we don't short out indirections here. -- HWL */
1683 /* Nothing to do with packing but good place to (sanity) check closure;
1684 if the closure is a thunk, it must be unique; otherwise we have copied
1685 work at some point before that which violates one of our main global
1686 assertions in GranSim/GUM */
1687 ASSERT(!closure_THUNK(closure) || is_unique(closure));
1690 belch("** Packing closure %p (%s)",
1691 closure, info_type(closure)));
1693 if (where_is(closure) != where_is(graph_root)) {
1695 belch("** faking a FETCHME [current PE: %d, closure's PE: %d]",
1696 where_is(graph_root), where_is(closure)));
1698 /* GUM would pack a FETCHME here; simulate that by increasing the */
1699 /* unpacked size accordingly but don't pack anything -- HWL */
1700 unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
1704 /* If the closure's not already being packed */
1705 if (!NotYetPacking(closure))
1706 /* Don't have to do anything in GrAnSim if closure is already */
1710 belch("** Closure %p is already packed and omitted now!",
1715 switch (get_itbl(closure)->type) {
1716 /* ToDo: check for sticky bit here? */
1717 /* BH-like closures which must not be moved to another PE */
1718 case CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1719 case SE_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1720 case SE_CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1721 case BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1722 case BLACKHOLE_BQ: /* # of ptrs, nptrs: 1,1 */
1723 case RBH: /* # of ptrs, nptrs: 1,1 */
1724 /* same for these parallel specific closures */
1729 belch("** Avoid packing BH-like closures (%p, %s)!",
1730 closure, info_type(closure)));
1731 /* Just ignore RBHs i.e. they stay where they are */
1734 case THUNK_SELECTOR:
1736 StgClosure *selectee = ((StgSelector *)closure)->selectee;
1739 belch("** Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
1740 closure, info_type(closure), selectee, info_type(selectee)));
1741 QueueClosure(selectee);
1743 belch("** [%p (%s) (Queueing closure) ....]",
1744 selectee, info_type(selectee)));
1749 case CONSTR_NOCAF_STATIC:
1750 /* For now we ship indirections to CAFs:
1751 * They are evaluated on each PE if needed */
1753 belch("** Nothing to pack for %p (%s)!",
1754 closure, info_type(closure)));
1755 // Pack(closure); GUM only
1758 case CONSTR_CHARLIKE:
1759 case CONSTR_INTLIKE:
1761 belch("** Nothing to pack for %s (%p)!",
1762 closure, info_type(closure)));
1763 // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1768 /* partial applications; special treatment necessary? */
1772 barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1773 closure, info_type(closure));
1778 case MUT_ARR_PTRS_FROZEN:
1779 /* Mutable objects; require special treatment to ship all data */
1780 is_mutable = rtsTrue;
1786 /* weak pointers and other FFI objects */
1787 barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1788 closure, info_type(closure));
1791 /* parallel objects */
1792 barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1793 closure, info_type(closure));
1796 /* Hugs objects (i.e. closures used by the interpreter) */
1797 barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1798 closure, info_type(closure));
1800 case IND: /* # of ptrs, nptrs: 1,0 */
1801 case IND_STATIC: /* # of ptrs, nptrs: 1,0 */
1802 case IND_PERM: /* # of ptrs, nptrs: 1,1 */
1803 case IND_OLDGEN: /* # of ptrs, nptrs: 1,1 */
1804 case IND_OLDGEN_PERM: /* # of ptrs, nptrs: 1,1 */
1805 /* we shouldn't find an indirection here, because we have shorted them
1806 out at the beginning of this functions already.
1810 barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1811 closure, info_type(closure));
1818 /* stack frames; should never be found when packing for now;
1819 once we support thread migration these have to be covered properly
1821 barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1822 closure, info_type(closure));
1830 /* vectored returns; should never be found when packing; */
1831 barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1832 closure, info_type(closure));
1834 case INVALID_OBJECT:
1835 barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1836 closure, info_type(closure));
1840 Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1841 a specialised version with wired in #ptr/#nptr info; currently
1842 we treat these specialised versions like the generic version)
1846 /* Otherwise it's not Fixed */
1848 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1849 will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1852 belch("** Info on closure %p (%s): size=%d; ptrs=%d",
1853 closure, info_type(closure),
1855 (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1857 // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1858 no_more_thunks_please =
1859 (RtsFlags.GranFlags.ThunksToPack>0) &&
1860 (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1863 should be covered by get_closure_info
1864 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1865 info->type == BLACKHOLE || info->type == RBH )
1866 size = ptrs = nonptrs = vhs = 0;
1868 /* Now peek ahead to see whether the closure has any primitive */
1869 /* array children */
1872 for (i = 0; i < ptrs; ++i) {
1874 W_ childSize, childPtrs, childNonPtrs, childVhs;
1876 childInfo = get_closure_info(((StgPtrPtr) (closure))[i + _HS + vhs],
1877 &childSize, &childPtrs, &childNonPtrs,
1878 &childVhs, junk_str);
1879 if (IS_BIG_MOTHER(childInfo)) {
1880 reservedPAsize += PACK_GA_SIZE + _HS +
1881 childVhs + childNonPtrs +
1882 childPtrs * PACK_FETCHME_SIZE;
1883 PAsize += PACK_GA_SIZE + _HS + childSize;
1884 PAptrs += childPtrs;
1888 /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1889 * is full and it isn't a primitive array. N.B. Primitive arrays are
1890 * always packed (because their parents index into them directly) */
1892 if (IS_BLACK_HOLE(closure))
1896 !(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)
1897 || IS_BIG_MOTHER(info)))
1901 /* At last! A closure we can actually pack! */
1903 if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1904 belch("ghuH: Replicated a Mutable closure!");
1906 if (RtsFlags.GranFlags.GranSimStats.Global &&
1907 no_more_thunks_please && will_be_rbh) {
1908 globalGranStats.tot_cuts++;
1909 if ( RtsFlags.GranFlags.Debug.pack )
1910 belch("** PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1911 RtsFlags.GranFlags.ThunksToPack, closure);
1912 } else if (will_be_rbh || (closure==graph_root) ) {
1914 globalGranStats.tot_thunks++;
1917 if (no_more_thunks_please && will_be_rbh)
1918 return; /* don't pack anything */
1920 /* actual PACKING done here -- HWL */
1922 for (i = 0; i < ptrs; ++i) {
1923 /* extract i-th pointer from closure */
1924 QueueClosure((StgClosure *)(closure->payload[i]));
1926 belch("** [%p (%s) (Queueing closure) ....]",
1927 closure->payload[i],
1928 info_type(*stgCast(StgPtr*,((closure)->payload+(i))))));
1929 //^^^^^^^^^^^ payloadPtr(closure,i))));
1933 for packing words (GUM only) do something like this:
1935 for (i = 0; i < ptrs; ++i) {
1936 Pack(payloadWord(obj,i+j));
1939 /* Turn thunk into a revertible black hole. */
1941 rbh = convertToRBH(closure);
1942 ASSERT(rbh != NULL);
1947 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1948 //@subsection Low level packing routines
1951 @Pack@ is the basic packing routine. It just writes a word of data into
1952 the pack buffer and increments the pack location. */
1961 ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1962 globalPackBuffer->buffer[pack_locn++] = data;
1969 StgClosure *closure;
1972 nat size, ptrs, nonptrs, vhs;
1975 /* This checks the size of the GrAnSim internal pack buffer. The simulated
1976 pack buffer is checked via RoomToPack (as in GUM) */
1977 if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
1978 reallocPackBuffer();
1980 if (closure==(StgClosure*)NULL)
1981 belch("Qagh {Pack}Daq: Trying to pack 0");
1982 globalPackBuffer->buffer[pack_locn++] = closure;
1983 /* ASSERT: Data is a closure in GrAnSim here */
1984 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1985 // ToDo: is check for MIN_UPD_SIZE really needed? */
1986 unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1993 If a closure is local, make it global. Then, divide its weight for
1994 export. The GA is then packed into the pack buffer. */
1997 //@cindex GlobaliseAndPackGA
1999 GlobaliseAndPackGA(closure)
2000 StgClosure *closure;
2005 if ((ga = LAGAlookup(closure)) == NULL) {
2006 ga = makeGlobal(closure, rtsTrue);
2008 // Global statistics: increase amount of global data by closure-size
2009 if (RtsFlags.ParFlags.ParStats.Global &&
2010 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2012 nat size, ptrs, nonptrs, vhs, i, m; // stats only!!
2013 char str[80]; // stats only!!
2015 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
2016 globalParStats.tot_global += size;
2019 ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
2021 if(dest_gtid==ga->payload.gc.gtid)
2022 { packGA.payload = ga->payload;
2023 packGA.weight = 0xFFFFFFFF; // 0,1,2 are used already
2026 { splitWeight(&packGA, ga);
2027 ASSERT(packGA.weight > 0);
2031 fprintf(stderr, "*>## %p (%s): Globalising (%s) closure with GA ",
2032 closure, info_type(closure),
2033 ( (ga->payload.gc.gtid==dest_gtid)?"returning":
2034 ( (ga->payload.gc.gtid==mytid)?"creating":"sharing" ) ));
2036 fputc('\n', stderr));
2039 Pack((StgWord) packGA.weight);
2040 Pack((StgWord) packGA.payload.gc.gtid);
2041 Pack((StgWord) packGA.payload.gc.slot);
2045 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
2046 address follows instead of PE, slot. */
2054 Pack(0L); /* weight */
2055 Pack((StgWord) addr); /* address */
2059 @PackOffset@ packs a special GA value that will be interpreted as an
2060 offset to a closure in the pack buffer. This is used to avoid unfolding
2061 the graph structure into a tree. */
2069 belch("** Packing Offset %d at pack location %u",
2070 offset, pack_locn));
2072 Pack(1L); /* weight */
2074 Pack(offset); /* slot/offset */
2078 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
2079 //@subsection Unpacking routines
2082 This was formerly in the (now deceased) module Unpack.c
2084 Unpacking closures which have been exported to remote processors
2086 This module defines routines for unpacking closures in the parallel
2087 runtime system (GUM).
2089 In the case of GrAnSim, this module defines routines for *simulating* the
2090 unpacking of closures as it is done in the parallel runtime system.
2093 //@node GUM code, GranSim Code, Unpacking routines, Unpacking routines
2094 //@subsubsection GUM code
2098 //@cindex InitPendingGABuffer
2100 InitPendingGABuffer(size)
2103 if (PendingGABuffer==(globalAddr *)NULL)
2104 PendingGABuffer = (globalAddr *)
2105 stgMallocBytes(size*2*sizeof(globalAddr),
2106 "InitPendingGABuffer");
2108 /* current location in the buffer */
2109 gaga = PendingGABuffer;
2113 @CommonUp@ commons up two closures which we have discovered to be
2114 variants of the same object. One is made an indirection to the other. */
2118 CommonUp(StgClosure *src, StgClosure *dst)
2120 StgBlockingQueueElement *bqe;
2123 nat size, ptrs, nonptrs, vhs, i;
2126 /* get info about basic layout of the closure */
2127 info = get_closure_info(src, &size, &ptrs, &nonptrs, &vhs, str);
2130 ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
2134 belch("*___ CommonUp %p (%s) --> %p (%s)",
2135 src, info_type(src), dst, info_type(dst)));
2137 switch (get_itbl(src)->type) {
2139 bqe = ((StgBlockingQueue *)src)->blocking_queue;
2143 bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
2147 bqe = ((StgRBH *)src)->blocking_queue;
2155 /* These closures are too small to be updated with an indirection!!! */
2158 ASSERT(size<_HS+MIN_UPD_SIZE); // that's why we have to avoid UPD_IND
2161 /* currently we also common up 2 CONSTRs; this should reduce heap
2162 * consumption but also does more work; not sure whether it's worth doing
2170 case MUT_ARR_PTRS_FROZEN:
2175 /* Don't common up anything else */
2179 /* closure must be big enough to permit update with ind */
2180 ASSERT(size>=_HS+MIN_UPD_SIZE);
2181 /* NB: this also awakens the blocking queue for src */
2186 * Common up the new closure with any existing closure having the same
2189 //@cindex SetGAandCommonUp
2191 SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
2193 StgClosure *existing;
2194 StgInfoTable *ip, *oldip;
2200 /* should we already have a local copy? */
2201 if (ga->weight==0xFFFFFFFF) {
2202 ASSERT(ga->payload.gc.gtid==mytid); //sanity
2204 /* probably should also ASSERT that a commonUp takes place...*/
2207 ip = get_itbl(closure);
2208 if ((existing = GALAlookup(ga)) == NULL) {
2209 /* Just keep the new object */
2211 belch("*<## New local object for GA ((%x, %d, %x)) is %p (%s)",
2212 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2213 closure, info_type(closure)));
2215 // make an entry binding closure to ga in the RemoteGA table
2216 newGA = setRemoteGA(closure, ga, rtsTrue);
2217 // if local closure is a FETCH_ME etc fill in the global indirection
2218 if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
2219 ((StgFetchMe *)closure)->ga = newGA;
2224 // ***************************************************************************
2225 // ***************************************************************************
2226 // REMOTE_REF HACK - dual is in PackRemoteRef
2227 // - prevents the weight ever being updated
2228 if (ip->type == REMOTE_REF)
2230 // ***************************************************************************
2231 // ***************************************************************************
2234 /* Two closures, one global name. Someone loses */
2235 oldip = get_itbl(existing);
2236 if ((oldip->type == FETCH_ME ||
2237 IS_BLACK_HOLE(existing) ||
2238 /* try to share evaluated closures */
2239 oldip->type == CONSTR ||
2240 oldip->type == CONSTR_1_0 ||
2241 oldip->type == CONSTR_0_1 ||
2242 oldip->type == CONSTR_2_0 ||
2243 oldip->type == CONSTR_1_1 ||
2244 oldip->type == CONSTR_0_2
2246 ip->type != FETCH_ME)
2249 belch("*<#- Duplicate local object for GA ((%x, %d, %x)); redirecting %p (%s) -> %p (%s)",
2250 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2251 existing, info_type(existing), closure, info_type(closure)));
2254 * What we had wasn't worth keeping, so make the old closure an
2255 * indirection to the new closure (copying BQs if necessary) and
2256 * make sure that the old entry is not the preferred one for this
2259 CommonUp(existing, closure);
2260 //GALAdeprecate(ga);
2264 nat size, ptrs, nonptrs, vhs, i;
2267 /* get info about basic layout of the closure */
2268 info = get_closure_info(GALAlookup(ga), &size, &ptrs, &nonptrs, &vhs, str);
2270 /* now ga indirectly refers to the new closure */
2271 ASSERT(size<_HS+MIN_UPD_SIZE ||
2272 UNWIND_IND(GALAlookup(ga))==closure);
2277 * Either we already had something worthwhile by this name or
2278 * the new thing is just another FetchMe. However, the thing we
2279 * just unpacked has to be left as-is, or the child unpacking
2280 * code will fail. Remember that the way pointer words are
2281 * filled in depends on the info pointers of the parents being
2282 * the same as when they were packed.
2285 belch("*<#@ Duplicate local object for GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
2286 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2287 existing, info_type(existing), closure, info_type(closure)));
2289 /* overwrite 2nd word; indicates that the closure is garbage */
2291 ((StgFetchMe*)closure)->ga = (globalAddr*)GARBAGE_MARKER;
2293 belch("++++ unpacked closure %p (%s) is garbage: %p",
2294 closure, info_type(closure), *(closure+1))));
2299 ty = get_itbl(closure)->type;
2306 CommonUp(closure, graph);
2309 /* We don't use this GA after all, so give back the weight */
2310 (void) addWeight(ga);
2313 /* if we have unpacked a FETCH_ME, we have a GA, too */
2314 ASSERT(get_itbl(closure)->type!=FETCH_ME ||
2315 looks_like_ga(((StgFetchMe*)closure)->ga));
2317 /* Sort out the global address mapping */
2319 // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
2320 //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
2321 /* Make up new GAs for single-copy closures */
2322 globalAddr *newGA = makeGlobal(closure, rtsTrue);
2324 // It's a new GA and therefore has the full weight
2325 ASSERT(newGA->weight==0);
2327 /* Create an old GA to new GA mapping */
2329 splitWeight(gaga, newGA);
2330 /* inlined splitWeight; we know that newGALA has full weight
2331 newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
2332 gaga->payload = newGA->payload;
2334 ASSERT(gaga->weight == 1U << (BITS_IN(unsigned) - 1));
2341 Copies a segment of the buffer, starting at @bufptr@, representing a closure
2342 into the heap at @graph@.
2344 //@cindex FillInClosure
2346 FillInClosure(StgWord ***bufptrP, StgClosure *graph)
2349 StgWord **bufptr = *bufptrP;
2350 nat ptrs, nonptrs, vhs, i, size;
2353 ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
2356 * Close your eyes. You don't want to see where we're looking. You
2357 * can't get closure info until you've unpacked the variable header,
2358 * but you don't know how big it is until you've got closure info.
2359 * So...we trust that the closure in the buffer is organized the
2360 * same way as they will be in the heap...at least up through the
2361 * end of the variable header.
2363 ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2365 /* Make sure that nothing sans the fixed header is filled in
2366 The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
2367 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
2368 ASSERT(size>=_HS+MIN_UPD_SIZE); // size of the FM in the heap
2369 ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
2371 /* ToDo: check whether this is really needed */
2372 if (ip->type == ARR_WORDS) {
2373 UnpackArray(bufptrP, graph);
2374 return arr_words_sizeW((StgArrWords *)bufptr);
2377 if (ip->type == PAP || ip->type == AP_UPD) {
2378 return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
2382 Remember, the generic closure layout is as follows:
2383 +-------------------------------------------------+
2384 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2385 +-------------------------------------------------+
2387 /* Fill in the fixed header */
2388 for (i = 0; i < _HS; i++)
2389 ((StgPtr)graph)[i] = (StgWord)*bufptr++;
2391 /* Fill in the packed variable header */
2392 for (i = 0; i < vhs; i++)
2393 ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
2395 /* Pointers will be filled in later */
2397 /* Fill in the packed non-pointers */
2398 for (i = 0; i < nonptrs; i++)
2399 ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
2401 /* Indirections are never packed */
2402 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2405 ASSERT(((ip->type==FETCH_ME || ip->type==REMOTE_REF)&& sizeofW(StgFetchMe)==size) ||
2406 _HS+vhs+ptrs+nonptrs == size);
2411 Find the next pointer field in the parent closure.
2412 If the current parent has been completely unpacked already, get the
2413 next closure from the global closure queue.
2415 //@cindex LocateNextParent
2417 LocateNextParent(parentP, pptrP, pptrsP, sizeP)
2418 StgClosure **parentP;
2419 nat *pptrP, *pptrsP, *sizeP;
2421 StgInfoTable *ip; // debugging
2425 /* pptr as an index into the current parent; find the next pointer field
2426 in the parent by increasing pptr; if that takes us off the closure
2427 (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
2430 while (*pptrP + 1 > *pptrsP) {
2431 /* *parentP has been constructed (all pointer set); so check it now */
2433 if ((*parentP!=(StgClosure*)NULL) && // not root
2434 (*((StgPtr)(*parentP)+1)!=GARBAGE_MARKER) && // not commoned up
2435 (get_itbl(*parentP)->type != FETCH_ME))
2436 checkClosure(*parentP));
2438 *parentP = DeQueueClosure();
2440 if (*parentP == NULL)
2443 ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
2448 /* *parentP points to the new (or old) parent; */
2449 /* *pptr, *pptrs and *size have been updated referring to the new parent */
2453 UnpackClosure is the heart of the unpacking routine. It is called for
2454 every closure found in the packBuffer. Any prefix such as GA, PLC marker
2455 etc has been unpacked into the *ga structure.
2456 UnpackClosure does the following:
2457 - check for the kind of the closure (PLC, Offset, std closure)
2458 - copy the contents of the closure from the buffer into the heap
2459 - update LAGA tables (in particular if we end up with 2 closures
2460 having the same GA, we make one an indirection to the other)
2461 - set the GAGA map in order to send back an ACK message
2463 At the end of this function *graphP has been updated to point to the
2464 next free word in the heap for unpacking the rest of the graph and
2465 *bufptrP points to the next word in the pack buffer to be unpacked.
2469 UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
2470 StgClosure *closure;
2472 rtsBool hasGA = rtsFalse, unglobalised = rtsFalse;
2474 /* Now unpack the closure body, if there is one; three cases:
2475 - PLC: closure is just a pointer to a static closure
2476 - Offset: closure has been unpacked already
2477 - else: copy data from packet into closure
2480 closure = UnpackPLC(ga);
2481 } else if (isOffset(ga)) {
2482 closure = UnpackOffset(ga);
2484 /* if not PLC or Offset it must be a GA and then the closure */
2485 ASSERT(RtsFlags.ParFlags.globalising!=0 || LOOKS_LIKE_GA(ga));
2486 /* check whether this is an unglobalised closure */
2487 unglobalised = isUnglobalised(ga);
2488 /* Now we have to build something. */
2489 hasGA = !isConstr(ga);
2490 /* the new closure will be built here */
2493 /* fill in the closure from the buffer */
2494 size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
2495 /* if it is unglobalised, it may not be a thunk!! */
2496 ASSERT(!unglobalised || !closure_THUNK(closure));
2498 /* Add to queue for processing */
2499 QueueClosure(closure);
2501 /* common up with other graph if necessary */
2503 closure = SetGAandCommonUp(ga, closure, hasGA);
2505 /* if we unpacked a THUNK, check that it is large enough to update */
2506 ASSERT(!closure_THUNK(closure) || size>=_HS+MIN_UPD_SIZE);
2507 /* graph shall point to next free word in the heap */
2509 //*graphP += (size < _HS+MIN_UPD_SIZE) ? _HS+MIN_UPD_SIZE : size; // see ASSERT
2515 @UnpackGraph@ unpacks the graph contained in a message buffer. It
2516 returns a pointer to the new graph. The @gamap@ parameter is set to
2517 point to an array of (oldGA,newGA) pairs which were created as a result
2518 of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
2521 The format of graph in the pack buffer is as defined in @Pack.lc@. */
2523 //@cindex UnpackGraph
2525 UnpackGraph(packBuffer, gamap, nGAs)
2526 rtsPackBuffer *packBuffer;
2530 StgWord **bufptr, **slotptr;
2532 StgClosure *closure, *graphroot, *graph, *parent;
2533 nat size, heapsize, bufsize,
2534 pptr = 0, pptrs = 0, pvhs = 0;
2535 nat unpacked_closures = 0, unpacked_thunks = 0; // stats only
2537 IF_PAR_DEBUG(resume,
2538 graphFingerPrint[0] = '\0');
2540 ASSERT(_HS==1); // HWL HACK; compile time constant
2542 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2543 PAR_TICKY_UNPACK_GRAPH_START();
2546 /* Initialisation */
2547 InitPacking(rtsTrue); // same as in PackNearbyGraph
2548 globalUnpackBuffer = packBuffer;
2550 IF_DEBUG(sanity, // do a sanity check on the incoming packet
2551 checkPacket(packBuffer));
2553 ASSERT(gaga==PendingGABuffer);
2554 graphroot = (StgClosure *)NULL;
2556 /* Unpack the header */
2557 bufsize = packBuffer->size;
2558 heapsize = packBuffer->unpacked_size;
2559 bufptr = packBuffer->buffer;
2563 graph = (StgClosure *)allocate(heapsize);
2564 ASSERT(graph != NULL);
2565 // parallel global statistics: increase amount of global data
2566 if (RtsFlags.ParFlags.ParStats.Global &&
2567 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2568 globalParStats.tot_global += heapsize;
2572 /* iterate over the buffer contents and unpack all closures */
2573 parent = (StgClosure *)NULL;
2575 /* check that we aren't at the end of the buffer, yet */
2576 IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
2578 /* This is where we will ultimately save the closure's address */
2581 /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
2582 bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
2584 /* this allocates heap space, updates LAGA tables etc */
2585 closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
2586 unpacked_closures++; // stats only; doesn't count FMs in PAP!!!
2587 unpacked_thunks += (closure_THUNK(closure)) ? 1 : 0; // stats only
2590 * Set parent pointer to point to chosen closure. If we're at the top of
2591 * the graph (our parent is NULL), then we want to arrange to return the
2592 * chosen closure to our caller (possibly in place of the allocated graph
2596 graphroot = closure;
2598 ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
2600 /* Save closure pointer for resolving offsets */
2601 *slotptr = (StgWord*) closure;
2603 /* Locate next parent pointer */
2604 LocateNextParent(&parent, &pptr, &pptrs, &size);
2607 gaS.weight = 0xdeadffff;
2608 gaS.payload.gc.gtid = 0xdead;
2609 gaS.payload.gc.slot = 0xdeadbeef;);
2610 } while (parent != NULL);
2612 IF_PAR_DEBUG(resume,
2613 GraphFingerPrint(graphroot, graphFingerPrint);
2614 ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
2615 belch(">>> Fingerprint of graph rooted at %p (after unpacking <<%d>>:\n {%s}",
2616 graphroot, packBuffer->id, graphFingerPrint));
2618 /* we unpacked exactly as many words as there are in the buffer */
2619 ASSERT(bufsize == (nat) (bufptr-(packBuffer->buffer)));
2620 /* we filled no more heap closure than we allocated at the beginning;
2621 ideally this should be a ==;
2622 NB: test is only valid if we unpacked anything at all (graphroot might
2623 end up to be a PLC!), therfore the strange test for HEAP_ALLOCED
2628 StgInfoTable *info = get_itbl(graphroot);
2629 ASSERT(!HEAP_ALLOCED(graphroot) || heapsize >= (nat) (graph-graphroot) ||
2630 // ToDo: check whether CAFs are really a special case here!!
2631 info->type==CAF_BLACKHOLE || info->type==FETCH_ME || info->type==FETCH_ME_BQ);
2635 /* check for magic end-of-buffer word */
2636 IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
2638 *gamap = PendingGABuffer;
2639 *nGAs = (gaga - PendingGABuffer) / 2;
2641 IF_PAR_DEBUG(tables,
2642 belch("** LAGA table after unpacking closure %p:",
2646 /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
2647 ASSERT(graphroot!=NULL);
2653 /* check the unpacked graph */
2654 //checkHeapChunk(graphroot,graph-sizeof(StgWord));
2656 // if we do sanity checks, then wipe the pack buffer after unpacking
2657 for (p=(StgPtr)packBuffer->buffer; p<(StgPtr)(packBuffer->buffer)+(packBuffer->size); )
2661 /* reset the global variable */
2662 globalUnpackBuffer = (rtsPackBuffer*)NULL;
2664 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2665 PAR_TICKY_UNPACK_GRAPH_END(unpacked_closures, unpacked_thunks);
2673 UnpackGA(StgWord **bufptr, globalAddr *ga)
2675 /* First, unpack the next GA or PLC */
2676 ga->weight = (rtsWeight) *bufptr++;
2678 if (ga->weight == 2) { // unglobalised closure to follow
2679 // nothing to do; closure starts at *bufptr
2680 } else if (ga->weight > 0) { // fill in GA
2681 ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
2682 ga->payload.gc.slot = (int) *bufptr++;
2684 ga->payload.plc = (StgPtr) *bufptr++;
2691 UnpackPLC(globalAddr *ga)
2693 /* No more to unpack; just set closure to local address */
2695 belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
2696 return (StgClosure*)ga->payload.plc;
2699 //@cindex UnpackOffset
2701 UnpackOffset(globalAddr *ga)
2703 /* globalUnpackBuffer is a global var init in UnpackGraph */
2704 ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
2705 /* No more to unpack; just set closure to cached address */
2707 belch("*<__ Unpacked indirection to %p (was OFFSET %d)",
2708 (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
2709 ga->payload.gc.slot));
2710 return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
2714 Input: *bufptrP, *graphP ... ptrs to the pack buffer and into the heap.
2716 *bufptrP points to something that should be unpacked as a FETCH_ME:
2719 +-------------------------------
2721 +-------------------------------
2723 The first 3 words starting at *bufptrP are the GA address; the next
2724 word is the generic FM info ptr followed by the remaining FH (if any)
2725 The result after unpacking will be a FETCH_ME closure, pointed to by
2726 *graphP at the start of the fct;
2729 +------------------------+
2730 | FH of FM | ptr to a GA |
2731 +------------------------+
2733 The ptr field points into the RemoteGA table, which holds the actual GA.
2734 *bufptrP has been updated to point to the next word in the buffer.
2735 *graphP has been updated to point to the first free word at the end.
2739 UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
2740 StgClosure *closure, *foo;
2743 /* This fct relies on size of FM < size of FM in pack buffer */
2744 ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
2746 /* fill in gaS from buffer */
2747 *bufptrP = UnpackGA(*bufptrP, &gaS);
2748 /* might be an offset to a closure in the pack buffer */
2749 if (isOffset(&gaS)) {
2750 belch("*< UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
2751 gaS.payload.gc.slot, *bufptrP);
2753 closure = UnpackOffset(&gaS);
2754 /* return address of previously unpacked closure; leaves *graphP unchanged */
2758 /* we have a proper GA at hand */
2759 ASSERT(LOOKS_LIKE_GA(&gaS));
2763 barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
2764 *bufptrP, info_type((StgClosure*)*bufptrP)));
2767 belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
2770 fputc('\n', stderr));
2772 /* the next thing must be the IP to a FETCH_ME closure */
2773 ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
2776 /* fill in the closure from the buffer */
2777 FillInClosure(bufptrP, closure);
2779 /* the newly built closure is a FETCH_ME */
2780 ASSERT(get_itbl(closure)->type == FETCH_ME);
2782 /* common up with other graph if necessary
2783 this also assigns the contents of gaS to the ga field of the FM closure */
2784 foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
2786 ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
2789 if (foo==closure) { // only if not commoned up
2790 belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
2791 *graphP, *graphP+sizeofW(StgFetchMe), closure);
2792 printClosure(closure);
2794 *graphP += sizeofW(StgFetchMe);
2799 Unpack an array of words.
2800 Could use generic unpack most of the time, but cleaner to separate it.
2801 ToDo: implement packing of MUT_ARRAYs
2804 //@cindex UnackArray
2806 UnpackArray(StgWord ***bufptrP, StgClosure *graph)
2809 StgWord **bufptr=*bufptrP;
2810 nat size, ptrs, nonptrs, vhs, i, n;
2813 /* yes, I know I am paranoid; but who's asking !? */
2815 info = get_closure_info((StgClosure*)bufptr,
2816 &size, &ptrs, &nonptrs, &vhs, str);
2817 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
2818 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
2820 n = arr_words_words(((StgArrWords *)bufptr));
2821 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
2825 belch("*<== unpacking an array of %d words %p (%s) (size=%d) |%s|\n",
2826 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2827 arr_words_sizeW((StgArrWords *)bufptr),
2828 /* print array (string?) */
2829 ((StgArrWords *)graph)->payload);
2831 belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
2832 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2833 arr_words_sizeW((StgArrWords *)bufptr)));
2835 /* Unpack the header (2 words: info ptr and the number of words to follow) */
2836 ((StgArrWords *)graph)->header.info = (StgInfoTable*)*bufptr++; // assumes _HS==1; yuck!
2837 ((StgArrWords *)graph)->bytes = ((StgWord)*bufptr++) * sizeof(StgWord);
2839 /* unpack the payload of the closure (all non-ptrs) */
2841 ((StgArrWords *)graph)->payload[i] = (StgWord)*bufptr++;
2843 ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
2848 Unpack a PAP in the buffer into a heap closure.
2849 For each FETCHME we find in the packed PAP we have to unpack a separate
2850 FETCHME closure and insert a pointer to this closure into the PAP.
2851 We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
2852 Note that the size of a FETCHME in the buffer is exactly the same as
2853 the size of an unpacked FETCHME plus 1 word for the pointer to it.
2854 Therefore, we just allocate packed_size words in the heap for the unpacking.
2855 After this routine the heap starting from *graph looks like this:
2859 v PAP closure | FM area |
2860 +------------------------------------------------------------+
2861 | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
2862 +------------------------------------------------------------+
2864 where payload contains pointers to each of the unpacked FM_1, FM_2 ...
2865 The size of the PAP closure plus all FMs is _HS+2+packed_size.
2870 UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
2872 nat n, i, j, packed_size = 0;
2873 StgPtr p, q, end, payload_start, p_FMs;
2874 const StgInfoTable* info;
2876 StgWord **bufptr = *bufptrP;
2879 void checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end);
2883 belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
2884 *bufptr, *(bufptr+1), graph));
2886 /* Unpack the PAP header (both fixed and variable) */
2887 ((StgPAP *)graph)->header.info = (StgInfoTable*)*bufptr++;
2888 n = ((StgPAP *)graph)->n_args = (StgWord)*bufptr++;
2889 ((StgPAP *)graph)->fun = (StgClosure*)*bufptr++;
2890 packed_size = (nat)*bufptr++;
2893 belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
2894 ((StgPAP *)graph)->header.info,
2895 ((StgPAP *)graph)->n_args,
2896 ((StgPAP *)graph)->fun,
2899 payload_start = (StgPtr)bufptr;
2900 /* p points to the current word in the heap */
2901 p = (StgPtr)((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
2902 p_FMs = (StgPtr)graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
2903 end = (StgPtr) payload_start+packed_size;
2905 The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
2906 FM area for unpacking all FETCHMEs encountered during unpacking.
2908 while ((StgPtr)bufptr<end) {
2909 /* be sure that we don't write more than we allocated for this closure */
2910 ASSERT(p_FMs <= (StgPtr)(graph+_HS+2+packed_size));
2911 /* be sure that the unpacked PAP doesn't run into the FM area */
2912 ASSERT(p < (StgPtr)(graph+pap_sizeW((StgPAP*)graph)));
2913 /* the loop body has been borrowed from scavenge_stack */
2914 q = *bufptr; // let q be the contents of the current pointer into the buffer
2916 /* Test whether the next thing is a FETCH_ME.
2917 In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
2919 if (q==(StgPtr)(ARGTAG_MAX+1)) {
2921 belch("*<** UnpackPAP @ %p: unpacking FM; filling in ptr to FM area: %p",
2923 bufptr++; // skip ARGTAG_MAX+1 marker
2924 // Unpack a FM into the FM area after the PAP proper and insert pointer
2925 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
2926 IF_DEBUG(sanity, FMs_in_PAP++);
2930 /* Test whether it is a PLC */
2931 if (q==(StgPtr)0) { // same as isFixed(q)
2933 belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
2935 bufptr++; // skip 0 marker
2936 *p++ = (StgWord)*bufptr++;
2940 /* If we've got a tag, pack all words in that block */
2941 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
2942 nat m = ARG_SIZE(q); // first word after this block
2944 belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
2946 for (i=0; i<m+1; i++)
2947 *p++ = (StgWord)*bufptr++;
2952 * Otherwise, q must be the info pointer of an activation
2953 * record. All activation records have 'bitmap' style layout
2956 info = get_itbl((StgClosure *)q);
2957 switch (info->type) {
2959 /* Dynamic bitmap: the mask is stored on the stack */
2962 belch("*<** UnpackPAP @ %p: RET_DYN",
2965 /* Pack the header as is */
2966 ((StgRetDyn *)p)->info = (StgWord)*bufptr++;
2967 ((StgRetDyn *)p)->liveness = (StgWord)*bufptr++;
2968 ((StgRetDyn *)p)->ret_addr = (StgWord)*bufptr++;
2971 //bitmap = ((StgRetDyn *)p)->liveness;
2972 //p = (P_)&((StgRetDyn *)p)->payload[0];
2975 /* probably a slow-entry point return address: */
2980 belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
2983 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr;
2986 goto follow_srt; //??
2989 /* Using generic code here; could inline as in scavenge_stack */
2992 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2993 //nat type = get_itbl(frame->updatee)->type;
2995 //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
2998 belch("*<** UnackPAP @ %p: UPDATE_FRAME",
3001 ((StgUpdateFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3002 ((StgUpdateFrame *)p)->link = (StgUpdateFrame*)*bufptr++; // ToDo: fix intra-stack pointer
3003 ((StgUpdateFrame *)p)->updatee = (StgClosure*)*bufptr++; // ToDo: follow link
3008 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
3012 belch("*<** UnpackPAP @ %p: STOP_FRAME",
3014 ((StgStopFrame *)p)->header.info = (StgInfoTable*)*bufptr;
3021 belch("*<** UnpackPAP @ %p: CATCH_FRAME",
3024 ((StgCatchFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3025 ((StgCatchFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
3026 ((StgCatchFrame *)p)->exceptions_blocked = (StgInt)*bufptr++;
3027 ((StgCatchFrame *)p)->handler = (StgClosure*)*bufptr++;
3034 belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
3037 ((StgSeqFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3038 ((StgSeqFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
3040 // ToDo: handle bitmap
3041 bitmap = info->layout.bitmap;
3043 p = (StgPtr)&(((StgClosure *)p)->payload);
3050 belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
3054 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3056 // ToDo: handle bitmap
3057 bitmap = info->layout.bitmap;
3058 /* this assumes that the payload starts immediately after the info-ptr */
3061 while (bitmap != 0) {
3062 if ((bitmap & 1) == 0) {
3063 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3064 IF_DEBUG(sanity, FMs_in_PAP++);
3066 *p++ = (StgWord)*bufptr++;
3068 bitmap = bitmap >> 1;
3072 belch("*<-- UnpackPAP: nothing to do for follow_srt");
3075 /* large bitmap (> 32 entries) */
3080 StgLargeBitmap *large_bitmap;
3083 belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
3084 p, info->layout.large_bitmap));
3087 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3090 large_bitmap = info->layout.large_bitmap;
3092 for (j=0; j<large_bitmap->size; j++) {
3093 bitmap = large_bitmap->bitmap[j];
3094 q = p + BITS_IN(W_);
3095 while (bitmap != 0) {
3096 if ((bitmap & 1) == 0) {
3097 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3098 IF_DEBUG(sanity, FMs_in_PAP++);
3100 *p++ = (StgWord)*bufptr;
3102 bitmap = bitmap >> 1;
3104 if (j+1 < large_bitmap->size) {
3106 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3107 IF_DEBUG(sanity, FMs_in_PAP++);
3112 /* and don't forget to follow the SRT */
3117 barf("UnpackPAP: weird activation record found on stack: %d",
3122 belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
3123 (StgClosure *)graph);
3124 printClosure((StgClosure *)graph));
3126 IF_DEBUG(sanity, /* check sanity of unpacked PAP */
3127 checkClosure(graph));
3131 Now p points to the first word after the PAP proper and p_FMs points
3132 to the next free word in the heap; everything between p and p_FMs are
3136 checkPAPSanity(graph, p, p_FMs));
3138 /* we have to return the size of PAP + FMs as size of the unpacked thing */
3139 ASSERT(graph+pap_sizeW((StgPAP*)graph)==p);
3140 return (nat)((StgClosure*)p_FMs-graph);
3145 Check sanity of a PAP after unpacking the PAP.
3146 This means that there is slice of heap after the PAP containing FETCHMEs
3149 checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end)
3153 /* check that the main unpacked closure is a PAP */
3154 ASSERT(graph->header.info = &stg_PAP_info);
3155 checkClosure(graph);
3156 /* check that all of the closures in the FM-area are FETCHMEs */
3157 for (xx=p_FM_begin; xx<p_FM_end; xx += sizeofW(StgFetchMe)) {
3158 /* must be a FETCHME closure */
3159 ASSERT(((StgClosure*)xx)->header.info == &stg_FETCH_ME_info);
3160 /* it might have been commoned up (=> marked as garbage);
3161 otherwise it points to a GA */
3162 ASSERT((((StgFetchMe*)xx)->ga)==GARBAGE_MARKER ||
3163 LOOKS_LIKE_GA(((StgFetchMe*)xx)->ga));
3165 /* traverse the payload of the PAP */
3166 for (xx=graph->payload; xx-(StgPtr)(graph->payload)<graph->n_args; xx++) {
3167 /* if the current elem is a pointer into the FM area, check that
3168 the GA field is ok */
3169 ASSERT(!(p_FM_begin<(StgPtr)*xx && (StgPtr)*xx<p_FM_end) ||
3170 LOOKS_LIKE_GA(((StgFetchMe*)*xx)->ga));
3176 //@node GranSim Code, , GUM code, Unpacking routines
3177 //@subsubsection GranSim Code
3180 For GrAnSim: No actual unpacking should be necessary. We just
3181 have to walk over the graph and set the bitmasks appropriately.
3182 Since we use RBHs similarly to GUM but without an ACK message/event
3183 we have to revert the RBH from within the UnpackGraph routine (good luck!)
3189 CommonUp(StgClosure *src, StgClosure *dst)
3191 barf("CommonUp: should never be entered in a GranSim setup");
3196 rtsPackBuffer* buffer;
3198 nat size, ptrs, nonptrs, vhs,
3200 StgClosure *closure, *graphroot, *graph;
3202 StgWord bufsize, unpackedsize,
3203 pptr = 0, pptrs = 0, pvhs;
3205 char str[240], str1[80];
3209 graphroot = buffer->buffer[0];
3213 /* Unpack the header */
3214 unpackedsize = buffer->unpacked_size;
3215 bufsize = buffer->size;
3218 belch("<<< Unpacking <<%d>> (buffer @ %p):\n (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
3219 buffer->id, buffer, graphroot, where_is(graphroot),
3220 bufsize, tso->id, tso,
3221 where_is((StgClosure *)tso)));
3224 closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
3226 /* Actually only ip is needed; rest is useful for TESTING -- HWL */
3227 ip = get_closure_info(closure,
3228 &size, &ptrs, &nonptrs, &vhs, str);
3231 sprintf(str, "** (%p): Changing bitmask[%s]: 0x%x ",
3232 closure, (closure_HNF(closure) ? "NF" : "__"),
3235 if (get_itbl(closure)->type == RBH) {
3236 /* if it's an RBH, we have to revert it into a normal closure, thereby
3237 awakening the blocking queue; not that this is code currently not
3238 needed in GUM, but it should be added with the new features in
3239 GdH (and the implementation of an NACK message)
3241 // closure->header.gran.procs = PE_NUMBER(CurrentProc);
3242 SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc)); /* Move node */
3245 strcat(str, " (converting RBH) "));
3247 convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
3250 belch(":: closure %p (%s) is a RBH; after reverting: IP=%p",
3251 closure, info_type(closure), get_itbl(closure)));
3252 } else if (IS_BLACK_HOLE(closure)) {
3254 belch(":: closure %p (%s) is a BH; copying node to %d",
3255 closure, info_type(closure), CurrentProc));
3256 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3257 } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
3258 if (closure_HNF(closure)) {
3260 belch(":: closure %p (%s) is a HNF; copying node to %d",
3261 closure, info_type(closure), CurrentProc));
3262 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3265 belch(":: closure %p (%s) is no (R)BH or HNF; moving node to %d",
3266 closure, info_type(closure), CurrentProc));
3267 closure->header.gran.procs = PE_NUMBER(CurrentProc); /* Move node */
3272 sprintf(str1, "0x%x", PROCS(closure)); strcat(str, str1));
3273 IF_GRAN_DEBUG(pack, belch(str));
3275 } while (bufptr<buffer->size) ; /* (parent != NULL); */
3277 /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
3278 free(buffer->buffer);
3282 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
3288 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
3289 //@subsection Aux fcts for packing
3294 //* Types of Global Addresses::
3298 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
3299 //@subsubsection Offset table
3302 DonePacking is called when we've finished packing. It releases memory
3305 //@cindex DonePacking
3312 freeHashTable(offsetTable, NULL);
3317 AmPacking records that the closure is being packed. Note the abuse of
3318 the data field in the hash table -- this saves calling @malloc@! */
3324 StgClosure *closure;
3326 insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
3330 OffsetFor returns an offset for a closure which is already being packed. */
3336 StgClosure *closure;
3338 return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
3342 NotYetPacking determines whether the closure's already being packed.
3343 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no. */
3345 //@cindex NotYetPacking
3348 NotYetPacking(offset)
3351 return(offset == 0); // ToDo: what if root is found again?? FIX
3363 NotYetPacking searches through the whole pack buffer for closure. */
3366 NotYetPacking(closure)
3367 StgClosure *closure;
3369 rtsBool found = rtsFalse;
3371 for (i=0; (i<pack_locn) && !found; i++)
3372 found = globalPackBuffer->buffer[i]==closure;
3378 //@node Packet size, Closure Info, Offset table, Aux fcts for packing
3379 //@subsubsection Packet size
3382 The size needed if all currently queued closures are packed as FETCH_ME
3383 closures. This represents the headroom we must have when packing the
3384 buffer in order to maintain all links in the graphs.
3386 // ToDo: check and merge cases
3389 QueuedClosuresMinSize (nat ptrs) {
3390 return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3394 QueuedClosuresMinSize (nat ptrs) {
3395 return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3400 RoomToPack determines whether there's room to pack the closure into
3401 the pack buffer based on
3403 o how full the buffer is already,
3404 o the closures' size and number of pointers (which must be packed as GAs),
3405 o the size and number of pointers held by any primitive arrays that it
3408 It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
3412 //@cindex RoomToPack
3414 RoomToPack(size, ptrs)
3419 (pack_locn + // where we are in the buffer right now
3420 size + // space needed for the current closure
3421 QueuedClosuresMinSize(ptrs) // space for queued closures as FETCH_MEs
3422 + 1 // headroom (DEBUGGING only)
3424 RTS_PACK_BUFFER_SIZE))
3426 roomInBuffer = rtsFalse;
3432 QueuedClosuresMinSize(ptrs)
3434 RTS_PACK_BUFFER_SIZE))
3436 roomInBuffer = rtsFalse;
3439 return (roomInBuffer);
3442 //@node Closure Info, , Packet size, Aux fcts for packing
3443 //@subsubsection Closure Info
3448 @get_closure_info@ determines the size, number of pointers etc. for this
3449 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
3451 [Can someone please keep this function up to date. I keep needing it
3452 (or something similar) for interpretive code, and it keeps
3453 bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95] */
3457 // {Parallel.h}Daq ngoqvam vIroQpu'
3459 # if defined(GRAN) || defined(PAR)
3460 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
3461 //@cindex get_closure_info
3463 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
3465 nat *size, *ptrs, *nonptrs, *vhs;
3470 info = get_itbl(node);
3471 /* the switch shouldn't be necessary, really; just use default case */
3472 switch (info->type) {
3477 *size = sizeW_fromITBL(info);
3478 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3479 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3480 *vhs = (nat) 0; // unknown
3481 info_hdr_type(node, info_hdr_ty);
3487 *size = sizeW_fromITBL(info);
3488 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3489 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3490 *vhs = (nat) 0; // unknown
3491 info_hdr_type(node, info_hdr_ty);
3497 *size = sizeW_fromITBL(info);
3498 *ptrs = (nat) 2; // (info->layout.payload.ptrs);
3499 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3500 *vhs = (nat) 0; // unknown
3501 info_hdr_type(node, info_hdr_ty);
3507 *size = sizeW_fromITBL(info);
3508 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3509 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3510 *vhs = (nat) 0; // unknown
3511 info_hdr_type(node, info_hdr_ty);
3517 *size = sizeW_fromITBL(info);
3518 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3519 *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
3520 *vhs = (nat) 0; // unknown
3521 info_hdr_type(node, info_hdr_ty);
3526 StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
3527 *size = sizeW_fromITBL(rip);
3528 *ptrs = (nat) (rip->layout.payload.ptrs);
3529 *nonptrs = (nat) (rip->layout.payload.nptrs);
3530 *vhs = (nat) 0; // unknown
3531 info_hdr_type(node, info_hdr_ty);
3532 return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
3536 *size = sizeW_fromITBL(info);
3537 *ptrs = (nat) (info->layout.payload.ptrs);
3538 *nonptrs = (nat) (info->layout.payload.nptrs);
3539 *vhs = (nat) 0; // unknown
3540 info_hdr_type(node, info_hdr_ty);
3545 //@cindex IS_BLACK_HOLE
3547 IS_BLACK_HOLE(StgClosure* node)
3550 info = get_itbl(node);
3551 return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
3554 //@cindex IS_INDIRECTION
3556 IS_INDIRECTION(StgClosure* node)
3559 info = get_itbl(node);
3560 switch (info->type) {
3564 case IND_OLDGEN_PERM:
3566 /* relies on indirectee being at same place for all these closure types */
3567 return (((StgInd*)node) -> indirectee);
3575 IS_THUNK(StgClosure* node)
3578 info = get_itbl(node);
3579 return ((info->type == THUNK ||
3580 info->type == THUNK_STATIC ||
3581 info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
3592 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
3594 W_ *size, *ptrs, *nonptrs, *vhs;
3597 P_ ip = (P_) INFO_PTR(closure);
3599 if (closure==NULL) {
3600 fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
3601 *size = *ptrs = *nonptrs = *vhs = 0;
3602 strcpy(type,"ERROR in get_closure_info");
3604 } else if (closure==PrelBase_Z91Z93_closure) {
3605 /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
3606 *size = *ptrs = *nonptrs = *vhs = 0;
3607 strcpy(type,"PrelBase_Z91Z93_closure");
3611 ip = (P_) INFO_PTR(closure);
3613 switch (INFO_TYPE(ip)) {
3614 case INFO_SPEC_U_TYPE:
3615 case INFO_SPEC_S_TYPE:
3616 case INFO_SPEC_N_TYPE:
3617 *size = SPEC_CLOSURE_SIZE(closure);
3618 *ptrs = SPEC_CLOSURE_NoPTRS(closure);
3619 *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
3620 *vhs = 0 /*SPEC_VHS*/;
3621 strcpy(type,"SPEC");
3624 case INFO_GEN_U_TYPE:
3625 case INFO_GEN_S_TYPE:
3626 case INFO_GEN_N_TYPE:
3627 *size = GEN_CLOSURE_SIZE(closure);
3628 *ptrs = GEN_CLOSURE_NoPTRS(closure);
3629 *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
3635 *size = DYN_CLOSURE_SIZE(closure);
3636 *ptrs = DYN_CLOSURE_NoPTRS(closure);
3637 *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
3642 case INFO_TUPLE_TYPE:
3643 *size = TUPLE_CLOSURE_SIZE(closure);
3644 *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
3645 *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
3647 strcpy(type,"TUPLE");
3650 case INFO_DATA_TYPE:
3651 *size = DATA_CLOSURE_SIZE(closure);
3652 *ptrs = DATA_CLOSURE_NoPTRS(closure);
3653 *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
3655 strcpy(type,"DATA");
3658 case INFO_IMMUTUPLE_TYPE:
3659 case INFO_MUTUPLE_TYPE:
3660 *size = MUTUPLE_CLOSURE_SIZE(closure);
3661 *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
3662 *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
3664 strcpy(type,"(IM)MUTUPLE");
3667 case INFO_STATIC_TYPE:
3668 *size = STATIC_CLOSURE_SIZE(closure);
3669 *ptrs = STATIC_CLOSURE_NoPTRS(closure);
3670 *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
3672 strcpy(type,"STATIC");
3677 *size = IND_CLOSURE_SIZE(closure);
3678 *ptrs = IND_CLOSURE_NoPTRS(closure);
3679 *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
3681 strcpy(type,"CAF|IND");
3684 case INFO_CONST_TYPE:
3685 *size = CONST_CLOSURE_SIZE(closure);
3686 *ptrs = CONST_CLOSURE_NoPTRS(closure);
3687 *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
3689 strcpy(type,"CONST");
3692 case INFO_SPEC_RBH_TYPE:
3693 *size = SPEC_RBH_CLOSURE_SIZE(closure);
3694 *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
3695 *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
3697 *nonptrs -= (2 - *ptrs);
3701 *vhs = SPEC_RBH_VHS;
3702 strcpy(type,"SPEC_RBH");
3705 case INFO_GEN_RBH_TYPE:
3706 *size = GEN_RBH_CLOSURE_SIZE(closure);
3707 *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
3708 *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
3710 *nonptrs -= (2 - *ptrs);
3715 strcpy(type,"GEN_RBH");
3718 case INFO_CHARLIKE_TYPE:
3719 *size = CHARLIKE_CLOSURE_SIZE(closure);
3720 *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
3721 *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
3722 *vhs = CHARLIKE_VHS;
3723 strcpy(type,"CHARLIKE");
3726 case INFO_INTLIKE_TYPE:
3727 *size = INTLIKE_CLOSURE_SIZE(closure);
3728 *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
3729 *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
3731 strcpy(type,"INTLIKE");
3735 case INFO_FETCHME_TYPE:
3736 *size = FETCHME_CLOSURE_SIZE(closure);
3737 *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
3738 *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
3740 strcpy(type,"FETCHME");
3743 case INFO_FMBQ_TYPE:
3744 *size = FMBQ_CLOSURE_SIZE(closure);
3745 *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
3746 *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
3748 strcpy(type,"FMBQ");
3753 *size = BQ_CLOSURE_SIZE(closure);
3754 *ptrs = BQ_CLOSURE_NoPTRS(closure);
3755 *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
3761 *size = BH_CLOSURE_SIZE(closure);
3762 *ptrs = BH_CLOSURE_NoPTRS(closure);
3763 *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
3769 *size = 0; /* TSO_CLOSURE_SIZE(closure); */
3770 *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
3771 *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
3776 case INFO_STKO_TYPE:
3781 strcpy(type,"STKO");
3785 fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
3786 INFO_TYPE(ip), (StgWord) closure);
3795 // Use allocate in Storage.c instead
3797 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
3798 is available, but it will not perform garbage collection.
3799 ToDo: check whether we can use an existing STG allocation routine -- HWL
3803 //@cindex AllocateHeap
3810 /* Allocate a new closure */
3811 if (Hp + size > HpLim)
3814 newClosure = Hp + 1;
3823 //@cindex doGlobalGC
3827 fprintf(stderr,"Splat -- we just hit global GC!\n");
3828 stg_exit(EXIT_FAILURE);
3829 //fishing = rtsFalse;
3830 outstandingFishes--;
3835 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
3836 //@subsection Printing Packet Contents
3838 Printing Packet Contents
3841 #if defined(DEBUG) || defined(GRAN_CHECK)
3843 //@cindex PrintPacket
3847 PrintPacket(packBuffer)
3848 rtsPackBuffer *packBuffer;
3850 StgClosure *parent, *graphroot, *closure_start;
3851 const StgInfoTable *ip;
3853 StgWord **bufptr, **slotptr;
3856 nat pptr = 0, pptrs = 0, pvhs;
3859 nat size, ptrs, nonptrs, vhs;
3862 /* disable printing if a non-std globalisation scheme is used; ToDo: FIX */
3863 if (RtsFlags.ParFlags.globalising != 0)
3866 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3867 unpacking components replaced by printing fcts
3868 Long live higher-order fcts!
3870 /* Initialisation */
3871 //InitPackBuffer(); /* in case it isn't already init'd */
3873 // ASSERT(gaga==PendingGABuffer);
3874 graphroot = (StgClosure *)NULL;
3876 /* Unpack the header */
3877 bufsize = packBuffer->size;
3878 bufptr = packBuffer->buffer;
3880 fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
3881 packBuffer->id, packBuffer);
3882 fprintf(stderr, "*. size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
3883 packBuffer->size, packBuffer->unpacked_size,
3884 packBuffer->tso, packBuffer->buffer);
3886 parent = (StgClosure *)NULL;
3889 /* This is where we will ultimately save the closure's address */
3891 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3893 /* First, unpack the next GA or PLC */
3894 ga.weight = (rtsWeight) *bufptr++;
3896 if (ga.weight == 2) { // unglobalised closure to follow
3897 // nothing to do; closure starts at *bufptr
3898 } else if (ga.weight > 0) { // fill in GA
3899 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3900 ga.payload.gc.slot = (int) *bufptr++;
3902 ga.payload.plc = (StgPtr) *bufptr++;
3904 /* Now unpack the closure body, if there is one */
3906 fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
3907 // closure = ga.payload.plc;
3908 } else if (isOffset(&ga)) {
3909 fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
3910 // closure = (StgClosure *) buffer[ga.payload.gc.slot];
3912 /* Print normal closures */
3914 ASSERT(bufsize > 0);
3916 fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
3917 ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
3919 closure_start = (StgClosure*)bufptr;
3920 ip = get_closure_info((StgClosure *)bufptr,
3921 &size, &ptrs, &nonptrs, &vhs, str);
3923 /* ToDo: check whether this is really needed */
3924 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
3926 ptrs = nonptrs = vhs = 0;
3928 /* ToDo: check whether this is really needed */
3929 if (ip->type == ARR_WORDS) {
3931 nonptrs = arr_words_words(((StgArrWords *)bufptr));
3932 size = arr_words_sizeW((StgArrWords *)bufptr);
3935 /* special code for printing a PAP in a buffer */
3936 if (ip->type == PAP || ip->type == AP_UPD) {
3939 nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
3940 size = _HS+vhs+ptrs+nonptrs;
3944 Remember, the generic closure layout is as follows:
3945 +-------------------------------------------------+
3946 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
3947 +-------------------------------------------------+
3949 /* Print fixed header */
3950 fprintf(stderr, "FH [");
3951 for (i = 0; i < _HS; i++)
3952 fprintf(stderr, " %p", *bufptr++);
3954 if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
3955 size = ptrs = nonptrs = vhs = 0;
3957 // VH is always empty in the new RTS
3959 ip->type == PAP || ip->type == AP_UPD);
3960 /* Print variable header */
3961 fprintf(stderr, "] VH [");
3962 for (i = 0; i < vhs; i++)
3963 fprintf(stderr, " %p", *bufptr++);
3965 //fprintf(stderr, "] %d PTRS [", ptrs);
3966 /* Pointers will be filled in later */
3968 fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
3969 /* Print non-pointers */
3970 for (i = 0; i < nonptrs; i++)
3971 fprintf(stderr, " %p", *bufptr++);
3973 fprintf(stderr, "] (%s)\n", str);
3975 /* Indirections are never packed */
3976 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
3978 /* Add to queue for processing
3979 When just printing the packet we do not have an unpacked closure
3980 in hand, so we feed it the packet entry;
3981 again, this assumes that at least the fixed header of the closure
3982 has the same layout in the packet; also we may not overwrite entries
3983 in the packet (done in Unpack), but for printing that's a bad idea
3985 QueueClosure((StgClosure *)closure_start);
3987 /* No Common up needed for printing */
3989 /* No Sort out the global address mapping for printing */
3991 } /* normal closure case */
3993 /* Locate next parent pointer */
3995 while (pptr + 1 > pptrs) {
3996 parent = DeQueueClosure();
4001 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4006 } while (parent != NULL);
4007 fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
4008 packBuffer->id, packBuffer->size, size);
4013 Doing a sanity check on a packet.
4014 This does a full iteration over the packet, as in PrintPacket.
4016 //@cindex checkPacket
4018 checkPacket(packBuffer)
4019 rtsPackBuffer *packBuffer;
4021 StgClosure *parent, *graphroot, *closure_start;
4022 const StgInfoTable *ip;
4024 StgWord **bufptr, **slotptr;
4027 nat pptr = 0, pptrs = 0, pvhs;
4029 nat size, ptrs, nonptrs, vhs;
4032 /* NB: this whole routine is more or less a copy of UnpackGraph with all
4033 unpacking components replaced by printing fcts
4034 Long live higher-order fcts!
4036 /* Initialisation */
4037 //InitPackBuffer(); /* in case it isn't already init'd */
4039 // ASSERT(gaga==PendingGABuffer);
4040 graphroot = (StgClosure *)NULL;
4042 /* Unpack the header */
4043 bufsize = packBuffer->size;
4044 bufptr = packBuffer->buffer;
4045 parent = (StgClosure *)NULL;
4046 ASSERT(bufsize > 0);
4048 /* check that we are not at the end of the buffer, yet */
4049 IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
4051 /* This is where we will ultimately save the closure's address */
4053 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
4054 ASSERT(locn<=bufsize);
4056 /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
4057 ga.weight = (rtsWeight) *bufptr++;
4059 if (ga.weight == 2) { // unglobalised closure to follow
4060 // nothing to do; closure starts at *bufptr
4061 } else if (ga.weight > 0) { // fill in GA
4062 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
4063 ga.payload.gc.slot = (int) *bufptr++;
4065 ga.payload.plc = (StgPtr) *bufptr++;
4067 /* Now unpack the closure body, if there is one */
4070 ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
4071 } else if (isOffset(&ga)) {
4072 ASSERT(ga.payload.gc.slot<=(int)bufsize);
4074 /* normal closure */
4075 ASSERT(!RtsFlags.ParFlags.globalising==0 || LOOKS_LIKE_GA(&ga));
4077 closure_start = (StgClosure*)bufptr;
4078 ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
4079 ip = get_closure_info((StgClosure *)bufptr,
4080 &size, &ptrs, &nonptrs, &vhs, str);
4082 /* ToDo: check whether this is really needed */
4083 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
4085 ptrs = nonptrs = vhs = 0;
4087 /* ToDo: check whether this is really needed */
4088 if (ip->type == ARR_WORDS) {
4090 nonptrs = arr_words_words(((StgArrWords *)bufptr))+1; // payload+words
4091 size = arr_words_sizeW((StgArrWords *)bufptr);
4092 ASSERT(size==_HS+vhs+nonptrs);
4094 /* special code for printing a PAP in a buffer */
4095 if (ip->type == PAP || ip->type == AP_UPD) {
4098 nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
4099 size = _HS+vhs+ptrs+nonptrs;
4102 /* no checks on contents of closure (pointers aren't packed anyway) */
4103 ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
4104 bufptr += _HS+vhs+nonptrs;
4106 /* Add to queue for processing */
4107 QueueClosure((StgClosure *)closure_start);
4109 /* No Common up needed for checking */
4111 /* No Sort out the global address mapping for checking */
4113 } /* normal closure case */
4115 /* Locate next parent pointer */
4117 while (pptr + 1 > pptrs) {
4118 parent = DeQueueClosure();
4123 //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
4124 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4129 } while (parent != NULL);
4130 /* we unpacked exactly as many words as there are in the buffer */
4131 ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
4132 /* check for magic end-of-buffer word */
4133 IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
4138 rtsPackBuffer *buffer;
4140 // extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
4141 // extern char *display_info_type(P_ infoptr); /* defined in Threads.lc */
4144 nat size, ptrs, nonptrs, vhs;
4145 char info_hdr_ty[80];
4146 char str1[80], str2[80], junk_str[80];
4148 /* globalAddr ga; */
4150 nat bufsize, unpacked_size ;
4152 nat pptr = 0, pptrs = 0, pvhs;
4154 nat unpack_locn = 0;
4155 nat gastart = unpack_locn;
4156 nat closurestart = unpack_locn;
4159 StgClosure *closure, *p;
4163 fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
4164 fprintf(stderr, " size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
4165 buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
4166 fputs(" contents: ", stderr);
4167 for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
4168 closure = buffer->buffer[unpack_locn];
4169 fprintf(stderr, ", %p (%s)",
4170 closure, info_type(closure));
4172 fputc('\n', stderr);
4175 /* traverse all elements of the graph; omitted for now, but might be usefule */
4180 /* Unpack the header */
4181 unpacked_size = buffer->unpacked_size;
4182 bufsize = buffer->size;
4184 fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
4185 buffer, bufsize, unpacked_size,
4186 tso->id, tso, where_is((StgClosure*)tso));
4189 closurestart = unpack_locn;
4190 closure = buffer->buffer[unpack_locn++];
4192 fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
4194 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
4196 fprintf(stderr, "(%s|%s) ", str1, str2);
4198 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
4199 IS_BLACK_HOLE(closure))
4200 size = ptrs = nonptrs = vhs = 0;
4202 if (closure_THUNK(closure)) {
4203 if (closure_UNPOINTED(closure))
4204 fputs("UNPOINTED ", stderr);
4206 fputs("POINTED ", stderr);
4208 if (IS_BLACK_HOLE(closure)) {
4209 fputs("BLACK HOLE\n", stderr);
4212 fprintf(stderr, "FH [");
4213 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
4214 fprintf(stderr, " %p", *p);
4218 fprintf(stderr, "] VH [%p", closure->payload[_HS]);
4220 for (i = 1; i < vhs; i++)
4221 fprintf(stderr, " %p", closure->payload[_HS+i]);
4224 fprintf(stderr, "] PTRS %u", ptrs);
4228 fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
4230 for (i = 1; i < nonptrs; i++)
4231 fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
4237 } while (unpack_locn<bufsize) ; /* (parent != NULL); */
4239 fprintf(stderr, "--- End ---\n\n");
4243 #endif /* DEBUG || GRAN_CHECK */
4245 #endif /* PAR || GRAN -- whole file */
4247 //@node End of file, , Printing Packet Contents, Graph packing
4248 //@subsection End of file
4251 //* AllocateHeap:: @cindex\s-+AllocateHeap
4252 //* AmPacking:: @cindex\s-+AmPacking
4253 //* CommonUp:: @cindex\s-+CommonUp
4254 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
4255 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
4256 //* DonePacking:: @cindex\s-+DonePacking
4257 //* FillInClosure:: @cindex\s-+FillInClosure
4258 //* IS_BLACK_HOLE:: @cindex\s-+IS_BLACK_HOLE
4259 //* IS_INDIRECTION:: @cindex\s-+IS_INDIRECTION
4260 //* InitClosureQueue:: @cindex\s-+InitClosureQueue
4261 //* InitPendingGABuffer:: @cindex\s-+InitPendingGABuffer
4262 //* LocateNextParent:: @cindex\s-+LocateNextParent
4263 //* NotYetPacking:: @cindex\s-+NotYetPacking
4264 //* OffsetFor:: @cindex\s-+OffsetFor
4265 //* Pack:: @cindex\s-+Pack
4266 //* PackArray:: @cindex\s-+PackArray
4267 //* PackClosure:: @cindex\s-+PackClosure
4268 //* PackFetchMe:: @cindex\s-+PackFetchMe
4269 //* PackGeneric:: @cindex\s-+PackGeneric
4270 //* PackNearbyGraph:: @cindex\s-+PackNearbyGraph
4271 //* PackOneNode:: @cindex\s-+PackOneNode
4272 //* PackPAP:: @cindex\s-+PackPAP
4273 //* PackPLC:: @cindex\s-+PackPLC
4274 //* PackStkO:: @cindex\s-+PackStkO
4275 //* PackTSO:: @cindex\s-+PackTSO
4276 //* PendingGABuffer:: @cindex\s-+PendingGABuffer
4277 //* PrintPacket:: @cindex\s-+PrintPacket
4278 //* QueueClosure:: @cindex\s-+QueueClosure
4279 //* QueueEmpty:: @cindex\s-+QueueEmpty
4280 //* RoomToPack:: @cindex\s-+RoomToPack
4281 //* SetGAandCommonUp:: @cindex\s-+SetGAandCommonUp
4282 //* UnpackGA:: @cindex\s-+UnpackGA
4283 //* UnpackGraph:: @cindex\s-+UnpackGraph
4284 //* UnpackOffset:: @cindex\s-+UnpackOffset
4285 //* UnpackPLC:: @cindex\s-+UnpackPLC
4286 //* doGlobalGC:: @cindex\s-+doGlobalGC
4287 //* get_closure_info:: @cindex\s-+get_closure_info
4288 //* InitPackBuffer:: @cindex\s-+initPackBuffer
4289 //* isFixed:: @cindex\s-+isFixed
4290 //* isOffset:: @cindex\s-+isOffset
4291 //* offsetTable:: @cindex\s-+offsetTable